From: William Harold Newman Date: Thu, 1 Mar 2001 16:00:12 +0000 (+0000) Subject: 0.6.11.7: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4a4f1e5ca70363d64d7cbb141863a387334e6760;p=sbcl.git 0.6.11.7: hacking on 0.6.11.5 patches, continued.. ..MAKE-HASH-TABLE :TEST #'EQUAL uses 'EQUAL instead. ..tested that PRINT-PRETTY-ON-STREAM? stuff doesn't get confused on Gray streams ..added test case for new byte compiler bug ..removed extra DUP in patched GENERATE-BYTE-CODE-FOR-SET new DEFCONSTANT cleanups, as per AL, sbcl-devel, 2001-02-27 Wrapping DEFCONSTANT +EMPTY-HT-SLOT+ in EVAL-WHEN seems to cause problems, so instead I moved the +EMPTY-HT-SLOT+ definition 'way early in stems-and-flags.lisp-expr. --- diff --git a/NEWS b/NEWS index 25cd7d9..7a79666 100644 --- a/NEWS +++ b/NEWS @@ -706,3 +706,4 @@ planned incompatible changes in 0.7.x: e.g. UNPROFILE will interact with TRACE and UNTRACE. (This shouldn't matter, though, unless you are using profiling. If you never profile anything, TRACE should continue to behave as before.) +* The fasl file extension may change, perhaps to ".fasl". \ No newline at end of file diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3e98854..eef14df 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -795,6 +795,9 @@ retained, possibly temporariliy, because it might be used internally." "UNIX-ENVIRONMENT-CMUCL-FROM-SBCL" "UNIX-ENVIRONMENT-SBCL-FROM-CMUCL" + ;; a sort of quasi unbound tag for use in hash tables + "+EMPTY-HT-SLOT+" + ;; not used any more, I think -- WHN 19991206 #+nil ("SERVE-BUTTON-PRESS" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 13e80e8..15ec5dd 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -767,7 +767,8 @@ (cond ((and lisp-path-fp c-path-fp) ;; Both still seem valid - choose the lisp frame. #+nil (when (zerop depth) - (format t "debug: both still valid ~S ~S ~S ~S~%" + (format t + "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) #+freebsd (if (sap> lisp-ocfp c-ocfp) diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index f4cc5b8..b82a585 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -12,35 +12,6 @@ (in-package "SB!IMPL") -;;; an internal tag for marking empty slots -;;; -;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty -;;; since it's easily accessible to the user, so that e.g. -;;; (DEFVAR *HT* (MAKE-HASH-TABLE)) -;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY) -;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V))) -;;; gives no output -- oops! -;;; -;;; Note that as of version 0.6.6 there's a dependence in the gencgc.c -;;; code on this value being a symbol. (This is only one of many nasty -;;; dependencies between that code and this, alas.) -(defconstant +empty-ht-slot+ '%empty-ht-slot%) -;;; KLUDGE: Using a private symbol still leaves us vulnerable to users -;;; getting nonconforming behavior by messing around with -;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for -;;; now we just don't worry about it. If for some reason it becomes -;;; worrisome and the magic value needs replacement: -;;; * The replacement value needs to be LOADable with EQL preserved, -;;; so that macroexpansion for WITH-HASH-TABLE-ITERATOR will work -;;; when compiled into a file and loaded back into SBCL. -;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.) -;;; * The replacement value needs to be acceptable to the -;;; low-level gencgc.lisp hash table scavenging code. -;;; * The change will break binary compatibility, since comparisons -;;; against the value used at the time of compilation are wired -;;; into FASL files. -;;; -- WHN 20000622 - ;;; HASH-TABLE is implemented as a STRUCTURE-OBJECT. (sb!xc:defstruct (hash-table (:constructor %make-hash-table)) ;; The type of hash table this is. Only used for printing and as @@ -93,7 +64,7 @@ ;; hash associated with the key, saving recalculation. Could be ;; useful for EQL, and EQUAL hash tables. This table is not needed ;; for EQ hash tables, and when present the value of #x8000000 - ;; represents EQ-based hashing on the respective Key. + ;; represents EQ-based hashing on the respective key. (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*))))) (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body) @@ -120,8 +91,8 @@ (let ((key (aref kv-vector (* 2 index))) (value (aref kv-vector (1+ (* 2 index))))) (incf index) - (unless (and (eq key '#.+empty-ht-slot+) - (eq value '#.+empty-ht-slot+)) + (unless (and (eq key +empty-ht-slot+) + (eq value +empty-ht-slot+)) (return (values t key value)))))))) #',function)))) (macrolet ((,function () '(funcall ,n-function))) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 3a8a71d..2f739c0 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -12,6 +12,46 @@ (in-package "SB!INT") +;;;; target constants which need to appear as early as possible + +;;; an internal tag for marking empty slots, which needs to be defined +;;; as early as possible because it appears in macroexpansions for +;;; iteration over hash tables +;;; +;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty +;;; since it's easily accessible to the user, so that e.g. +;;; (DEFVAR *HT* (MAKE-HASH-TABLE)) +;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY) +;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V))) +;;; gives no output -- oops! +;;; +;;; FIXME: It'd probably be good to use the unbound marker for this. +;;; However, there might be some gotchas involving assumptions by +;;; e.g. AREF that they're not going to return the unbound marker, +;;; and there's also the noted-below problem that the C-level code +;;; contains implicit assumptions about this marker. +;;; +;;; KLUDGE: Note that as of version 0.6.6 there's a dependence in the +;;; gencgc.c code on this value being a symbol. (This is only one of +;;; many nasty dependencies between that code and this, alas.) +;;; -- WHN 2001-02-28 +(defconstant +empty-ht-slot+ '%empty-ht-slot%) +;;; KLUDGE: Using a private symbol still leaves us vulnerable to users +;;; getting nonconforming behavior by messing around with +;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for +;;; now we just don't worry about it. If for some reason it becomes +;;; worrisome and the magic value needs replacement: +;;; * The replacement value needs to be LOADable with EQL preserved, +;;; so that macroexpansion for WITH-HASH-TABLE-ITERATOR will work +;;; when compiled into a file and loaded back into SBCL. +;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.) +;;; * The replacement value needs to be acceptable to the +;;; low-level gencgc.lisp hash table scavenging code. +;;; * The change will break binary compatibility, since comparisons +;;; against the value used at the time of compilation are wired +;;; into FASL files. +;;; -- WHN 20000622 + ;;;; DO-related stuff which needs to be visible on the cross-compilation host (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/code/print.lisp b/src/code/print.lisp index 3a52072..7164452 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -260,7 +260,7 @@ (cond ((print-pretty-on-stream-p stream) ;; Since we're printing prettily on STREAM, format the ;; object within a logical block. PPRINT-LOGICAL-BLOCK does - ;; not rebind the stream when it is already a pretty stream + ;; not rebind the stream when it is already a pretty stream, ;; so output from the body will go to the same stream. (pprint-logical-block (stream nil :prefix "#<" :suffix ">") (print-description))) @@ -954,34 +954,34 @@ (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) - (cond ((or *print-escape* *print-readably*) - (write-char #\" stream) - (quote-string vector stream) - (write-char #\" stream)) - (t - (write-string vector stream)))) + (cond ((or *print-escape* *print-readably*) + (write-char #\" stream) + (quote-string vector stream) + (write-char #\" stream)) + (t + (write-string vector stream)))) ((not (or *print-array* *print-readably*)) - (output-terse-array vector stream)) + (output-terse-array vector stream)) ((bit-vector-p vector) - (write-string "#*" stream) - (dotimes (i (length vector)) - (output-object (aref vector i) stream))) + (write-string "#*" stream) + (dotimes (i (length vector)) + (output-object (aref vector i) stream))) (t - (when (and *print-readably* - (not (eq (array-element-type vector) 't))) - (error 'print-not-readable :object vector)) - (descend-into (stream) - (write-string "#(" stream) - (dotimes (i (length vector)) - (unless (zerop i) - (write-char #\space stream)) - (punt-print-if-too-long i stream) - (output-object (aref vector i) stream)) - (write-string ")" stream))))) - -;;; This function outputs a string quoting characters sufficiently that so -;;; someone can read it in again. Basically, put a slash in front of an -;;; character satisfying NEEDS-SLASH-P + (when (and *print-readably* + (not (eq (array-element-type vector) 't))) + (error 'print-not-readable :object vector)) + (descend-into (stream) + (write-string "#(" stream) + (dotimes (i (length vector)) + (unless (zerop i) + (write-char #\space stream)) + (punt-print-if-too-long i stream) + (output-object (aref vector i) stream)) + (write-string ")" stream))))) + +;;; This function outputs a string quoting characters sufficiently +;;; that so someone can read it in again. Basically, put a slash in +;;; front of an character satisfying NEEDS-SLASH-P. (defun quote-string (string stream) (macrolet ((needs-slash-p (char) ;; KLUDGE: We probably should look at the readtable, but just do diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 96c9700..67796d1 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -274,7 +274,7 @@ ,@body)))) ;;; Check for stupid typos in FLAGS list keywords. -(let ((stems (make-hash-table :test #'equal))) +(let ((stems (make-hash-table :test 'equal))) (for-stems-and-flags (stem flags) (if (gethash stem stems) (error "duplicate stem ~S in stems-and-flags data" stem) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index f8eb793..a024055 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -1266,9 +1266,6 @@ (values (if info (byte-continuation-info-results info) 0))) - (unless (eql values 0) - ;; Someone wants the value, so copy it. - (output-do-xop segment 'dup)) (etypecase leaf (global-var (ecase (global-var-kind leaf) @@ -1280,15 +1277,15 @@ ;; references to the variable before we actually try to set it. ;; (Setting a lexical variable with no refs caused bugs ca. CMU ;; CL 18c, because the compiler deletes such variables.) - (cond ((leaf-refs leaf) - (unless (eql values 0) - ;; Someone wants the value, so copy it. - (output-do-xop segment 'dup)) - (output-set-lambda-var segment leaf (node-environment set))) - ;; If no one wants the value, then pop it, else leave it - ;; for them. - ((eql values 0) - (output-byte-with-operand segment byte-pop-n 1))))) + (cond ((leaf-refs leaf) + (unless (eql values 0) + ;; Someone wants the value, so copy it. + (output-do-xop segment 'dup)) + (output-set-lambda-var segment leaf (node-environment set))) + ;; If no one wants the value, then pop it, else leave it + ;; for them. + ((eql values 0) + (output-byte-with-operand segment byte-pop-n 1))))) (unless (eql values 0) (checked-canonicalize-values segment cont 1))) (values)) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index c48ca7a..183bd29 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -829,12 +829,13 @@ (defun reference-this-var-to-keep-it-alive (node) node) -;;; This sets a sb!c::cset node's var to value, returning value. When var is -;;; local, we have to compare its home environment to the current one, node's -;;; environment. If they're the same, we check to see whether the var is -;;; indirect, and store the value on the stack or in the value cell as -;;; appropriate. Otherwise, var is a closure variable, and since we're -;;; setting it, we know its location contains an indirect value object. +;;; This sets a SB!C::CSET node's var to value, returning value. When +;;; var is local, we have to compare its home environment to the +;;; current one, node's environment. If they're the same, we check to +;;; see whether the var is indirect, and store the value on the stack +;;; or in the value cell as appropriate. Otherwise, var is a closure +;;; variable, and since we're setting it, we know its location +;;; contains an indirect value object. (defun set-leaf-value (node frame-ptr closure value) (let ((var (sb!c::set-var node))) (etypecase var @@ -844,7 +845,7 @@ (setf (symbol-value (sb!c::global-var-name var)) value))))) ;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools' -;;; internals uses this also to set interpreted local variables. +;;; internals use this also to set interpreted local variables. (defun set-leaf-value-lambda-var (node var frame-ptr closure value) ;; Note: We avoid trying to set a lexical variable with no refs ;; because the compiler deletes such variables. @@ -852,22 +853,22 @@ (let ((env (sb!c::node-environment node))) (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var)) env)) - (setf (indirect-value - (svref closure - (position var (sb!c::environment-closure env) - :test #'eq))) - value)) + (setf (indirect-value + (svref closure + (position var (sb!c::environment-closure env) + :test #'eq))) + value)) ((sb!c::lambda-var-indirect var) - (setf (indirect-value - (eval-stack-local frame-ptr (sb!c::lambda-var-info var))) - value)) + (setf (indirect-value + (eval-stack-local frame-ptr (sb!c::lambda-var-info var))) + value)) (t - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) - value)))))) + (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) + value)))))) -;;; This figures out how to return a value for a ref node. Leaf is the ref's -;;; structure that tells us about the value, and it is one of the following -;;; types: +;;; This figures out how to return a value for a ref node. LEAF is the +;;; ref's structure that tells us about the value, and it is one of +;;; the following types: ;;; constant -- It knows its own value. ;;; global-var -- It's either a value or function reference. Get it right. ;;; local-var -- This may on the stack or in the current closure, the @@ -955,35 +956,39 @@ (indirect-value temp) temp))) -;;; This computes a closure for a local call and for returned call'able closure -;;; objects. Sometimes the closure is a simple-vector of no elements. Node -;;; is either a reference node or a combination node. Leaf is either the leaf -;;; of the reference node or the lambda to internally apply for the combination -;;; node. Frame-ptr is the current frame pointer for fetching current values -;;; to store in the closure. Closure is the current closure, the currently -;;; interpreting lambda's closed over environment. -;;; -;;; A computed closure is a vector corresponding to the list of closure -;;; variables described in an environment. The position of a lambda-var in -;;; this closure list is the index into the closure vector of values. +;;; Compute a closure for a local call and for returned call'able +;;; closure objects. Sometimes the closure is a SIMPLE-VECTOR of no +;;; elements. NODE is either a reference node or a combination node. +;;; LEAF is either the leaf of the reference node or the lambda to +;;; internally apply for the combination node. FRAME-PTR is the +;;; current frame pointer for fetching current values to store in the +;;; closure. CLOSURE is the current closure, the closed-over +;;; environment of the currently interpreting LAMBDA. ;;; -;;; Functional-env is the environment description for leaf, the lambda for -;;; which we're computing a closure. This environment describes which of -;;; lambda's vars we find in lambda's closure when it's running, versus finding -;;; them on the stack. For each lambda-var in the functional environment's -;;; closure list, if the lambda-var's home environment is the current -;;; environment, then get a value off the stack and store it in the closure -;;; we're computing. Otherwise that lambda-var's value comes from somewhere -;;; else, but we have it in our current closure, the environment we're running -;;; in as we compute this new closure. Find this value the same way we do in -;;; LEAF-VALUE, by finding the lambda-var's position in the current -;;; environment's description of the current closure. +;;; A computed closure is a vector corresponding to the list of +;;; closure variables described in an environment. The position of a +;;; lambda-var in this closure list is the index into the closure +;;; vector of values. (defun compute-closure (node leaf frame-ptr closure) (let* ((current-env (sb!c::node-environment node)) (current-closure-vars (sb!c::environment-closure current-env)) + ;; FUNCTIONAL-ENV is the environment description for leaf, + ;; the lambda for which we're computing a closure. This + ;; environment describes which of lambda's vars we find in + ;; lambda's closure when it's running, versus finding them on + ;; the stack. (functional-env (sb!c::lambda-environment leaf)) (functional-closure-vars (sb!c::environment-closure functional-env)) (functional-closure (make-array (length functional-closure-vars)))) + ;; For each lambda-var VAR in the functional environment's closure + ;; list, if the VAR's home environment is the current environment, + ;; then get a value off the stack and store it in the closure + ;; we're computing. Otherwise VAR's value comes from somewhere + ;; else, but we have it in our current closure, the environment + ;; we're running in as we compute this new closure. Find this + ;; value the same way we do in LEAF-VALUE, by finding VAR's + ;; position in the current environment's description of the + ;; current closure. (do ((vars functional-closure-vars (cdr vars)) (i 0 (1+ i))) ((null vars)) @@ -1008,7 +1013,7 @@ (sb!c::nlx-info-cleanup ele)) (sb!c::lambda-eval-info-entries (sb!c::lambda-info - ;; lambda INTERNAL-APPLY-LOOP tosses around. + ;; the lambda INTERNAL-APPLY-LOOP tosses around (sb!c::environment-function (sb!c::node-environment node)))))))) (svref closure @@ -1016,11 +1021,11 @@ :test #'eq)))))))) functional-closure)) -;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack -;;; on some arguments also taken from the stack. When tail-p is non-nil, -;;; control does not return to INTERNAL-APPLY to further interpret the current -;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's -;;; stack frame. +;;; INTERNAL-APPLY uses this to invoke a function from the +;;; interpreter's stack on some arguments also taken from the stack. +;;; When tail-p is non-nil, control does not return to INTERNAL-APPLY +;;; to further interpret the current IR1 lambda, so INTERNAL-INVOKE +;;; must clean up the current interpreter's stack frame. (defun internal-invoke (arg-count &optional tailp) (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first. (fun (eval-stack-pop))) @@ -1029,8 +1034,9 @@ (format t "(~S~{ ~S~})~%" fun args)) (apply fun args))) -;;; Almost just like INTERNAL-INVOKE. We call MV-EVAL-STACK-ARGS, and our -;;; function is in a list on the stack instead of simply on the stack. +;;; This is almost just like INTERNAL-INVOKE. We call +;;; MV-EVAL-STACK-ARGS, and our function is in a list on the stack +;;; instead of simply on the stack. (defun mv-internal-invoke (arg-count &optional tailp) (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first. (fun (car (eval-stack-pop)))) @@ -1039,15 +1045,16 @@ (format t "(~S~{ ~S~})~%" fun args)) (apply fun args))) -;;; This returns a list of the top arg-count elements on the interpreter's +;;; Return a list of the top arg-count elements on the interpreter's ;;; stack. This removes them from the stack. (defun eval-stack-args (arg-count) (let ((args nil)) (dotimes (i arg-count args) (push (eval-stack-pop) args)))) -;;; This assumes the top count elements on interpreter's stack are lists. This -;;; returns a single list with all the elements from these lists. +;;; This assumes the top count elements on interpreter's stack are +;;; lists. This returns a single list with all the elements from these +;;; lists. (defun mv-eval-stack-args (count) (if (= count 1) (eval-stack-pop) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index b9a60b6..389844c 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -21,6 +21,9 @@ ;;; the main types. These types are represented by the low three bits ;;; of the pointer or immediate object. (eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary (at least for Lispworks), because the + ;; second DEFENUM uses the value of OTHER-IMMEDIATE-0-TYPE, which is + ;; defined in the first DEFENUM. -- AL 20000216 (defenum (:suffix -type) even-fixnum function-pointer diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 268afc5..7478656 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -197,7 +197,10 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defconstant list-to-hash-table-threshold 32) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; below. -- AL 20010227 + (defconstant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index 9ed8e2b..cf523ad 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -97,6 +97,9 @@ ;;;; generation of emit functions (eval-when (:compile-toplevel :load-toplevel :execute) + ;; We need the EVAL-WHEN because %EMIT-GENERIC-VOP (below) + ;; uses #.MAX-VOP-TN-REFS, not just MAX-VOP-TN-REFS. + ;; -- AL 20010218 (defconstant max-vop-tn-refs 256)) (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil)) diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 94c5c8b..a46bbbe 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -30,7 +30,11 @@ (let ((offset-sym (symbolicate name "-OFFSET")) (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) `(progn - (defconstant ,offset-sym ,offset) + (eval-when (:compile-toplevel :load-toplevel :execute) + ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET + ;; (in the same file) depends on compile-time evaluation + ;; of the DEFCONSTANT. -- AL 20010224 + (defconstant ,offset-sym ,offset)) (setf (svref ,names-vector ,offset-sym) ,(symbol-name name))))) ;; FIXME: It looks to me as though DEFREGSET should also diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index f456693..4f23946 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -695,7 +695,7 @@ (defvar *note-iis-entry-p* nil) (defvar *compiled-initialize-instance-simple-functions* - (make-hash-table :test #'equal)) + (make-hash-table :test 'equal)) (defun initialize-instance-simple-function (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index f0a966d..43ccf96 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -2925,12 +2925,12 @@ scav_vector(lispobj *where, lispobj object) * the hash table code reserves for marking empty slots. */ scavenge(where+3, 1); if (!Pointerp(where[3])) { - lose("not #:%EMPTY-HT-SLOT% symbol pointer: %x", where[3]); + lose("not empty-hash-table-slot symbol pointer: %x", where[3]); } empty_symbol = where[3]; /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/ if (TypeOf(*(lispobj *)PTR(empty_symbol)) != type_SymbolHeader) { - lose("not a symbol where #:%EMPTY-HT-SLOT% expected: %x", + lose("not a symbol where empty-hash-table-slot symbol expected: %x", *(lispobj *)PTR(empty_symbol)); } diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp new file mode 100644 index 0000000..8c7dd8e --- /dev/null +++ b/tests/compiler.pure-cload.lisp @@ -0,0 +1,22 @@ +;;;; miscellaneous tests of compiling toplevel forms + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +;;; Exercise a compiler bug (by causing a call to ERROR). +;;; +;;; This bug was in sbcl-0.6.11.6. +(let ((a 1) (b 1)) + (declare (type (mod 1000) a b)) + (let ((tmp (= 10 (+ (incf a) (incf a) (incf b) (incf b))))) + (or tmp (error "TMP not true")))) diff --git a/tests/gray-streams.impure.lisp b/tests/gray-streams.impure.lisp index 5f96206..585aa0a 100644 --- a/tests/gray-streams.impure.lisp +++ b/tests/gray-streams.impure.lisp @@ -183,6 +183,19 @@ (assert (null (fresh-line our-char-output))) (write-char #\c our-char-output))) (format nil "a ~%b~%c"))) + +;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic +;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some +;;; cases. Try to verify that we don't end up doing tests like that on +;;; bare Gray streams and thus bogusly omitting pretty-printing +;;; operations. +(flet ((frob () + (with-output-to-string (string) + (let ((gray-output-stream (make-character-output-stream string))) + (format gray-output-stream + "~@~%"))))) + (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob))))) + (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob)))))) ;;;; example classes for binary output diff --git a/tests/run-tests.sh b/tests/run-tests.sh index e4de8cf..90e7581 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -14,7 +14,7 @@ # more information. # how we invoke SBCL -sbcl=${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --noprint --noprogrammer} +sbcl=${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer} # "Ten four" is the closest numerical slang I can find to "OK", so # it's the Unix status value that we expect from a successful test. @@ -80,4 +80,17 @@ for f in *.assertoids; do fi done +# *.pure-cload.lisp files want to be compiled, then loaded. They +# can all be done in the same invocation of Lisp. +echo //running '*.pure-cload.lisp' tests +for f in *.pure-cload.lisp; do + if [ -f $f ]; then + echo //running $f test + $sbcl <