0.6.12.25:

	merged MNA port of Pierre Mai fixes for PCL stuff (sbcl-devel
		2001-05-30)
	renamed tests/pcl.impure.lisp to tests/clos.impure.lisp, to be
		consistent with tests/clos.test.sh
	reverted the part of the patch which nuked the
		INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS call, as per
		my sbcl-devel mail 2001-06-07

NEWS

@@ -740,20 +740,20 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12:
 * Martin Atzmueller ported Tim Moore's marvellous CMU CL DISASSEMBLE
   patch, so that DISASSEMBLE output is much nicer.
 * better error handling in CLOS method combination, thanks to 
-  Martin Atzmueller and Pierre Mai
-* Logical pathnames work better, thanks to various fixes and 
-  tests from Dan Barlow.
+  Martin Atzmueller porting Pierre Mai's CMU CL patches
+* Pathnames are much more ANSI-compliant, thanks to various fixes
+  and tests from Dan Barlow.
 * Hash tables can be printed readably, as inspired by CMU CL code
   of Eric Marsden and SBCL code of Martin Atzmueller.
-* a new slam.sh hack to shorten the edit/compile/debug cycle for
-  low-level changes to SBCL itself, and a new :SB-AFTER-XC-CORE
-  target feature to control the generation of the after-xc.core
-  file needed by slam.sh.
 * Compiler trace output (the :TRACE-FILE option to COMPILE-FILE)
   is now a supported extension again, since the consensus is that
   it can be useful for ordinary development work, not just for
   debugging SBCL itself.
 ?? more overflow fixes for >16Mbyte i/o buffers
+* There's a new slam.sh hack to shorten the edit/compile/debug
+  cycle for low-level changes to SBCL itself, and a new
+  :SB-AFTER-XC-CORE target feature to control the generation of
+  the after-xc.core file needed by slam.sh.
 * minor incompatible change: The ENTRY-POINTS &KEY argument to 
   COMPILE-FILE is no longer supported, so that now every function
   gets an entry point, so that block compilation looks a little

src/pcl/boot.lisp

@@ -1760,7 +1760,11 @@ bootstrapping.
 	 (setf (getf ,all-keys :method-combination)
 	       (find-method-combination (class-prototype ,gf-class)
 					(car combin)
-					(cdr combin)))))))
+					(cdr combin)))))
+    (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
+      (unless (eq method-class '.shes-not-there.)
+        (setf (getf ,all-keys :method-class)
+                (find-class method-class t ,env))))))
 
 (defun real-ensure-gf-using-class--generic-function
        (existing

src/pcl/defclass.lisp

@@ -49,10 +49,6 @@
   (expand-defclass name direct-superclasses direct-slots options))
 
 (defun expand-defclass (name supers slots options)
-  ;; FIXME: We should probably just ensure that the relevant
-  ;; DEFVAR/DEFPARAMETERs occur before this definition, rather 
-  ;; than locally declaring them SPECIAL.
-  (declare (special *boot-state* *the-class-structure-class*))
   (setq supers  (copy-tree supers)
 	slots   (copy-tree slots)
 	options (copy-tree options))
@@ -127,6 +123,22 @@
 		   ,defclass-form))
 	      (progn
 		(when (eq *boot-state* 'complete)
+		  ;; FIXME: MNA (on sbcl-devel 2001-05-30) reported
+		  ;; (if I understand correctly -- WHN) that this call
+		  ;; is directly responsible for defining
+		  ;; class-predicates which always return
+		  ;; CONSTANTLY-NIL in the compile-time environment,
+		  ;; and is indirectly responsible for bogus warnings
+		  ;; about redefinitions when making definitions in
+		  ;; the interpreter. I didn't like his fix (deleting
+		  ;; the call) since I think the type system *should*
+		  ;; be informed about class definitions here. And I'm
+		  ;; not eager to look too deeply into this sort of
+		  ;; done-too-many-times-in-the-interpreter problem
+		  ;; right now, since it should be easier to make a
+		  ;; clean fix when EVAL-WHEN is made more ANSI (as
+		  ;; per the IR1 section in the BUGS file). But
+		  ;; at some point this should be cleaned up.
 		  (inform-type-system-about-std-class name))
 		defclass-form)))))))
 

src/pcl/defs.lisp

@@ -198,12 +198,18 @@
     #'(lambda (x)
 	(funcall (the function (find-class-cell-predicate cell)) x))))
 
-(defun make-class-eq-predicate (class)
-  (when (symbolp class) (setq class (find-class class)))
-  #'(lambda (object) (eq class (class-of object))))
-
-(defun make-eql-predicate (eql-object)
-  #'(lambda (object) (eql eql-object object)))
+(defun make-type-predicate-name (name &optional kind)
+  (if (symbol-package name)
+      (intern (format nil
+		      "~@[~A ~]TYPE-PREDICATE ~A ~A"
+		      kind
+		      (package-name (symbol-package name))
+		      (symbol-name name))
+	      *pcl-package*)
+      (make-symbol (format nil
+			   "~@[~A ~]TYPE-PREDICATE ~A"
+			   kind
+			   (symbol-name name)))))
 
 ;;; internal to this file..
 ;;;
@@ -271,19 +277,6 @@
 	      (t
 	       (subtypep (convert-to-system-type type1)
 			 (convert-to-system-type type2))))))))
-
-(defun make-type-predicate-name (name &optional kind)
-  (if (symbol-package name)
-      (intern (format nil
-		      "~@[~A ~]TYPE-PREDICATE ~A ~A"
-		      kind
-		      (package-name (symbol-package name))
-		      (symbol-name name))
-	      *pcl-package*)
-      (make-symbol (format nil
-			   "~@[~A ~]TYPE-PREDICATE ~A"
-			   kind
-			   (symbol-name name)))))
 
 (defvar *built-in-class-symbols* ())
 (defvar *built-in-wrapper-symbols* ())

src/pcl/dfun.lisp

@@ -963,23 +963,19 @@ And so, we are saved.
 ;;;	       an :instance slot, this is the index number of that slot
 ;;;	       in the object argument.
 (defun cache-miss-values (gf args state)
-  (if (null (if (early-gf-p gf)
-		(early-gf-methods gf)
-		(generic-function-methods gf)))
-      (apply #'no-applicable-method gf args)
-      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-	  (get-generic-function-info gf)
-	(declare (ignore nreq applyp nkeys))
-	(with-dfun-wrappers (args metatypes)
-	  (dfun-wrappers invalid-wrapper-p wrappers classes types)
-	  (error-need-at-least-n-args gf (length metatypes))
-	  (multiple-value-bind (emf methods accessor-type index)
-	      (cache-miss-values-internal
-	       gf arg-info wrappers classes types state)
-	    (values emf methods
-		    dfun-wrappers
-		    invalid-wrapper-p
-		    accessor-type index))))))
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-function-info gf)
+    (declare (ignore nreq applyp nkeys))
+    (with-dfun-wrappers (args metatypes)
+      (dfun-wrappers invalid-wrapper-p wrappers classes types)
+      (error-need-at-least-n-args gf (length metatypes))
+      (multiple-value-bind (emf methods accessor-type index)
+          (cache-miss-values-internal
+           gf arg-info wrappers classes types state)
+        (values emf methods
+                dfun-wrappers
+                invalid-wrapper-p
+                accessor-type index)))))
 
 (defun cache-miss-values-internal (gf arg-info wrappers classes types state)
   (let* ((for-accessor-p (eq state 'accessor))

src/pcl/methods.lisp

@@ -23,22 +23,6 @@
 
 (in-package "SB-PCL")
 
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-				     slot-names &key)
-  (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
-
-(defmethod shared-initialize :after ((slotd structure-slot-definition)
-				     slot-names
-				     &key (allocation :instance))
-  (declare (ignore slot-names))
-  (unless (eq allocation :instance)
-    (error "Structure slots must have :INSTANCE allocation.")))
-
-(defmethod inform-type-system-about-class ((class structure-class) (name t))
-  nil)
 
 ;;; methods
 ;;;

src/pcl/slots-boot.lisp

@@ -84,20 +84,13 @@
 	`(let ,bindings ,form)
 	form)))
 
-;;; FIXME: Why is this defined in two different places? And what does
-;;; it mean anyway? And can we just eliminate it completely (replacing
-;;; it with NIL, then hand-eliminating any resulting dead code)?
-(defconstant +optimize-slot-boundp+ nil)
-
 (defmacro accessor-slot-boundp (object slot-name)
   (unless (constantp slot-name)
     (error "~S requires its slot-name argument to be a constant"
 	   'accessor-slot-boundp))
   (let* ((slot-name (eval slot-name))
 	 (sym (slot-boundp-symbol slot-name)))
-    (if (not +optimize-slot-boundp+)
-	`(slot-boundp-normal ,object ',slot-name)
-	`(asv-funcall ,sym ,slot-name boundp ,object))))
+    `(slot-boundp-normal ,object ',slot-name)))
 
 (defun structure-slot-boundp (object)
   (declare (ignore object))
@@ -411,12 +404,6 @@
 	   (gf (ensure-generic-function name)))
       (unless (generic-function-methods gf)
 	(add-writer-method *the-class-slot-object* gf slot-name))))
-  (when (and +optimize-slot-boundp+
-	     (or (null type) (eq type 'boundp)))
-    (let* ((name (slot-boundp-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-boundp-method *the-class-slot-object* gf slot-name))))
   nil)
 
 (defun initialize-internal-slot-gfs* (readers writers boundps)

src/pcl/slots.lisp

@@ -144,8 +144,6 @@
       `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
       `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
 
-(defconstant +optimize-slot-boundp+ nil)
-
 (defun slot-boundp (object slot-name)
   (let* ((class (class-of object))
 	 (slot-definition (find-slot-definition class slot-name)))

src/pcl/std-class.lisp

@@ -335,10 +335,9 @@
 (defmethod ensure-class-using-class (name (class null) &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
-    (inform-type-system-about-class (class-prototype meta) name);***
     (setf class (apply #'make-instance meta :name name initargs)
 	  (find-class name) class)
-    (inform-type-system-about-class class name)			;***
+    (inform-type-system-about-class class name)
     class))
 
 (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
@@ -347,7 +346,7 @@
     (unless (eq (class-of class) meta) (change-class class meta))
     (apply #'reinitialize-instance class initargs)
     (setf (find-class name) class)
-    (inform-type-system-about-class class name)			;***
+    (inform-type-system-about-class class name)
     class))
 
 (defmethod class-predicate-name ((class t))
@@ -387,14 +386,6 @@
 		     (and (neq supplied-slots unsupplied) supplied-slots)
 		     initargs)))))
 
-#|| ; since it doesn't do anything
-(defmethod shared-initialize :before ((class std-class)
-				      slot-names
-				      &key direct-superclasses)
-  (declare (ignore slot-names))
-  ;; *** error checking
-  )
-||#
 
 (defmethod shared-initialize :after
 	   ((class std-class)
@@ -472,6 +463,20 @@
 		  #'(lambda (dependent)
 		      (apply #'update-dependent class dependent initargs))))
 
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+				     slot-names &key)
+  (declare (ignore slot-names))
+  (with-slots (allocation class)
+    slotd
+    (setq allocation (if (eq allocation :class) class allocation))))
+
+(defmethod shared-initialize :after ((slotd structure-slot-definition)
+				     slot-names
+				     &key (allocation :instance))
+  (declare (ignore slot-names))
+  (unless (eq allocation :instance)
+    (error "Structure slots must have :INSTANCE allocation.")))
+
 (defmethod shared-initialize :after
       ((class structure-class)
        slot-names
@@ -968,7 +973,7 @@
 ;;; *** There is a subtle bug here which is going to have to be fixed.
 ;;; *** Namely, the simplistic use of the template has to be fixed. We
 ;;; *** have to give the optimize-slot-value method the user might have
-;;; *** defined for this metclass a chance to run.
+;;; *** defined for this metaclass a chance to run.
 
 (defmethod make-reader-method-function ((class slot-class) slot-name)
   (make-std-reader-method-function (class-name class) slot-name))
@@ -980,7 +985,6 @@
   (make-std-boundp-method-function (class-name class) slot-name))
 
 ;;;; inform-type-system-about-class
-;;;; make-type-predicate
 ;;;
 ;;; These are NOT part of the standard protocol. They are internal
 ;;; mechanism which PCL uses to *try* and tell the type system about
@@ -990,6 +994,9 @@
 ;;; the type system about new classes would be different.
 (defmethod inform-type-system-about-class ((class std-class) name)
   (inform-type-system-about-std-class name))
+
+(defmethod inform-type-system-about-class ((class structure-class) (name t))
+  nil)
 
 (defmethod compatible-meta-class-change-p (class proto-new-class)
   (eq (class-of class) (class-of proto-new-class)))

tests/pcl.impure.lisp → tests/clos.impure.lisp

@@ -17,10 +17,8 @@
 
 ;;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
 ;;;; structure types defined earlier in the file.
-
 (defstruct struct-a x y)
 (defstruct struct-b x y z)
-
 (defmethod wiggle ((a struct-a))
   (+ (struct-a-x a)
      (struct-a-y a)))
@@ -32,17 +30,23 @@
   (- (struct-b-x b)
      (struct-b-y b)
      (struct-b-z b)))
-
 (assert (= (wiggle (make-struct-a :x 6 :y 5))
            (jiggle (make-struct-b :x 19 :y 6 :z 2))))
-
+
 ;;; Compiling DEFGENERIC should prevent "undefined function" style warnings
 ;;; from code within the same file.
-
 (defgeneric gf-defined-in-this-file ((x number) (y number)))
 (defun function-using-gf-defined-in-this-file (x y n)
   (unless (minusp n)
     (gf-defined-in-this-file x y)))
+
+;;; Until Martin Atzmueller ported Pierre Mai's CMU CL fixes in
+;;; sbcl-0.6.12.25, the implementation of NO-APPLICABLE-METHOD was
+;;; broken in such a way that the code here would signal an error.
+(defgeneric zut-n-a-m (a b c))
+(defmethod no-applicable-method ((zut-n-a-m (eql #'zut-n-a-m)) &rest args)
+  (format t "~&No applicable method for ZUT-N-A-M ~S, yet.~%" args))
+(zut-n-a-m 1 2 3)
 
 ;;;; success
 

version.lisp-expr

@@ -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.12.24"
+"0.6.12.25"