0.6.11.7:
authorWilliam Harold Newman <william.newman@airmail.net>
Thu, 1 Mar 2001 16:00:12 +0000 (16:00 +0000)
committerWilliam Harold Newman <william.newman@airmail.net>
Thu, 1 Mar 2001 16:00:12 +0000 (16:00 +0000)
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.

19 files changed:
NEWS
package-data-list.lisp-expr
src/code/debug-int.lisp
src/code/hash-table.lisp
src/code/primordial-extensions.lisp
src/code/print.lisp
src/cold/shared.lisp
src/compiler/byte-comp.lisp
src/compiler/eval.lisp
src/compiler/generic/early-objdef.lisp
src/compiler/ir1tran.lisp
src/compiler/vmdef.lisp
src/compiler/x86/vm.lisp
src/pcl/fast-init.lisp
src/runtime/gencgc.c
tests/compiler.pure-cload.lisp [new file with mode: 0644]
tests/gray-streams.impure.lisp
tests/run-tests.sh
version.lisp-expr

diff --git a/NEWS b/NEWS
index 25cd7d9..7a79666 100644 (file)
--- 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
index 3e98854..eef14df 100644 (file)
@@ -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"
index 13e80e8..15ec5dd 100644 (file)
               (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)
index f4cc5b8..b82a585 100644 (file)
 
 (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) (*)))))
 \f
 (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
                         (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)))
index 3a8a71d..2f739c0 100644 (file)
 
 (in-package "SB!INT")
 \f
+;;;; 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
+\f
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
index 3a52072..7164452 100644 (file)
     (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)))
 (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
index 96c9700..67796d1 100644 (file)
         ,@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)
index f8eb793..a024055 100644 (file)
         (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)
        ;; 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))
index c48ca7a..183bd29 100644 (file)
 (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
        (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.
     (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
        (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))
                              (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
                                      :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)))
       (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))))
       (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)
index b9a60b6..389844c 100644 (file)
@@ -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
index 268afc5..7478656 100644 (file)
 ;;; 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))
index 9ed8e2b..cf523ad 100644 (file)
@@ -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))
index 94c5c8b..a46bbbe 100644 (file)
             (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
index f456693..4f23946 100644 (file)
 (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))
index f0a966d..43ccf96 100644 (file)
@@ -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 (file)
index 0000000..8c7dd8e
--- /dev/null
@@ -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"))))
index 5f96206..585aa0a 100644 (file)
        (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
+                    "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
+  (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
+  (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
 \f
 ;;;; example classes for binary output
 
index e4de8cf..90e7581 100644 (file)
@@ -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 <<EOF ; tenfour
+               (compile-file "$f")
+               (progn (load *) (sb-ext:quit :unix-status 104))
+EOF
+    fi
+done
+
 echo '//apparent success (reached end of run-tests.sh normally)'
index a77725e..7eafa79 100644 (file)
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.11.6"
+"0.6.11.7"