From 203c15eefffd996fd20bd28d461ea1aa3865dbbe Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 7 Jun 2001 19:22:26 +0000 Subject: [PATCH] 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 | 14 ++++++------- src/pcl/boot.lisp | 6 +++++- src/pcl/defclass.lisp | 20 ++++++++++++++---- src/pcl/defs.lisp | 31 +++++++++++---------------- src/pcl/dfun.lisp | 30 ++++++++++++--------------- src/pcl/methods.lisp | 16 -------------- src/pcl/slots-boot.lisp | 15 +------------- src/pcl/slots.lisp | 2 -- src/pcl/std-class.lisp | 33 +++++++++++++++++------------ tests/clos.impure.lisp | 53 +++++++++++++++++++++++++++++++++++++++++++++++ tests/pcl.impure.lisp | 49 ------------------------------------------- version.lisp-expr | 2 +- 12 files changed, 128 insertions(+), 143 deletions(-) create mode 100644 tests/clos.impure.lisp delete mode 100644 tests/pcl.impure.lisp diff --git a/NEWS b/NEWS index 9ab2a07..841a38d 100644 --- a/NEWS +++ b/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 diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 1152cec..37afe01 100644 --- a/src/pcl/boot.lisp +++ b/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 diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index f4d934a..ed10b5f 100644 --- a/src/pcl/defclass.lisp +++ b/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))))))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 7cc68d3..655b3b9 100644 --- a/src/pcl/defs.lisp +++ b/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* ()) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 8a44336..bdb2dd0 100644 --- a/src/pcl/dfun.lisp +++ b/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)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index a95c72e..f4fca4f 100644 --- a/src/pcl/methods.lisp +++ b/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 ;;; diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 998b02b..98d9848 100644 --- a/src/pcl/slots-boot.lisp +++ b/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) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 6d82bcd..7b217e3 100644 --- a/src/pcl/slots.lisp +++ b/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))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index bf55281..0c90dc3 100644 --- a/src/pcl/std-class.lisp +++ b/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))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp new file mode 100644 index 0000000..983fd57 --- /dev/null +++ b/tests/clos.impure.lisp @@ -0,0 +1,53 @@ +;;;; miscellaneous side-effectful tests of CLOS + +;;;; 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. + +(defpackage "FOO" + (:use "CL")) +(in-package "FOO") + +;;;; 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))) +(defgeneric jiggle ((arg t))) +(defmethod jiggle ((a struct-a)) + (- (struct-a-x a) + (struct-a-y a))) +(defmethod jiggle ((b struct-b)) + (- (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 + +(sb-ext:quit :unix-status 104) diff --git a/tests/pcl.impure.lisp b/tests/pcl.impure.lisp deleted file mode 100644 index 8486540..0000000 --- a/tests/pcl.impure.lisp +++ /dev/null @@ -1,49 +0,0 @@ -;;;; miscellaneous side-effectful tests of CLOS - -;;;; 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. - -(defpackage "FOO" - (:use "CL")) -(in-package "FOO") - -;;;; 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))) -(defgeneric jiggle ((arg t))) -(defmethod jiggle ((a struct-a)) - (- (struct-a-x a) - (struct-a-y a))) -(defmethod jiggle ((b struct-b)) - (- (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))) - -;;;; success - -(sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index e009f94..c8f05b1 100644 --- a/version.lisp-expr +++ b/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" -- 1.7.10.4