Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv12829/src/compiler

Modified Files:
	checkgen.lisp 
Log Message:
0.7.9.13:
        Disabled type checking of arguments in MV-COMBINATION


Index: checkgen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- checkgen.lisp	27 Sep 2002 11:30:57 -0000	1.25
+++ checkgen.lisp	29 Oct 2002 17:28:13 -0000	1.26
@@ -260,6 +260,9 @@
 	   (let ((kind (basic-combination-kind dest)))
 	     (cond ((eq cont (basic-combination-fun dest)) t)
 		   ((eq kind :local) t)
+                   ((mv-combination-p dest)
+                    ;; See bug 220
+                    nil)
                    ((not (eq (continuation-asserted-type cont)
                              (continuation-externally-checkable-type cont)))
                     ;; There is an explicit assertion.

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv12829/tests

Modified Files:
	compiler-1.impure-cload.lisp 
Log Message:
0.7.9.13:
        Disabled type checking of arguments in MV-COMBINATION


Index: compiler-1.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler-1.impure-cload.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- compiler-1.impure-cload.lisp	3 May 2002 14:59:15 -0000	1.8
+++ compiler-1.impure-cload.lisp	29 Oct 2002 17:28:13 -0000	1.9
@@ -106,4 +106,14 @@
 	     (make-array 3 :element-type t :initial-element 0))
 	    nil))
 
+;;; bug 220: type check inserted after all arguments in MV-CALL caused
+;;; failure of stack analysis
+(defun bug220-helper ()
+  13)
+(assert (equal (multiple-value-call #'list
+                 (the integer (bug220-helper))
+                 nil)
+               '(13 nil)))
+
 (sb-ext:quit :unix-status 104) ; success
+

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv12829

Modified Files:
	BUGS version.lisp-expr 
Log Message:
0.7.9.13:
        Disabled type checking of arguments in MV-COMBINATION


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.224
retrieving revision 1.225
diff -u -d -r1.224 -r1.225
--- BUGS	29 Oct 2002 12:48:20 -0000	1.224
+++ BUGS	29 Oct 2002 17:28:06 -0000	1.225
@@ -1290,6 +1290,21 @@
   * (baz t)
   1
 
+220: 
+  Sbcl 0.7.9 fails to compile
+
+  (multiple-value-call #'list
+    (the integer (helper))
+    nil)
+
+  Type check for INTEGER is inserted, the result of which serves as
+  the first argument of M-V-C, is inserted after evaluation of NIL. So
+  arguments of M-V-C are pushed in the wrong order. As a temporary
+  workaround type checking was disabled for M-V-Cs in 0.7.9.13. A
+  better solution would be to put a check between evaluation of
+  arguments, but it could be tricky to check result types of PROG1, IF
+  etc.
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.621
retrieving revision 1.622
diff -u -d -r1.621 -r1.622
--- version.lisp-expr	29 Oct 2002 12:48:20 -0000	1.621
+++ version.lisp-expr	29 Oct 2002 17:28:09 -0000	1.622
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.12"
+"0.7.9.13"

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv5275/tests

Modified Files:
	clos.impure.lisp type.impure.lisp 
Log Message:
0.7.9.12:
	Fix for BUG 140 (not opening bug 176 this time) from Gerd Moellmann,
		on cmucl-imp 86fzuwdkmy.fsf@... and
		private communication;
		entomotomy reference: redefined-classes-and-subtypep
	... slightly kludgy logic in FORCE-CACHE-FLUSHES
	... break me if you can
	BUGS frobbage, too; delete several old bugs that are probably
		fixed now.


Index: clos.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- clos.impure.lisp	29 Oct 2002 10:02:31 -0000	1.17
+++ clos.impure.lisp	29 Oct 2002 12:48:21 -0000	1.18
@@ -327,6 +327,21 @@
 (assert (eq (no-next-method-test 1) 'success))
 (assert (null (ignore-errors (no-next-method-test 'foo))))
 
+;;; regression test for bug 176, following a fix that seems
+;;; simultaneously to fix 140 while not exposing 176 (by Gerd
+;;; Moellmann, merged in sbcl-0.7.9.12).
+(dotimes (i 10)
+  (let ((lastname (intern (format nil "C176-~D" (1- i))))
+        (name (intern (format nil "C176-~D" i))))
+  (eval `(defclass ,name
+             (,@(if (= i 0) nil (list lastname)))
+           ()))
+  (eval `(defmethod initialize-instance :after ((x ,name) &rest any)
+           (declare (ignore any))))))
+(defclass b176 () (aslot-176))
+(defclass c176-0 (b176) ())
+(assert (= 1 (setf (slot-value (make-instance 'c176-9) 'aslot-176) 1)))
+
 ;;;; success
 
 (sb-ext:quit :unix-status 104)

Index: type.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/type.impure.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- type.impure.lisp	21 Aug 2002 10:30:08 -0000	1.22
+++ type.impure.lisp	29 Oct 2002 12:48:21 -0000	1.23
@@ -339,14 +339,14 @@
 (tests-of-inline-type-tests)
 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 
-#|| Pending fix for bug 176, bug 140 has been unfixed
 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 (defclass superclass () ())
+(defclass maybe-subclass () ())
+(assert-nil-t (subtypep 'maybe-subclass 'superclass))
 (defclass maybe-subclass (superclass) ())
 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 (defclass maybe-subclass () ())
 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
-||#
 
 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
 ;;; specialized on some as-yet-undefined type which would cause this

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv5275

Modified Files:
	BUGS version.lisp-expr 
Log Message:
0.7.9.12:
	Fix for BUG 140 (not opening bug 176 this time) from Gerd Moellmann,
		on cmucl-imp 86fzuwdkmy.fsf@... and
		private communication;
		entomotomy reference: redefined-classes-and-subtypep
	... slightly kludgy logic in FORCE-CACHE-FLUSHES
	... break me if you can
	BUGS frobbage, too; delete several old bugs that are probably
		fixed now.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.223
retrieving revision 1.224
diff -u -d -r1.223 -r1.224
--- BUGS	27 Oct 2002 14:52:48 -0000	1.223
+++ BUGS	29 Oct 2002 12:48:20 -0000	1.224
@@ -356,9 +356,6 @@
   crashes SBCL. In general tracing anything which is used in the 
   implementation of TRACE is likely to have the same problem.
 
-72:
-  (DECLAIM (OPTIMIZE ..)) doesn't work properly inside LOCALLY forms.
-
 75:
   As reported by Martin Atzmueller on sbcl-devel 26 Dec 2000,
   ANSI says that WITH-OUTPUT-TO-STRING should have a keyword
@@ -499,18 +496,6 @@
   the first time around, until regression tests are written I'm not 
   comfortable merging the patches in the CVS version of SBCL.
 
-104:
-  (DESCRIBE 'SB-ALIEN:DEF-ALIEN-TYPE) reports the macro argument list
-  incorrectly:
-	DEF-ALIEN-TYPE is
-	  an external symbol
-	  in #<PACKAGE "SB-ALIEN">.
-	Macro-function: #<FUNCTION "DEF!MACRO DEF-ALIEN-TYPE" {19F4A39}>
-	  Macro arguments:  (#:whole-470 #:environment-471)
-	  On Sat, May 26, 2001 09:45:57 AM CDT it was compiled from:
-	  /usr/stuff/sbcl/src/code/host-alieneval.lisp
-	    Created: Monday, March 12, 2001 07:47:43 AM CST
-
 108:
   (TIME (ROOM T)) reports more than 200 Mbytes consed even for
   a clean, just-started SBCL system. And it seems to be right:
@@ -584,26 +569,6 @@
    is attached to FOO in 120a above, and used to optimize code which
    calls FOO. 
 
-122:
-   There was some sort of screwup in handling of
-   (IF (NOT (IGNORE-ERRORS ..))). E.g.
-	(defun foo1i ()
-	  (if (not (ignore-errors
-		     (make-pathname :host "foo"
-                                    :directory "!bla"
-                                    :name "bar")))
-	      (print "ok")
-	      (error "notunlessnot")))
-   The (NOT (IGNORE-ERRORS ..)) form evaluates to T, so this should be
-   printing "ok", but instead it's going to the ERROR. This problem
-   seems to've been introduced by MNA's HANDLER-CASE patch (sbcl-devel
-   2001-07-17) and as a workaround (put in sbcl-0.pre7.14.flaky4.12)
-   I reverted back to the old weird HANDLER-CASE code. However, I
-   think the problem looks like a compiler bug in handling RETURN-FROM,
-   so I left the MNA-patched code in HANDLER-CASE (suppressed with
-   #+NIL) and I'd like to go back to see whether this really is
-   a compiler bug before I delete this BUGS entry.
-
 124:
    As of version 0.pre7.14, SBCL's implementation of MACROLET makes
    the entire lexical environment at the point of MACROLET available
@@ -693,36 +658,6 @@
         (call-next-method)))
   Now (FOO 3) should return 3, but instead it returns 4.
 
-140:
-  (reported by Alexey Dejneka sbcl-devel 2002-01-03)
-
-  SUBTYPEP does not work well with redefined classes:
-  ---
-  * (defclass a () ())
-  #<STANDARD-CLASS A>
-  * (defclass b () ())
-  #<STANDARD-CLASS B>
-  * (subtypep 'b 'a)
-  NIL
-  T
-  * (defclass b (a) ())
-  #<STANDARD-CLASS B>
-  * (subtypep 'b 'a)
-  T
-  T
-  * (defclass b () ())
-  #<STANDARD-CLASS B>
-
-  ;;; And now...
-  * (subtypep 'b 'a)
-  T
-  T
-
-  This bug was fixed in sbcl-0.7.4.1 by invalidating the PCL wrapper
-  class upon redefinition. Unfortunately, doing so causes bug #176 to
-  appear.  Pending further investigation, one or other of these bugs
-  might be present at any given time.
-
 141: 
   Pretty-printing nested backquotes doesn't work right, as 
   reported by Alexey Dejneka sbcl-devel 2002-01-13:
@@ -908,39 +843,6 @@
   code. Since then the warning has been downgraded to STYLE-WARNING, 
   so it's still a bug but at least it's a little less annoying.
 
-176:
-  reported by Alexey Dejneka 08 Jun 2002 in sbcl-devel:
-    Playing with McCLIM, I've received an error "Unbound variable WRAPPER
-    in SB-PCL::CHECK-WRAPPER-VALIDITY".
-      (defun check-wrapper-validity (instance)
-        (let* ((owrapper (wrapper-of instance)))
-          (if (not (invalid-wrapper-p owrapper))
-              owrapper
-              (let* ((state (wrapper-state wrapper)) ; !!!
-        ...
-    I've tried to replace it with OWRAPPER, but now OBSOLETE-INSTANCE-TRAP
-    breaks with "NIL is not of type SB-KERNEL:LAYOUT".
-    SBCL 0.7.4.13.
-  partial fix: The undefined variable WRAPPER resulted from an error
-  in recent refactoring, as can be seen by comparing to the code in e.g. 
-  sbcl-0.7.2. Replacing WRAPPER with OWRAPPER (done by WHN in sbcl-0.7.4.22)
-  should bring the code back to its behavior as of sbcl-0.7.2, but
-  that still leaves the OBSOLETE-INSTANCE-TRAP bug. An example of 
-  input which triggers that bug is
-    (dotimes (i 20)
-      (let ((lastname (intern (format nil "C~D" (1- i))))
-            (name (intern (format nil "C~D" i))))
-      (eval `(defclass ,name
-                 (,@(if (= i 0) nil (list lastname)))
-               ()))
-      (eval `(defmethod initialize-instance :after ((x ,name) &rest any)
-               (declare (ignore any))))))
-    (defclass b () ())
-    (defclass c0 (b) ())
-    (make-instance 'c19)
-
-  See also bug #140.
-
 178: "AVER failure compiling confused THEs in FUNCALL"
   In sbcl-0.7.4.24, compiling
     (defun bug178 (x)
@@ -1254,12 +1156,6 @@
   package: FOO-SLOT". (This is fairly bad code, but still it's hard
   to see that it should cause symbols to be interned in the CL package.)
 
-209: "DOCUMENTATION generic function has wrong argument precedence order"
-  (fixed in sbcl-0.7.8.39)
-
-210: "unsafe evaluation of DEFSTRUCT slot initforms in BOA constructors"
-  (fixed in sbcl-0.7.8.35)
-
 211: "keywords processing"
   a. :ALLOW-OTHER-KEYS T should allow a function to receive an odd
      number of keyword arguments.
@@ -1276,7 +1172,6 @@
        ; caught STYLE-WARNING:
        ;   The variable #:G15 is defined but never used.
 
-
 212: "Sequence functions and circular arguments"
   COERCE, MERGE and CONCATENATE go into an infinite loop when given
   circular arguments; it would be good for the user if they could be
@@ -1326,7 +1221,7 @@
   a. FIND and POSITION currently signal errors when given non-NIL for
      both their :TEST and (deprecated) :TEST-NOT arguments, but by
      ANSI 17.2 "the consequences are unspecified", which by ANSI 1.4.2
-     means that the effect is "unpredictable but harmless.  It's not
+     means that the effect is "unpredictable but harmless".  It's not
      clear what that actually means; it may preclude conforming
      implementations from signalling errors.
   b. COUNT, REMOVE and the like give priority to a :TEST-NOT argument

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.620
retrieving revision 1.621
diff -u -d -r1.620 -r1.621
--- version.lisp-expr	29 Oct 2002 10:19:43 -0000	1.620
+++ version.lisp-expr	29 Oct 2002 12:48:20 -0000	1.621
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.11"
+"0.7.9.12"

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv5275/src/pcl

Modified Files:
	braid.lisp cache.lisp slots-boot.lisp slots.lisp 
	std-class.lisp 
Log Message:
0.7.9.12:
	Fix for BUG 140 (not opening bug 176 this time) from Gerd Moellmann,
		on cmucl-imp 86fzuwdkmy.fsf@... and
		private communication;
		entomotomy reference: redefined-classes-and-subtypep
	... slightly kludgy logic in FORCE-CACHE-FLUSHES
	... break me if you can
	BUGS frobbage, too; delete several old bugs that are probably
		fixed now.


Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- braid.lisp	29 Oct 2002 10:02:30 -0000	1.24
+++ braid.lisp	29 Oct 2002 12:48:20 -0000	1.25
@@ -578,7 +578,7 @@
               (sb-kernel:order-layout-inherits
                (map 'simple-vector #'class-wrapper
                     (reverse (rest (class-precedence-list class))))))
-      (sb-kernel:register-layout layout :invalidate nil)
+      (sb-kernel:register-layout layout :invalidate t)
 
       ;; Subclasses of formerly forward-referenced-class may be
       ;; unknown to CL:FIND-CLASS and also anonymous. This

Index: cache.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- cache.lisp	26 Oct 2002 11:00:11 -0000	1.25
+++ cache.lisp	29 Oct 2002 12:48:21 -0000	1.26
@@ -261,44 +261,6 @@
 (defmacro wrapper-no-of-instance-slots (wrapper)
   `(sb-kernel:layout-length ,wrapper))
 
-;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly)
-;;; iff the wrapper is valid. Any other return value denotes some
-;;; invalid state. Special conventions have been set up for certain
-;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN
-;;; 19991204) haven't been motivated to reverse engineer them from the
-;;; code and document them here.
-;;;
-;;; FIXME: We have removed the persistent use of this function throughout
-;;; the PCL codebase, instead opting to use INVALID-WRAPPER-P, which 
-;;; abstractly tests the return result of this function for invalidness.
-;;; However, part of the original comment that is still applicable follows.
-;;;   --njf, 2002-05-02
-;;;
-;;; FIXME: It would probably be even better to switch the sense of the
-;;; WRAPPER-STATE function, renaming it to WRAPPER-INVALID and making it
-;;; synonymous with LAYOUT-INVALID. Then the INVALID-WRAPPER-P function
-;;; would become trivial and would go away (replaced with
-;;; WRAPPER-INVALID), since all the various invalid wrapper states would
-;;; become generalized boolean "true" values. -- WHN 19991204
-#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
-(defun wrapper-state (wrapper)
-  (let ((invalid (sb-kernel:layout-invalid wrapper)))
-    (cond ((null invalid)
-	   t)
-	  ((atom invalid)
-	   ;; some non-PCL object. INVALID is probably :INVALID. We
-	   ;; should arguably compute the new wrapper here instead of
-	   ;; returning NIL, but we don't bother, since
-	   ;; OBSOLETE-INSTANCE-TRAP can't use it.
-	   '(:obsolete nil))
-	  (t
-	   invalid))))
-(defun (setf wrapper-state) (new-value wrapper)
-  (setf (sb-kernel:layout-invalid wrapper)
-	(if (eq new-value t)
-	    nil
-	    new-value)))
-
 (defmacro wrapper-instance-slots-layout (wrapper)
   `(%wrapper-instance-slots-layout ,wrapper))
 (defmacro wrapper-class-slots (wrapper)
@@ -411,63 +373,52 @@
 
 (declaim (inline invalid-wrapper-p))
 (defun invalid-wrapper-p (wrapper)
-  (neq (wrapper-state wrapper) t))
+  (not (null (sb-kernel:layout-invalid wrapper))))
 
 (defvar *previous-nwrappers* (make-hash-table))
 
 (defun invalidate-wrapper (owrapper state nwrapper)
-  (ecase state
-    ((:flush :obsolete)
-     (let ((new-previous ()))
-       ;; First off, a previous call to INVALIDATE-WRAPPER may have
-       ;; recorded OWRAPPER as an NWRAPPER to update to. Since
-       ;; OWRAPPER is about to be invalid, it no longer makes sense to
-       ;; update to it.
-       ;;
-       ;; We go back and change the previously invalidated wrappers so
-       ;; that they will now update directly to NWRAPPER. This
-       ;; corresponds to a kind of transitivity of wrapper updates.
-       (dolist (previous (gethash owrapper *previous-nwrappers*))
-	 (when (eq state :obsolete)
-	   (setf (car previous) :obsolete))
-	 (setf (cadr previous) nwrapper)
-	 (push previous new-previous))
+  (aver (member state '(:flush :obsolete) :test #'eq))
+  (let ((new-previous ()))
+    ;; First off, a previous call to INVALIDATE-WRAPPER may have
+    ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
+    ;; is about to be invalid, it no longer makes sense to update to
+    ;; it.
+    ;;
+    ;; We go back and change the previously invalidated wrappers so
+    ;; that they will now update directly to NWRAPPER. This
+    ;; corresponds to a kind of transitivity of wrapper updates.
+    (dolist (previous (gethash owrapper *previous-nwrappers*))
+      (when (eq state :obsolete)
+	(setf (car previous) :obsolete))
+      (setf (cadr previous) nwrapper)
+      (push previous new-previous))
 
-       (let ((ocnv (wrapper-cache-number-vector owrapper)))
-	 (dotimes (i sb-kernel:layout-clos-hash-length)
-	   (setf (cache-number-vector-ref ocnv i) 0)))
-       (push (setf (wrapper-state owrapper) (list state nwrapper))
-	     new-previous)
+    (let ((ocnv (wrapper-cache-number-vector owrapper)))
+      (dotimes (i sb-kernel:layout-clos-hash-length)
+	(setf (cache-number-vector-ref ocnv i) 0)))
 
-       (setf (gethash owrapper *previous-nwrappers*) ()
-	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
+    (push (setf (sb-kernel:layout-invalid owrapper) (list state nwrapper))
+	  new-previous)
+
+    (setf (gethash owrapper *previous-nwrappers*) ()
+	  (gethash nwrapper *previous-nwrappers*) new-previous)))
 
 (defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance)))
-    (if (not (invalid-wrapper-p owrapper))
+  (let* ((owrapper (wrapper-of instance))
+	 (state (sb-kernel:layout-invalid owrapper)))
+    (if (null state)
 	owrapper
-	(let* ((state (wrapper-state owrapper))
-	       (nwrapper
-		(ecase (car state)
-		  (:flush
-		   (flush-cache-trap owrapper (cadr state) instance))
-		  (:obsolete
-		   (obsolete-instance-trap owrapper (cadr state) instance)))))
-	  ;; This little bit of error checking is superfluous. It only
-	  ;; checks to see whether the person who implemented the trap
-	  ;; handling screwed up. Since that person is hacking
-	  ;; internal PCL code, and is not a user, this should be
-	  ;; needless. Also, since this directly slows down instance
-	  ;; update and generic function cache refilling, feel free to
-	  ;; take it out sometime soon.
-	  ;;
-	  ;; FIXME: We probably need to add a #+SB-PARANOID feature to
-	  ;; make stuff like this optional. Until then, it stays in.
-	  (cond ((neq nwrapper (wrapper-of instance))
-		 (error "wrapper returned from trap not wrapper of instance"))
-		((invalid-wrapper-p nwrapper)
-		 (error "wrapper returned from trap invalid")))
-	  nwrapper))))
+	(ecase (car state)
+	  (:flush
+	   (flush-cache-trap owrapper (cadr state) instance))
+	  (:obsolete
+	   (obsolete-instance-trap owrapper (cadr state) instance))))))
+
+(declaim (inline check-obsolete-instance))
+(defun check-obsolete-instance (instance)
+  (when (invalid-wrapper-p (sb-kernel:layout-of instance))
+    (check-wrapper-validity instance)))
 
 (defvar *free-caches* nil)
 

Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- slots-boot.lisp	3 Oct 2002 02:00:24 -0000	1.13
+++ slots-boot.lisp	29 Oct 2002 12:48:21 -0000	1.14
@@ -99,18 +99,21 @@
    (etypecase index
      (fixnum (if fsc-p
 		 (lambda (instance)
+		   (check-obsolete-instance instance)
 		   (let ((value (clos-slots-ref (fsc-instance-slots instance)
 						index)))
 		     (if (eq value +slot-unbound+)
 			 (slot-unbound (class-of instance) instance slot-name)
 			 value)))
 		 (lambda (instance)
+		   (check-obsolete-instance instance)
 		   (let ((value (clos-slots-ref (std-instance-slots instance)
 					      index)))
 		     (if (eq value +slot-unbound+)
 			 (slot-unbound (class-of instance) instance slot-name)
 			 value)))))
      (cons   (lambda (instance)
+	       (check-obsolete-instance instance)
 	       (let ((value (cdr index)))
 		 (if (eq value +slot-unbound+)
 		     (slot-unbound (class-of instance) instance slot-name)
@@ -123,13 +126,15 @@
    (etypecase index
      (fixnum (if fsc-p
 		 (lambda (nv instance)
+		   (check-obsolete-instance instance)
 		   (setf (clos-slots-ref (fsc-instance-slots instance) index)
 			 nv))
 		 (lambda (nv instance)
+		   (check-obsolete-instance instance)
 		   (setf (clos-slots-ref (std-instance-slots instance) index)
 			 nv))))
      (cons   (lambda (nv instance)
-	       (declare (ignore instance))
+	       (check-obsolete-instance instance)
 	       (setf (cdr index) nv))))
    `(writer ,slot-name)))
 
@@ -139,15 +144,17 @@
    (etypecase index
      (fixnum (if fsc-p
 		 (lambda (instance)
+		   (check-obsolete-instance instance)
 		   (not (eq (clos-slots-ref (fsc-instance-slots instance)
 					    index)
 			    +slot-unbound+)))
 		 (lambda (instance)
+		   (check-obsolete-instance instance)
 		   (not (eq (clos-slots-ref (std-instance-slots instance)
 					    index)
 			    +slot-unbound+)))))
      (cons (lambda (instance)
-	     (declare (ignore instance))
+	     (check-obsolete-instance instance)
 	     (not (eq (cdr index) +slot-unbound+)))))
    `(boundp ,slot-name)))
 
@@ -201,7 +208,7 @@
     (fixnum (if fsc-p
 		(lambda (class instance slotd)
 		  (declare (ignore slotd))
-		  (unless (fsc-instance-p instance) (error "not fsc"))
+		  (check-obsolete-instance instance)
 		  (let ((value (clos-slots-ref (fsc-instance-slots instance)
 					       index)))
 		    (if (eq value +slot-unbound+)
@@ -209,7 +216,7 @@
 			value)))
 		(lambda (class instance slotd)
 		  (declare (ignore slotd))
-		  (unless (std-instance-p instance) (error "not std"))
+		  (check-obsolete-instance instance)
 		  (let ((value (clos-slots-ref (std-instance-slots instance)
 					       index)))
 		    (if (eq value +slot-unbound+)
@@ -217,6 +224,7 @@
 			value)))))
     (cons   (lambda (class instance slotd)
 	      (declare (ignore slotd))
+	      (check-obsolete-instance instance)
 	      (let ((value (cdr index)))
 		(if (eq value +slot-unbound+)
 		    (slot-unbound class instance slot-name)
@@ -230,14 +238,17 @@
     (fixnum (if fsc-p
 		(lambda (nv class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (setf (clos-slots-ref (fsc-instance-slots instance) index)
 			nv))
 		(lambda (nv class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (setf (clos-slots-ref (std-instance-slots instance) index)
 			nv))))
     (cons  (lambda (nv class instance slotd)
-	     (declare (ignore class instance slotd))
+	     (declare (ignore class slotd))
+	     (check-obsolete-instance instance)
 	     (setf (cdr index) nv)))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
@@ -248,14 +259,17 @@
     (fixnum (if fsc-p
 		(lambda (class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
 			   +slot-unbound+)))
 		(lambda (class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (not (eq (clos-slots-ref (std-instance-slots instance) index)
 			   +slot-unbound+)))))
     (cons   (lambda (class instance slotd)
-	      (declare (ignore class instance slotd))
+	      (declare (ignore class slotd))
+	      (check-obsolete-instance instance)
 	      (not (eq (cdr index) +slot-unbound+))))))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)

Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- slots.lisp	18 May 2002 22:13:07 -0000	1.10
+++ slots.lisp	29 Oct 2002 12:48:21 -0000	1.11
@@ -187,19 +187,14 @@
 (defmethod slot-value-using-class ((class std-class)
 				   (object std-object)
 				   (slotd standard-effective-slot-definition))
+  (check-obsolete-instance object)
   (let* ((location (slot-definition-location slotd))
 	 (value (typecase location
 		  (fixnum
 		   (cond ((std-instance-p object)
-			  (when (invalid-wrapper-p (std-instance-wrapper
-                                                    object))
-			    (check-wrapper-validity object))
 			  (clos-slots-ref (std-instance-slots object)
 					  location))
 			 ((fsc-instance-p object)
-			  (when (invalid-wrapper-p (fsc-instance-wrapper
-                                                    object))
-			    (check-wrapper-validity object))
 			  (clos-slots-ref (fsc-instance-slots object)
 					  location))
 			 (t (error "unrecognized instance type"))))
@@ -218,19 +213,16 @@
 	   (new-value (class std-class)
 		      (object std-object)
 		      (slotd standard-effective-slot-definition))
+  (check-obsolete-instance object)
   (let ((location (slot-definition-location slotd)))
     (typecase location
       (fixnum
        (cond ((std-instance-p object)
-	      (when (invalid-wrapper-p (std-instance-wrapper object))
-		(check-wrapper-validity object))
-               (setf (clos-slots-ref (std-instance-slots object) location)
-		     new-value))
+	      (setf (clos-slots-ref (std-instance-slots object) location)
+		    new-value))
 	     ((fsc-instance-p object)
-	      (when (invalid-wrapper-p (fsc-instance-wrapper object))
-		(check-wrapper-validity object))
-               (setf (clos-slots-ref (fsc-instance-slots object) location)
-		     new-value))
+	      (setf (clos-slots-ref (fsc-instance-slots object) location)
+		    new-value))
 	     (t (error "unrecognized instance type"))))
       (cons
        (setf (cdr location) new-value))
@@ -243,19 +235,14 @@
 	   ((class std-class)
 	    (object std-object)
 	    (slotd standard-effective-slot-definition))
+  (check-obsolete-instance object)
   (let* ((location (slot-definition-location slotd))
 	 (value (typecase location
 		  (fixnum
 		   (cond ((std-instance-p object)
-			  (when (invalid-wrapper-p (std-instance-wrapper
-                                                    object))
-			    (check-wrapper-validity object))
 			  (clos-slots-ref (std-instance-slots object)
 					  location))
 			 ((fsc-instance-p object)
-			  (when (invalid-wrapper-p (fsc-instance-wrapper
-                                                    object))
-			    (check-wrapper-validity object))
 			  (clos-slots-ref (fsc-instance-slots object)
 					  location))
 			 (t (error "unrecognized instance type"))))
@@ -272,19 +259,16 @@
 	   ((class std-class)
 	    (object std-object)
 	    (slotd standard-effective-slot-definition))
+  (check-obsolete-instance object)
   (let ((location (slot-definition-location slotd)))
     (typecase location
       (fixnum
        (cond ((std-instance-p object)
-	      (when (invalid-wrapper-p (std-instance-wrapper object))
-		(check-wrapper-validity object))
-               (setf (clos-slots-ref (std-instance-slots object) location)
-		     +slot-unbound+))
+	      (setf (clos-slots-ref (std-instance-slots object) location)
+		    +slot-unbound+))
 	     ((fsc-instance-p object)
-	      (when (invalid-wrapper-p (fsc-instance-wrapper object))
-		(check-wrapper-validity object))
-               (setf (clos-slots-ref (fsc-instance-slots object) location)
-		     +slot-unbound+))
+	      (setf (clos-slots-ref (fsc-instance-slots object) location)
+		    +slot-unbound+))
 	     (t (error "unrecognized instance type"))))
       (cons
        (setf (cdr location) +slot-unbound+))

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- std-class.lisp	28 Oct 2002 14:33:31 -0000	1.29
+++ std-class.lisp	29 Oct 2002 12:48:21 -0000	1.30
@@ -1050,12 +1050,17 @@
 
 (defun force-cache-flushes (class)
   (let* ((owrapper (class-wrapper class)))
-    ;; We only need to do something if the state is still T. If the
-    ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
-    ;; will already be doing what we want. In particular, we must be
-    ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
-    ;; means do what FLUSH does and then some.
-    (unless (invalid-wrapper-p owrapper)
+    ;; We only need to do something if the wrapper is still valid. If
+    ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
+    ;; both of those will already be doing what we want. In
+    ;; particular, we must be sure we never change an OBSOLETE into a
+    ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
+    (when (or (not (invalid-wrapper-p owrapper))
+	      ;; Ick. LAYOUT-INVALID can return a list (which we can
+	      ;; handle), T (which we can't), NIL (which is handled by
+	      ;; INVALID-WRAPPER-P) or :UNINITIALIZED (which never
+	      ;; gets here (I hope).  -- CSR, 2002-10-28
+	      (eq (sb-kernel:layout-invalid owrapper) t))
       (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
 				    class)))
 	(setf (wrapper-instance-slots-layout nwrapper)

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv16160/src/compiler

Modified Files:
	array-tran.lisp 
Log Message:
0.7.9.11:
	Remove bogus #-CMU unoptimization (punting on SB-FLUID problems
		as described in BUG 206)


Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- array-tran.lisp	3 Oct 2002 01:05:30 -0000	1.35
+++ array-tran.lisp	29 Oct 2002 10:19:44 -0000	1.36
@@ -573,10 +573,7 @@
 			   ,@(when offset-var `(,offset-var)))
 	 (if (not (array-header-p ,n-array))
 	     (let ((,n-array ,n-array))
-	       ;; The #-CMU is because tonyms reported (sbcl-devel
-	       ;; 2002-09-29) that this declaration confuses old CMU
-	       ;; CL on x86 Debian 2.2. -- WHN 2002-10-02
-	       #-cmu (declare (type (simple-array * (*)) ,n-array))
+	       (declare (type (simple-array * (*)) ,n-array))
 	       ,(once-only ((n-len `(length ,n-array))
 			    (n-end `(or ,n-evalue ,n-len)))
 		  `(if (<= ,n-svalue ,n-end ,n-len)

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv16160

Modified Files:
	version.lisp-expr 
Log Message:
0.7.9.11:
	Remove bogus #-CMU unoptimization (punting on SB-FLUID problems
		as described in BUG 206)


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.619
retrieving revision 1.620
diff -u -d -r1.619 -r1.620
--- version.lisp-expr	29 Oct 2002 10:02:29 -0000	1.619
+++ version.lisp-expr	29 Oct 2002 10:19:43 -0000	1.620
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.10"
+"0.7.9.11"

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv10321/tests

Modified Files:
	clos.impure.lisp 
Log Message:
0.7.9.10:
	Implement NO-NEXT-METHOD (following Gerd Moellmann on cmucl-imp
		in message 86vg5rryqn.fsf@...
		entomotomy reference: no-next-method-unimplemented)
	... add a comment in boot.lisp describing coupling of %METHOD-NAME 
		declaration to NO-NEXT-METHOD implementation


Index: clos.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- clos.impure.lisp	26 Oct 2002 11:22:51 -0000	1.16
+++ clos.impure.lisp	29 Oct 2002 10:02:31 -0000	1.17
@@ -318,6 +318,14 @@
 			  (declare (special y))))
   (assert-program-error (defgeneric bogus-declaration2 (x)
 			  (declare (notinline concatenate)))))
+;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next
+;;; method.
+(defmethod no-next-method-test ((x integer)) (call-next-method))
+(assert (null (ignore-errors (no-next-method-test 1))))
+(defmethod no-next-method ((g (eql #'no-next-method-test)) m &rest args)
+  'success)
+(assert (eq (no-next-method-test 1) 'success))
+(assert (null (ignore-errors (no-next-method-test 'foo))))
 
 ;;;; success

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv10321/src/pcl

Modified Files:
	boot.lisp braid.lisp generic-functions.lisp 
Log Message:
0.7.9.10:
	Implement NO-NEXT-METHOD (following Gerd Moellmann on cmucl-imp
		in message 86vg5rryqn.fsf@...
		entomotomy reference: no-next-method-unimplemented)
	... add a comment in boot.lisp describing coupling of %METHOD-NAME 
		declaration to NO-NEXT-METHOD implementation


Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -d -r1.56 -r1.57
--- boot.lisp	28 Oct 2002 14:33:29 -0000	1.56
+++ boot.lisp	29 Oct 2002 10:02:30 -0000	1.57
@@ -515,6 +515,13 @@
 		 ;; another declaration (e.g. %BLOCK-NAME), so that
 		 ;; our method debug names are free to have any format,
 		 ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
+		 ;;
+		 ;; Further, as of sbcl-0.7.9.10, the code to
+		 ;; implement NO-NEXT-METHOD is coupled to the form of
+		 ;; this declaration; see the definition of
+		 ;; CALL-NO-NEXT-METHOD (and the passing of
+		 ;; METHOD-NAME-DECLARATION arguments around the
+		 ;; various CALL-NEXT-METHOD logic).
 		 (declare (%method-name (,name
 					 ,@qualifiers
 					 ,specializers)))
@@ -726,6 +733,14 @@
 					:call-next-method-p
 					,call-next-method-p
 					:next-method-p-p ,next-method-p-p
+			                ;; we need to pass this along
+			                ;; so that NO-NEXT-METHOD can
+			                ;; be given a suitable METHOD
+			                ;; argument; we need the
+			                ;; QUALIFIERS and SPECIALIZERS
+			                ;; inside the declaration to
+			                ;; give to FIND-METHOD.
+			                :method-name-declaration ,name-decl
 					:closurep ,closurep
 					:applyp ,applyp)
 			  ,@walked-declarations
@@ -769,18 +784,32 @@
 		       (,',next-methods (cdr ,',next-methods)))
 		   .next-method. ,',next-methods
 		   ,@body))
-	      (call-next-method-body (cnm-args)
+	      (call-next-method-body (method-name-declaration cnm-args)
 		`(if .next-method.
 		     (funcall (if (std-instance-p .next-method.)
 				  (method-function .next-method.)
 				  .next-method.) ; for early methods
 			      (or ,cnm-args ,',method-args)
 			      ,',next-methods)
-		     (error "no next method")))
+		     (apply #'call-no-next-method ',method-name-declaration
+		            (or ,cnm-args ,',method-args))))
 	      (next-method-p-body ()
 		`(not (null .next-method.))))
      ,@body))
 
+(defun call-no-next-method (method-name-declaration &rest args)
+  (destructuring-bind (name) method-name-declaration
+    (destructuring-bind (name &rest qualifiers-and-specializers) name
+      ;; KLUDGE: inefficient traversal, but hey.  This should only
+      ;; happen on the slow error path anyway.
+      (let* ((qualifiers (butlast qualifiers-and-specializers))
+	     (specializers (car (last qualifiers-and-specializers)))
+	     (method (find-method (gdefinition name) qualifiers specializers)))
+	(apply #'no-next-method
+	       (method-generic-function method)
+	       method
+	       args)))))
+
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
@@ -1011,7 +1040,7 @@
 		   ,emf))
 	      (call-next-method-bind (&body body)
                `(let () ,@body))
-	      (call-next-method-body (cnm-args)
+	      (call-next-method-body (method-name-declaration cnm-args)
                `(if ,',next-method-call
                  ,(locally
                    ;; This declaration suppresses a "deleting
@@ -1039,13 +1068,22 @@
                                        ,cnm-args)
                             ,call)
                            ,call))))
-                 (error "no next method")))
+		 ,(if (and (null ',rest-arg)
+			   (consp cnm-args)
+			   (eq (car cnm-args) 'list))
+		      `(call-no-next-method ',method-name-declaration
+			                    ,@(cdr cnm-args))
+		      `(call-no-next-method ',method-name-declaration
+			                    ,@',args
+			                    ,@',(when rest-arg
+						      `(,rest-arg))))))
 	      (next-method-p-body ()
                `(not (null ,',next-method-call))))
     ,@body))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p closurep applyp)
+    ((&key call-next-method-p next-method-p-p
+	   closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
 	      (null closurep)
@@ -1057,7 +1095,8 @@
 	 ;; (else APPLYP would be true).
 	 `(call-next-method-bind
 	    (macrolet ((call-next-method (&rest cnm-args)
-			 `(call-next-method-body ,(when cnm-args
+			 `(call-next-method-body ,',method-name-declaration
+			                         ,(when cnm-args
 						    `(list ,@cnm-args))))
 		       (next-method-p ()
 			 `(next-method-p-body)))
@@ -1065,8 +1104,10 @@
 	(t
 	 `(call-next-method-bind
 	    (flet (,@(and call-next-method-p
-			  '((call-next-method (&rest cnm-args)
-			      (call-next-method-body cnm-args))))
+			  `((call-next-method (&rest cnm-args)
+			     (call-next-method-body
+			      ,method-name-declaration
+			      cnm-args))))
 		   ,@(and next-method-p-p
 			  '((next-method-p ()
 			      (next-method-p-body)))))

Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- braid.lisp	28 Oct 2002 14:33:30 -0000	1.23
+++ braid.lisp	29 Oct 2002 10:02:30 -0000	1.24
@@ -626,3 +626,11 @@
 	  ~I~_when called with arguments ~2I~_~S.~:>"
 	 generic-function
 	 args))
+
+(defmethod no-next-method ((generic-function standard-generic-function)
+			   (method standard-method) &rest args)
+  (error "~@<There is no next method for the generic function ~2I~_~S~
+	  ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
+	 generic-function
+	 method
+	 args))

Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- generic-functions.lisp	26 Oct 2002 11:00:12 -0000	1.12
+++ generic-functions.lisp	29 Oct 2002 10:02:31 -0000	1.13
@@ -488,6 +488,8 @@
 
 (defgeneric no-applicable-method (generic-function &rest args))
 
+(defgeneric no-next-method (generic-function method &rest args))
+
 (defgeneric reader-method-class (class direct-slot &rest initargs))
 
 (defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys))

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv10321

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.7.9.10:
	Implement NO-NEXT-METHOD (following Gerd Moellmann on cmucl-imp
		in message 86vg5rryqn.fsf@...
		entomotomy reference: no-next-method-unimplemented)
	... add a comment in boot.lisp describing coupling of %METHOD-NAME 
		declaration to NO-NEXT-METHOD implementation


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.180
retrieving revision 1.181
diff -u -d -r1.180 -r1.181
--- NEWS	28 Oct 2002 14:33:27 -0000	1.180
+++ NEWS	29 Oct 2002 10:02:28 -0000	1.181
@@ -1349,6 +1349,9 @@
   * minor incompatible change: PCL now records the pathname of a file
     in which methods and the like are defined, rather than its
     truename.
+  * more systematization and improvement of CLOS and MOP conformance
+    in PCL (thanks to Gerd Moellman and Pierre Mai):
+    ** NO-NEXT-METHOD is now implemented;
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.618
retrieving revision 1.619
diff -u -d -r1.618 -r1.619
--- version.lisp-expr	28 Oct 2002 21:37:30 -0000	1.618
+++ version.lisp-expr	29 Oct 2002 10:02:29 -0000	1.619
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.9"
+"0.7.9.10"

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv19626/tests

Modified Files:
	compiler.pure.lisp 
Added Files:
	eval.impure.lisp 
Log Message:
0.7.9.9:
	Fix entomotomy bug ccase-and-ecase-error-on-t-and-otherwise
		(and for CTYPECASE/ETYPECASE too!)
	... actual change to CASE-BODY
	... fix to logic of compiler warning handling when compiled
		under CMUCL
	... cosmetic fix to use macroexpanded EXP rather than
		ORIGINAL-EXP in EVAL, so we don't get STYLE-WARNING
		twice
	... correct an SB-IMPL::COMPILER-STYLE-WARN ->
		SB-C::COMPILER-STYLE-WARN bogosity
	Include tests of EVAL from previous refactor to get LOCALLY et
		al. right.


--- NEW FILE: eval.impure.lisp ---
;;;; various tests of EVAL with side effects

;;;; 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.

;;;; Note: this stuff gets loaded in (by LOAD) and is therefore
;;;; evaluated by EVAL, rather than compiled and then loaded; this is
;;;; why this idiom (a sequence of top-level forms) works as a test of
;;;; EVAL.

(cl:in-package :cl-user)

;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY,
;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness
;;; of their body forms:

;;; LOCALLY
(locally (defstruct locally-struct a (b t)))

(let ((x (make-locally-struct :a 1)))
  (assert (eql (locally-struct-a x) 1))
  (assert (eql (locally-struct-b x) t)))

(locally
  (defmacro locally-macro (x) `(+ ,x 1))
  (assert (= (locally-macro 3) 4)))

(locally (declare (special x))
  (defun locally-special-test ()
    x)
  (defun locally-special-test-aux ()
    (let ((x 1))
      (declare (special x))
      (locally-special-test)))
  (assert (= (locally-special-test-aux) 1)))

;;; MACROLET
(macrolet ()
  (defstruct macrolet-struct a (b t)))

(let ((x (make-macrolet-struct :a 1)))
  (assert (eql (macrolet-struct-a x) 1))
  (assert (eql (macrolet-struct-b x) t)))

(macrolet ()
  (defmacro macrolet-macro (x) `(+ ,x 1))
  (assert (= (macrolet-macro 3) 4)))

(locally (declare (special x))
  (defun macrolet-special-test ()
    x)
  (defun macrolet-special-test-aux ()
    (let ((x 1))
      (declare (special x))
      (macrolet-special-test)))
  (assert (= (macrolet-special-test-aux) 1)))

(macrolet ((foo (x) `(macrolet-bar ,x)))
  (defmacro macrolet-bar (x) `(+ ,x 1))
  (assert (= (foo 1) 2)))

;;; SYMBOL-MACROLET
(symbol-macrolet ()
  (defstruct symbol-macrolet-struct a (b t)))

(let ((x (make-symbol-macrolet-struct :a 1)))
  (assert (eql (symbol-macrolet-struct-a x) 1))
  (assert (eql (symbol-macrolet-struct-b x) t)))

(symbol-macrolet ()
  (defmacro symbol-macrolet-macro (x) `(+ ,x 1))
  (assert (= (symbol-macrolet-macro 3) 4)))

(locally (declare (special x))
  (defun symbol-macrolet-special-test ()
    x)
  (defun symbol-macrolet-special-test-aux ()
    (let ((x 1))
      (declare (special x))
      (symbol-macrolet-special-test)))
  (assert (= (symbol-macrolet-special-test-aux) 1)))

(symbol-macrolet ((foo (symbol-macrolet-bar 1)))
  (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
  (assert (= foo 2)))

;;; success
(sb-ext:quit :unix-status 104)

    

Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- compiler.pure.lisp	15 Oct 2002 12:20:35 -0000	1.20
+++ compiler.pure.lisp	28 Oct 2002 21:37:31 -0000	1.21
@@ -222,5 +222,15 @@
   (assert (null result))
   (assert (typep error 'program-error)))
 
+(multiple-value-bind (result error)
+    (ignore-errors (ecase 1 (t 0)))
+  (assert (null result))
+  (assert (typep error 'type-error)))
+
+(multiple-value-bind (result error)
+    (ignore-errors (ecase 1 (t 0) (1 2)))
+  (assert (eql result 2))
+  (assert (null error)))
+	  
 ;;; FTYPE should accept any functional type specifier
 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv19626/src/compiler

Modified Files:
	ir1tran.lisp 
Log Message:
0.7.9.9:
	Fix entomotomy bug ccase-and-ecase-error-on-t-and-otherwise
		(and for CTYPECASE/ETYPECASE too!)
	... actual change to CASE-BODY
	... fix to logic of compiler warning handling when compiled
		under CMUCL
	... cosmetic fix to use macroexpanded EXP rather than
		ORIGINAL-EXP in EVAL, so we don't get STYLE-WARNING
		twice
	... correct an SB-IMPL::COMPILER-STYLE-WARN ->
		SB-C::COMPILER-STYLE-WARN bogosity
	Include tests of EVAL from previous refactor to get LOCALLY et
		al. right.


Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.92
retrieving revision 1.93
diff -u -d -r1.92 -r1.93
--- ir1tran.lisp	19 Oct 2002 05:59:47 -0000	1.92
+++ ir1tran.lisp	28 Oct 2002 21:37:31 -0000	1.93
@@ -657,27 +657,12 @@
 		;; or the cross-compiler which encountered the problem?"
 		#+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
 		form))))
-      (handler-bind (;; When cross-compiling, we can get style warnings
-                     ;; about e.g. undefined functions. An unhandled
-                     ;; CL:STYLE-WARNING (as opposed to a
-                     ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
-                     ;; set on the return from #'SB!XC:COMPILE-FILE, which
-                     ;; would falsely indicate an error sufficiently
-                     ;; serious that we should stop the build process. To
-                     ;; avoid this, we translate CL:STYLE-WARNING
-                     ;; conditions from the host Common Lisp into
-                     ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
-                     ;; might be cleaner to just make Python use
-                     ;; CL:STYLE-WARNING internally, so that the
-                     ;; significance of any host Common Lisp
-                     ;; CL:STYLE-WARNINGs is understood automatically. But
-                     ;; for now I'm not motivated to do this. -- WHN
-                     ;; 19990412)
-                     (style-warning (lambda (c)
-                                      (compiler-note "~@<~A~:@_~A~:@_~A~:>"
-						     (wherestring) hint c)
-                                      (muffle-warning-or-die)))
-                     ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+      (handler-bind ((style-warning (lambda (c)
+				      (compiler-style-warn
+				       "~@<~A~:@_~A~@:_~A~:>"
+				       (wherestring) hint c)
+				      (muffle-warning-or-die)))
+		     ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
                      ;; Debian Linux, anyway) raises a CL:WARNING
                      ;; condition (not a CL:STYLE-WARNING) for undefined
                      ;; symbols when converting interpreted functions,
@@ -692,7 +677,7 @@
                      ;; and this code does so, by crudely suppressing all
                      ;; warnings in cross-compilation macroexpansion. --
                      ;; WHN 19990412
-                     #+cmu
+                     #+(and cmu sb-xc-host)
                      (warning (lambda (c)
                                 (compiler-note
                                  "~@<~A~:@_~
@@ -709,6 +694,11 @@
                                  (wherestring)
                                  c)
                                 (muffle-warning-or-die)))
+		     #-(and cmu sb-xc-host)
+		     (warning (lambda (c)
+				(compiler-warn "~@<~A~:@_~A~@:_~A~:>"
+					       (wherestring) hint c)
+				(muffle-warning-or-die)))
                      (error (lambda (c)
                               (compiler-error "~@<~A~:@_~A~@:_~A~:>"
                                               (wherestring) hint c))))

Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv19626/src/code

Modified Files:
	eval.lisp macros.lisp 
Log Message:
0.7.9.9:
	Fix entomotomy bug ccase-and-ecase-error-on-t-and-otherwise
		(and for CTYPECASE/ETYPECASE too!)
	... actual change to CASE-BODY
	... fix to logic of compiler warning handling when compiled
		under CMUCL
	... cosmetic fix to use macroexpanded EXP rather than
		ORIGINAL-EXP in EVAL, so we don't get STYLE-WARNING
		twice
	... correct an SB-IMPL::COMPILER-STYLE-WARN ->
		SB-C::COMPILER-STYLE-WARN bogosity
	Include tests of EVAL from previous refactor to get LOCALLY et
		al. right.


Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- eval.lisp	27 Oct 2002 14:52:48 -0000	1.17
+++ eval.lisp	28 Oct 2002 21:37:31 -0000	1.18
@@ -204,7 +204,7 @@
                          (dolist (arg (rest exp))
                            (args (eval-in-lexenv arg lexenv)))
                          (apply (symbol-function name) (args)))
-		(%eval original-exp lexenv))))))
+		(%eval exp lexenv))))))
       (t
        exp))))
 

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/macros.lisp,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -d -r1.27 -r1.28
--- macros.lisp	14 Aug 2002 13:16:12 -0000	1.27
+++ macros.lisp	28 Oct 2002 21:37:31 -0000	1.28
@@ -122,7 +122,7 @@
     ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised
     ;; by this way of complying with a rather screwy aspect of the ANSI
     ;; spec, so at least we can warn him...
-    (compiler-style-warn
+    (sb!c::compiler-style-warn
      "defining compiler macro of (SETF ...), which will not be expanded"))
   (let ((whole (gensym "WHOLE-"))
 	(environment (gensym "ENV-")))
@@ -173,10 +173,13 @@
       (destructuring-bind (keyoid &rest forms) case
 	(cond ((memq keyoid '(t otherwise))
 	       (if errorp
-		   (error 'simple-program-error
-			  :format-control
-			  "No default clause is allowed in ~S: ~S"
-			  :format-arguments (list name case))
+		   (progn
+		     ;; FIXME: this message could probably do with
+		     ;; some loving pretty-printer format controls.
+		     (style-warn "Treating bare ~A in ~A as introducing a normal-clause, not an otherwise-clause" keyoid name)
+		     (push keyoid keys)
+		     (push `((,test ,keyform-value ',keyoid) nil ,@forms)
+			   clauses))
 		   (push `(t nil ,@forms) clauses)))
 	      ((and multi-p (listp keyoid))
 	       (setf keys (append keyoid keys))

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv19626

Modified Files:
	version.lisp-expr 
Log Message:
0.7.9.9:
	Fix entomotomy bug ccase-and-ecase-error-on-t-and-otherwise
		(and for CTYPECASE/ETYPECASE too!)
	... actual change to CASE-BODY
	... fix to logic of compiler warning handling when compiled
		under CMUCL
	... cosmetic fix to use macroexpanded EXP rather than
		ORIGINAL-EXP in EVAL, so we don't get STYLE-WARNING
		twice
	... correct an SB-IMPL::COMPILER-STYLE-WARN ->
		SB-C::COMPILER-STYLE-WARN bogosity
	Include tests of EVAL from previous refactor to get LOCALLY et
		al. right.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.617
retrieving revision 1.618
diff -u -d -r1.617 -r1.618
--- version.lisp-expr	28 Oct 2002 14:33:28 -0000	1.617
+++ version.lisp-expr	28 Oct 2002 21:37:30 -0000	1.618
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.8"
+"0.7.9.9"

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv15278

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.7.9.8:
	Change *LOAD-TRUENAME* to *LOAD-PATHNAME* throughout PCL, so as to 
		facilitate an eventual build system which would enable
		the system sources to be findable when placed in an
		arbitrary filesystem location.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.179
retrieving revision 1.180
diff -u -d -r1.179 -r1.180
--- NEWS	22 Oct 2002 10:57:05 -0000	1.179
+++ NEWS	28 Oct 2002 14:33:27 -0000	1.180
@@ -1345,6 +1345,11 @@
   * compiler no longer signals WARNING on unknown keyword
     :ALLOW-OTHER-KEYS
 
+changes in sbcl-0.7.9 relative to sbcl-0.7.8:
+  * minor incompatible change: PCL now records the pathname of a file
+    in which methods and the like are defined, rather than its
+    truename.
+
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe
   later, it might impact TRACE. They both encapsulate functions, and

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.616
retrieving revision 1.617
diff -u -d -r1.616 -r1.617
--- version.lisp-expr	27 Oct 2002 16:02:58 -0000	1.616
+++ version.lisp-expr	28 Oct 2002 14:33:28 -0000	1.617
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.7"
+"0.7.9.8"

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv15278/src/pcl

Modified Files:
	boot.lisp braid.lisp defclass.lisp defcombin.lisp defs.lisp 
	std-class.lisp 
Log Message:
0.7.9.8:
	Change *LOAD-TRUENAME* to *LOAD-PATHNAME* throughout PCL, so as to 
		facilitate an eventual build system which would enable
		the system sources to be findable when placed in an
		arbitrary filesystem location.


Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -d -r1.55 -r1.56
--- boot.lisp	26 Oct 2002 11:22:51 -0000	1.55
+++ boot.lisp	28 Oct 2002 14:33:29 -0000	1.56
@@ -239,7 +239,7 @@
   (apply #'ensure-generic-function
          fun-name
          :lambda-list lambda-list
-         :definition-source `((defgeneric ,fun-name) ,*load-truename*)
+         :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
          initargs))
 
 ;;; As per section 3.4.2 of the ANSI spec, generic function lambda
@@ -1306,7 +1306,7 @@
 		       :definition-source `((defmethod ,gf-spec
 						,@qualifiers
 					      ,specializers)
-					    ,*load-truename*)
+					    ,*load-pathname*)
 		       initargs)))
     (unless (or (eq method-class 'standard-method)
 		(eq (find-class method-class nil) (class-of method)))
@@ -1764,7 +1764,7 @@
     (!bootstrap-set-slot 'standard-generic-function
 			 fin
 			 'source
-			 *load-truename*)
+			 *load-pathname*)
     (set-fun-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)

Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- braid.lisp	22 Jun 2002 15:15:29 -0000	1.22
+++ braid.lisp	28 Oct 2002 14:33:30 -0000	1.23
@@ -243,7 +243,7 @@
 				    smc
 				    name
 				    value)))
-	(set-slot 'source *load-truename*)
+	(set-slot 'source *load-pathname*)
 	(set-slot 'type 'standard)
 	(set-slot 'documentation "The standard method combination.")
 	(set-slot 'options ()))

Index: defclass.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- defclass.lisp	14 Aug 2002 13:26:00 -0000	1.23
+++ defclass.lisp	28 Oct 2002 14:33:30 -0000	1.24
@@ -400,7 +400,7 @@
 	canonical-options (copy-tree canonical-options))
   (let ((ecd
 	  (make-early-class-definition name
-				       *load-truename*
+				       *load-pathname*
 				       metaclass
 				       supers
 				       canonical-slots

Index: defcombin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defcombin.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- defcombin.lisp	31 Aug 2002 01:19:51 -0000	1.12
+++ defcombin.lisp	28 Oct 2002 14:33:31 -0000	1.13
@@ -74,7 +74,7 @@
      ',type ',operator ',identity-with-one-arg ',documentation)))
 
 (defun load-short-defcombin (type operator ioa doc)
-  (let* ((truename *load-truename*)
+  (let* ((pathname *load-pathname*)
 	 (specializers
 	   (list (find-class 'generic-function)
 		 (intern-eql-specializer type)
@@ -95,7 +95,7 @@
 			   (short-combine-methods
 			    type options operator ioa new-method doc))
 			 args))
-	    :definition-source `((define-method-combination ,type) ,truename)))
+	    :definition-source `((define-method-combination ,type) ,pathname)))
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)))
@@ -215,7 +215,7 @@
 					   :documentation doc))
 			  args))
 	     :definition-source `((define-method-combination ,type)
-			      ,*load-truename*))))
+				  ,*load-pathname*))))
     (setf (gethash type *long-method-combination-functions*) function)
     (when old-method (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)))

Index: defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- defs.lisp	9 Oct 2002 17:03:33 -0000	1.21
+++ defs.lisp	28 Oct 2002 14:33:31 -0000	1.22
@@ -472,7 +472,7 @@
 
 (defclass definition-source-mixin (std-object)
   ((source
-    :initform *load-truename*
+    :initform *load-pathname*
     :reader definition-source
     :initarg :definition-source))
   (:metaclass std-class))

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- std-class.lisp	15 Oct 2002 09:23:21 -0000	1.28
+++ std-class.lisp	28 Oct 2002 14:33:31 -0000	1.29
@@ -320,7 +320,7 @@
 		    :direct-superclasses supers
 		    :direct-slots slots
 		    :definition-source `((defclass ,name)
-					 ,*load-truename*)
+					 ,*load-pathname*)
 		    other)))
     ;; Defclass of a class with a forward-referenced superclass does not
     ;; have a wrapper. RES is the incomplete PCL class. The Lisp class

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv30322/src/compiler

Modified Files:
	target-main.lisp 
Log Message:
0.7.9.7:
	Move build-id.tmp-making logic to make-config.sh, to facilitate
		cross-compilation
	Add a comment regarding *policy* rebinding.


Index: target-main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-main.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- target-main.lisp	27 Oct 2002 14:52:49 -0000	1.13
+++ target-main.lisp	27 Oct 2002 16:02:59 -0000	1.14
@@ -61,6 +61,14 @@
 	     (*last-format-args* nil)
 	     (*last-message-count* 0)
 	     (*gensym-counter* 0)
+	     ;; KLUDGE: This rebinding of policy is necessary so that
+	     ;; forms such as LOCALLY at the REPL actually extend the
+	     ;; compilation policy correctly.  However, there is an
+	     ;; invariant that is potentially violated: future
+	     ;; refactoring must not allow this to be done in the file
+	     ;; compiler.  At the moment we're clearly alright, as we
+	     ;; call %COMPILE with a core-object, not a fasl-stream,
+	     ;; but caveat future maintainers. -- CSR, 2002-10-27
 	     (*policy* (lexenv-policy *lexenv*))
 	     ;; FIXME: ANSI doesn't say anything about CL:COMPILE
 	     ;; interacting with these variables, so we shouldn't. As

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv30322

Modified Files:
	make-config.sh make.sh version.lisp-expr 
Log Message:
0.7.9.7:
	Move build-id.tmp-making logic to make-config.sh, to facilitate
		cross-compilation
	Add a comment regarding *policy* rebinding.


Index: make-config.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-config.sh,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- make-config.sh	1 Sep 2002 22:34:17 -0000	1.16
+++ make-config.sh	27 Oct 2002 16:02:56 -0000	1.17
@@ -156,3 +156,8 @@
 # cp base-version.txt $versionfile
 # echo " (built `date -u` by `whoami`@`hostname`)" >> $versionfile
 # echo 'This is a machine-generated file and should not be edited by hand.' >> $versionfile
+
+# Make a unique ID for this build (to discourage people from
+# mismatching sbcl and *.core files).
+echo '"'`hostname -s`-`whoami`-`date +%F-%H-%M-%S`'"' > output/build-id.tmp
+

Index: make.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make.sh,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- make.sh	2 Oct 2002 23:22:47 -0000	1.17
+++ make.sh	27 Oct 2002 16:02:57 -0000	1.18
@@ -65,10 +65,6 @@
 # and target machines.
 sh make-config.sh || exit 1
 
-# Make a unique ID for this build (to discourage people from
-# mismatching sbcl and *.core files).
-echo '"'`hostname -s`-`whoami`-`date +%F-%H-%M-%S`'"' > output/build-id.tmp
-
 # The make-host-*.sh scripts are run on the cross-compilation host,
 # and the make-target-*.sh scripts are run on the target machine. In
 # ordinary compilation, we just do these phases consecutively on the

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.615
retrieving revision 1.616
diff -u -d -r1.615 -r1.616
--- version.lisp-expr	27 Oct 2002 14:52:48 -0000	1.615
+++ version.lisp-expr	27 Oct 2002 16:02:58 -0000	1.616
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.6"
+"0.7.9.7"

Update of /cvsroot/sbcl/sbcl/tests
In directory usw-pr-cvs1:/tmp/cvs-serv11544/tests

Modified Files:
	pathnames.impure.lisp 
Log Message:
0.7.9.6:
	Fix bug 185 (top level forms at the REPL)
	... implement a LOCALLY method for EVAL-IN-LEXENV
	... factor out MACROLET-DEFINITIONIZE-FUN and
		SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1
		translators for same
	... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV
		in terms of said DEFINITIONIZE-FUN macros and LOCALLY
	... set compilation policy in make-target-2 to avoid file scope
		limitations
	... set interaction policy by hard-coding it in
		MAKE-NULL-INTERACTIVE-LEXENV
	... throw it together and hope it all still works.


Index: pathnames.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/pathnames.impure.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- pathnames.impure.lisp	17 Sep 2002 19:52:29 -0000	1.16
+++ pathnames.impure.lisp	27 Oct 2002 14:52:49 -0000	1.17
@@ -79,17 +79,21 @@
 ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
 ;;; a TYPE-ERROR?
 
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "!bla" :name "bar"))))
-
-;; error: name-component not valid
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "bla" :name "!bar"))))
-
-;; error: type-component not valid.
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "bla" :name "bar"
-                              :type "&baz"))))
+(locally
+  ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE
+  (declare (optimize safety))
+  
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "!bla" :name "bar"))))
+  
+  ;; error: name-component not valid
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "bla" :name "!bar"))))
+  
+  ;; error: type-component not valid.
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "bla" :name "bar"
+			       :type "&baz")))))
 
 ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
 ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv11544/src/compiler

Modified Files:
	ir1-translators.lisp lexenv.lisp target-main.lisp 
Log Message:
0.7.9.6:
	Fix bug 185 (top level forms at the REPL)
	... implement a LOCALLY method for EVAL-IN-LEXENV
	... factor out MACROLET-DEFINITIONIZE-FUN and
		SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1
		translators for same
	... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV
		in terms of said DEFINITIONIZE-FUN macros and LOCALLY
	... set compilation policy in make-target-2 to avoid file scope
		limitations
	... set interaction policy by hard-coding it in
		MAKE-NULL-INTERACTIVE-LEXENV
	... throw it together and hope it all still works.


Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- ir1-translators.lisp	17 Oct 2002 03:36:09 -0000	1.31
+++ ir1-translators.lisp	27 Oct 2002 14:52:49 -0000	1.32
@@ -252,35 +252,44 @@
          (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
     (funcall fun definitionize-keyword processed-definitions)))
 
-;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
 ;;; call FUN (with no arguments).
 ;;;
 ;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top level MACROLET processing code.
+;;; shared by the special-case top level MACROLET processing code, and
+;;; further split so that the special-case MACROLET processing code in
+;;; EVAL can likewise make use of it.
+(defmacro macrolet-definitionize-fun (context lexenv)
+  (flet ((make-error-form (control &rest args)
+	   (ecase context
+	     (:compile `(compiler-error ,control ,@args))
+	     (:eval `(error 'simple-program-error
+		      :format-control ,control
+		      :format-arguments (list ,@args))))))
+    `(lambda (definition)
+      (unless (list-of-length-at-least-p definition 2)
+	,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
+      (destructuring-bind (name arglist &body body) definition
+	(unless (symbolp name)
+	  ,(make-error-form "The local macro name ~S is not a symbol." 'name))
+	(unless (listp arglist)
+	  ,(make-error-form "The local macro argument list ~S is not a list." 'arglist))
+	(let ((whole (gensym "WHOLE"))
+	      (environment (gensym "ENVIRONMENT")))
+	  (multiple-value-bind (body local-decls)
+	      (parse-defmacro arglist whole body name 'macrolet
+			      :environment environment)
+	    `(,name macro .
+	      ,(compile-in-lexenv
+		nil
+		`(lambda (,whole ,environment)
+		  ,@local-decls
+		  (block ,name ,body))
+		,lexenv))))))))
+
 (defun funcall-in-macrolet-lexenv (definitions fun)
   (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (list-of-length-at-least-p definition 2)
-       (compiler-error
-	"The list ~S is too short to be a legal local macro definition."
-	definition))
-     (destructuring-bind (name arglist &body body) definition
-       (unless (symbolp name)
-	 (compiler-error "The local macro name ~S is not a symbol." name))
-       (unless (listp arglist)
-	 (compiler-error "The local macro argument list ~S is not a list." arglist))
-       (let ((whole (gensym "WHOLE"))
-	     (environment (gensym "ENVIRONMENT")))
-	 (multiple-value-bind (body local-decls)
-	     (parse-defmacro arglist whole body name 'macrolet
-			     :environment environment)
-	   `(,name macro .
-		   ,(compile-in-lexenv
-                     nil
-                     `(lambda (,whole ,environment)
-                        ,@local-decls
-                        (block ,name ,body))
-                     (make-restricted-lexenv *lexenv*)))))))
+   (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))
    :funs
    definitions
    fun))
@@ -298,20 +307,31 @@
      (declare (ignore funs))
      (ir1-translate-locally body start cont))))
 
-(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
-  (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (proper-list-of-length-p definition 2)
-       (compiler-error "malformed symbol/expansion pair: ~S" definition))
+(defmacro symbol-macrolet-definitionize-fun (context)
+  (flet ((make-error-form (control &rest args)
+	   (ecase context
+	     (:compile `(compiler-error ,control ,@args))
+	     (:eval `(error 'simple-program-error
+		      :format-control ,control
+		      :format-arguments (list ,@args))))))
+    `(lambda (definition)
+      (unless (proper-list-of-length-p definition 2)
+       ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition))
      (destructuring-bind (name expansion) definition
        (unless (symbolp name)
-         (compiler-error
-          "The local symbol macro name ~S is not a symbol."
-          name))
+         ,(make-error-form
+	   "The local symbol macro name ~S is not a symbol."
+	   'name))
        (let ((kind (info :variable :kind name)))
 	 (when (member kind '(:special :constant))
-	   (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name)))
-       `(,name . (MACRO . ,expansion))))
+	   ,(make-error-form
+	     "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+	     'kind 'name)))
+       `(,name . (MACRO . ,expansion))))))1
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (symbol-macrolet-definitionize-fun :compile)
    :vars
    definitions
    fun))

Index: lexenv.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/lexenv.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- lexenv.lisp	12 Oct 2002 05:57:46 -0000	1.11
+++ lexenv.lisp	27 Oct 2002 14:52:49 -0000	1.12
@@ -18,6 +18,13 @@
 #!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place
 (def!struct (lexenv
 	     (:constructor make-null-lexenv ())
+	     (:constructor make-null-interactive-lexenv
+			   (&aux (policy (list '(safety . 3)
+					       '(compilation-speed . 2)
+					       '(speed . 1)
+					       '(space . 1)
+					       '(debug . 1)
+					       '(inhibit-warnings . 1)))))
 	     (:constructor internal-make-lexenv
 			   (funs vars blocks tags type-restrictions
 				 lambda cleanup policy)))

Index: target-main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-main.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- target-main.lisp	10 Oct 2002 07:16:15 -0000	1.12
+++ target-main.lisp	27 Oct 2002 14:52:49 -0000	1.13
@@ -61,6 +61,7 @@
 	     (*last-format-args* nil)
 	     (*last-message-count* 0)
 	     (*gensym-counter* 0)
+	     (*policy* (lexenv-policy *lexenv*))
 	     ;; FIXME: ANSI doesn't say anything about CL:COMPILE
 	     ;; interacting with these variables, so we shouldn't. As
 	     ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by

Update of /cvsroot/sbcl/sbcl/src/code
In directory usw-pr-cvs1:/tmp/cvs-serv11544/src/code

Modified Files:
	eval.lisp toplevel.lisp 
Log Message:
0.7.9.6:
	Fix bug 185 (top level forms at the REPL)
	... implement a LOCALLY method for EVAL-IN-LEXENV
	... factor out MACROLET-DEFINITIONIZE-FUN and
		SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1
		translators for same
	... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV
		in terms of said DEFINITIONIZE-FUN macros and LOCALLY
	... set compilation policy in make-target-2 to avoid file scope
		limitations
	... set interaction policy by hard-coding it in
		MAKE-NULL-INTERACTIVE-LEXENV
	... throw it together and hope it all still works.


Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- eval.lisp	10 Oct 2002 07:16:14 -0000	1.16
+++ eval.lisp	27 Oct 2002 14:52:48 -0000	1.17
@@ -17,22 +17,6 @@
   (funcall (sb!c:compile-in-lexenv
             (gensym "EVAL-TMPFUN-")
             `(lambda ()
-
-               ;; The user can reasonably expect that the
-               ;; interpreter will be safe.
-               (declare (optimize (safety 3)))
-
-               ;; It's also good if the interpreter doesn't
-               ;; spend too long thinking about each input
-               ;; form, since if the user'd wanted the
-               ;; tradeoff to favor quality of compiled code
-               ;; over compilation speed, he'd've explicitly
-               ;; asked for compilation.
-               (declare (optimize (compilation-speed 2)))
-
-               ;; Other properties are relatively unimportant.
-               (declare (optimize (speed 1) (debug 1) (space 1)))
-
                ,expr)
             lexenv)))
 
@@ -91,7 +75,7 @@
        (let ((name (first exp))
 	     (n-args (1- (length exp))))
 	 (case name
-	   (function
+	   ((function)
 	    (unless (= n-args 1)
 	      (error "wrong number of args to FUNCTION:~% ~S" exp))
 	    (let ((name (second exp)))
@@ -102,7 +86,7 @@
                                      (sb!c:lexenv-find name funs)))))
 		  (fdefinition name)
 		  (%eval original-exp lexenv))))
-	   (quote
+	   ((quote)
 	    (unless (= n-args 1)
 	      (error "wrong number of args to QUOTE:~% ~S" exp))
 	    (second exp))
@@ -154,12 +138,71 @@
 		(declare (ignore ct lt))
 		(when e
 		  (eval-progn-body body lexenv)))))
+	   ((locally)
+	    (multiple-value-bind (body decls) (parse-body (rest exp) nil)
+	      (let ((lexenv
+		     ;; KLUDGE: Uh, yeah.  I'm not anticipating
+		     ;; winning any prizes for this code, which was
+		     ;; written on a "let's get it to work" basis.
+		     ;; These seem to be the variables that need
+		     ;; bindings for PROCESS-DECLS to work
+		     ;; (*FREE-FUNS* and *FREE-VARS* so that
+		     ;; references to free functions and variables in
+		     ;; the declarations can be noted;
+		     ;; *UNDEFINED-WARNINGS* so that warnings about
+		     ;; undefined things can be accumulated [and then
+		     ;; thrown away, as it happens]). -- CSR, 2002-10-24
+		     (let ((sb!c:*lexenv* lexenv)
+			   (sb!c::*free-funs* (make-hash-table :test 'equal))
+			   (sb!c::*free-vars* (make-hash-table :test 'eq))
+			   (sb!c::*undefined-warnings* nil))
+		       (sb!c::process-decls decls
+					    nil nil
+					    (sb!c::make-continuation)
+					    lexenv))))
+		(eval-progn-body body lexenv))))
+	   ((macrolet)
+	    (destructuring-bind (definitions &rest body)
+		(rest exp)
+	      ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV
+	      (declare (type list definitions))
+	      (unless (= (length definitions)
+			 (length (remove-duplicates definitions :key #'first)))
+		(style-warn "duplicate definitions in ~S" definitions))
+	      (let ((lexenv
+		     (sb!c::make-lexenv
+		      :default lexenv
+		      :funs (mapcar
+			     (sb!c::macrolet-definitionize-fun
+			      :eval
+			      ;; I'm not sure that this is the correct
+			      ;; LEXENV to be compiling local macros
+			      ;; in...
+			      lexenv)
+			     definitions))))
+		(eval-in-lexenv `(locally ,@body) lexenv))))
+	   ((symbol-macrolet)
+	    (destructuring-bind (definitions &rest body)
+		(rest exp)
+	      ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV
+	      (declare (type list definitions))
+	      (unless (= (length definitions)
+			 (length (remove-duplicates definitions :key #'first)))
+		(style-warn "duplicate definitions in ~S" definitions))
+	      (let ((lexenv
+		     (sb!c::make-lexenv
+		      :default lexenv
+		      :vars (mapcar
+			     (sb!c::symbol-macrolet-definitionize-fun
+			      :eval)
+			     definitions))))
+		(eval-in-lexenv `(locally ,@body) lexenv))))
 	   (t
 	    (if (and (symbolp name)
 		     (eq (info :function :kind name) :function))
 		(collect ((args))
                          (dolist (arg (rest exp))
-                           (args (eval arg)))
+                           (args (eval-in-lexenv arg lexenv)))
                          (apply (symbol-function name) (args)))
 		(%eval original-exp lexenv))))))
       (t

Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- toplevel.lisp	17 Oct 2002 19:56:05 -0000	1.33
+++ toplevel.lisp	27 Oct 2002 14:52:48 -0000	1.34
@@ -260,7 +260,10 @@
   "Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
    +++, ++, +, ///, //, /, and -."
   (setf - form)
-  (let ((results (multiple-value-list (eval form))))
+  (let ((results
+	 (multiple-value-list
+	  (eval-in-lexenv form
+			  (make-null-interactive-lexenv)))))
     (setf /// //
 	  // /
 	  / results

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv11544

Modified Files:
	BUGS make-target-2.sh package-data-list.lisp-expr 
	version.lisp-expr 
Log Message:
0.7.9.6:
	Fix bug 185 (top level forms at the REPL)
	... implement a LOCALLY method for EVAL-IN-LEXENV
	... factor out MACROLET-DEFINITIONIZE-FUN and
		SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1
		translators for same
	... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV
		in terms of said DEFINITIONIZE-FUN macros and LOCALLY
	... set compilation policy in make-target-2 to avoid file scope
		limitations
	... set interaction policy by hard-coding it in
		MAKE-NULL-INTERACTIVE-LEXENV
	... throw it together and hope it all still works.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.222
retrieving revision 1.223
diff -u -d -r1.222 -r1.223
--- BUGS	27 Oct 2002 05:04:46 -0000	1.222
+++ BUGS	27 Oct 2002 14:52:48 -0000	1.223
@@ -979,14 +979,6 @@
           :ACCRUED-EXCEPTIONS (:INEXACT)
           :FAST-MODE NIL)
 
-185: "top-level forms at the REPL"
-  * (locally (defstruct foo (a 0 :type fixnum)))
-  gives an error:
-  ; caught ERROR:
-  ;   (in macroexpansion of (SB-KERNEL::%DELAYED-GET-COMPILER-LAYOUT BAR))
-  however, compiling and loading the same expression in a file works
-  as expected.
-
 187: "type inference confusion around DEFTRANSFORM time"
   (reported even more verbosely on sbcl-devel 2002-06-28 as "strange
   bug in DEFTRANSFORM")
@@ -1386,6 +1378,22 @@
   (defun test (x y) (the (values integer) (truncate x y)))
   (test 10 4) => 2
 
+219: "DEFINE-COMPILER-MACRO in non-toplevel contexts evaluated at compile-time"
+  In sbcl-0.7.9:
+
+  * (defun foo (x) 
+      (when x
+        (define-compiler-macro bar (&whole whole)
+          (declare (ignore whole))
+          (print "expanding compiler macro")
+          1)))
+  FOO
+  * (defun baz (x) (bar))
+  [ ... ]
+  "expanding compiler macro"
+  BAZ
+  * (baz t)
+  1
 
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:

Index: make-target-2.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-target-2.sh,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- make-target-2.sh	1 Nov 2001 20:24:55 -0000	1.13
+++ make-target-2.sh	27 Oct 2002 14:52:48 -0000	1.14
@@ -67,6 +67,17 @@
 	  (sb-int:/show "done with warm.lisp, about to GC :FULL T")
 	  (gc :full t))
 
+        ;; resetting compilation policy to neutral values in
+        ;; preparation for SAVE-LISP-AND-DIE as final SBCL core (not
+        ;; in warm.lisp because SB-C::*POLICY* has file scope)
+        (sb-int:/show "setting compilation policy to neutral values")
+        (proclaim '(optimize (compilation-speed 1)
+		             (debug 1)
+		             (inhibit-warnings 1)
+		             (safety 1)
+		             (space 1)
+		             (speed 1)))
+
         (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE")
 	;; Even if /SHOW output was wanted during build, it's probably
 	;; not wanted by default after build is complete. (And if it's

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.183
retrieving revision 1.184
diff -u -d -r1.183 -r1.184
--- package-data-list.lisp-expr	14 Oct 2002 06:59:20 -0000	1.183
+++ package-data-list.lisp-expr	27 Oct 2002 14:52:48 -0000	1.184
@@ -1097,7 +1097,8 @@
              "MAKE-KEY-INFO" "MAKE-LISP-OBJ"
 	     #!+long-float "MAKE-LONG-FLOAT"
              "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
-             "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"
+             "MAKE-NULL-LEXENV" "MAKE-NULL-INTERACTIVE-LEXENV"
+	     "MAKE-NUMERIC-TYPE"
              "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
              "%MAKE-INSTANCE"
 	     "MAKE-VALUE-CELL"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.614
retrieving revision 1.615
diff -u -d -r1.614 -r1.615
--- version.lisp-expr	27 Oct 2002 05:04:46 -0000	1.614
+++ version.lisp-expr	27 Oct 2002 14:52:48 -0000	1.615
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.5"
+"0.7.9.6"

Update of /cvsroot/sbcl/sbcl/src/cold
In directory usw-pr-cvs1:/tmp/cvs-serv11544/src/cold

Modified Files:
	warm.lisp 
Log Message:
0.7.9.6:
	Fix bug 185 (top level forms at the REPL)
	... implement a LOCALLY method for EVAL-IN-LEXENV
	... factor out MACROLET-DEFINITIONIZE-FUN and
		SYMBOL-MACROLET-DEFINITIONIZE-FUN from the IR1
		translators for same
	... implement SYMBOL-MACROLET and MACROLET for EVAL-IN-LEXENV
		in terms of said DEFINITIONIZE-FUN macros and LOCALLY
	... set compilation policy in make-target-2 to avoid file scope
		limitations
	... set interaction policy by hard-coding it in
		MAKE-NULL-INTERACTIVE-LEXENV
	... throw it together and hope it all still works.


Index: warm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/cold/warm.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- warm.lisp	14 Aug 2002 13:26:00 -0000	1.26
+++ warm.lisp	27 Oct 2002 14:52:48 -0000	1.27
@@ -269,14 +269,3 @@
 ;;; through the cold boot process. They need to be set somewhere. Maybe the
 ;;; easiest thing to do is to read them out of package-data-list.lisp-expr
 ;;; now?
-
-;;;; resetting compilation policy to neutral values in preparation for
-;;;; SAVE-LISP-AND-DIE as final SBCL core
-
-(sb-int:/show "setting compilation policy to neutral values")
-(proclaim '(optimize (compilation-speed 1)
-		     (debug 1)
-		     (inhibit-warnings 1)
-		     (safety 1)
-		     (space 1)
-		     (speed 1)))

Update of /cvsroot/sbcl/sbcl
In directory usw-pr-cvs1:/tmp/cvs-serv5860

Modified Files:
	BUGS slam.sh version.lisp-expr 
Log Message:
0.7.9.5:
        * new bug
        * slam.sh supports CMUCL


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.221
retrieving revision 1.222
diff -u -d -r1.221 -r1.222
--- BUGS	26 Oct 2002 05:30:58 -0000	1.221
+++ BUGS	27 Oct 2002 05:04:46 -0000	1.222
@@ -1380,6 +1380,12 @@
   produce invalid code, but type checking is not accurate. Similar
   problems exist with VALUES-TYPE-INTERSECTION.)
 
+218: "VALUES type specifier semantics"
+  (THE (VALUES ...) ...) in safe code discards extra values.
+
+  (defun test (x y) (the (values integer) (truncate x y)))
+  (test 10 4) => 2
+
 
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:

Index: slam.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/slam.sh,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- slam.sh	2 Sep 2002 22:35:18 -0000	1.8
+++ slam.sh	27 Oct 2002 05:04:46 -0000	1.9
@@ -63,10 +63,9 @@
 # recommended way to make that happen.
 #######################################################################
 
-if [ "" != "$*" ]; then
-    echo no command line arguments supported in this version of slam
-    exit 1
-fi
+HOST_TYPE="${1:-sbcl}"
+
+echo //HOST_TYPE=\"$HOST_TYPE\"
 
 # We don't try to be general about this in this script the way we are
 # in make.sh, since the idiosyncrasies of SBCL command line argument
@@ -74,7 +73,21 @@
 # and the SBCL-vs-CMUCL dependence of --core/-core argument syntax
 # make it too messy to try deal with arbitrary SBCL_XC_HOST variants.
 # So you have no choice:
-export SBCL_XC_HOST='sbcl --disable-debugger'
+case "$HOST_TYPE" in
+    cmucl) LISP="lisp -batch"
+           INIT="-noinit"
+           CORE="-core"
+           ;;
+    sbcl)  LISP="sbcl"
+           INIT="--sysinit /dev/null --userinit /dev/null"
+           CORE="--core"
+           ;;
+    *)     echo unknown host type: "$HOST_TYPE"
+           echo should be one of "sbcl" or "cmucl"
+           exit 1
+esac
+
+export SBCL_XC_HOST="$LISP $INIT"
 
 # (We don't do make-host-1.sh at all. Hopefully nothing relevant has
 # changed.)
@@ -84,7 +97,7 @@
 # Instead of doing the full make-host-2.sh, we (1) use after-xc.core
 # to rebuild only obviously-out-of-date Lisp files, then (2) run
 # GENESIS.
-sbcl --core output/after-xc.core --sysinit /dev/null --userinit /dev/null <<'EOF' || exit 1
+$LISP $CORE output/after-xc.core $INIT <<'EOF' || exit 1
   (load "src/cold/slam.lisp")
 EOF
 # (This ^ used to be

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.613
retrieving revision 1.614
diff -u -d -r1.613 -r1.614
--- version.lisp-expr	26 Oct 2002 13:35:55 -0000	1.613
+++ version.lisp-expr	27 Oct 2002 05:04:46 -0000	1.614
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.4"
+"0.7.9.5"