From: Christophe Rhodes Date: Wed, 9 Aug 2006 16:35:28 +0000 (+0000) Subject: 0.9.15.19: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bb8121bf453353ce2cadc85d9be7be05ca6248ff;p=sbcl.git 0.9.15.19: Allow forward-referenced-classes as specializers ... they are SPECIALIZERP, they have proper names... ... but it's at least slightly ANSIly-extending, so signal a STYLE-WARNING. Take this opportunity to rework the method initarg checking code ... no more LEGAL-FOO generic functions. --- diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index cf62b49..bdb7811 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -557,21 +557,26 @@ (logand mask result) (the fixnum (1+ (logand mask result)))))) -;;; NIL means nothing so far, no actual arg info has NILs -;;; in the metatype -;;; CLASS seen all sorts of metaclasses -;;; (specifically, more than one of the next 4 values) -;;; T means everything so far is the class T -;;; STANDARD-CLASS seen only standard classes -;;; BUILT-IN-CLASS seen only built in classes -;;; STRUCTURE-CLASS seen only structure classes +;;; NIL: means nothing so far, no actual arg info has NILs in the +;;; metatype +;;; +;;; CLASS: seen all sorts of metaclasses (specifically, more than one +;;; of the next 5 values) or else have seen something which doesn't +;;; fall into a single category (SLOT-INSTANCE, FORWARD). +;;; +;;; T: means everything so far is the class T +;;; STANDARD-INSTANCE: seen only standard classes +;;; BUILT-IN-INSTANCE: seen only built in classes +;;; STRUCTURE-INSTANCE: seen only structure classes +;;; CONDITION-INSTANCE: seen only condition classes (defun raise-metatype (metatype new-specializer) (let ((slot (find-class 'slot-class)) (standard (find-class 'standard-class)) (fsc (find-class 'funcallable-standard-class)) (condition (find-class 'condition-class)) (structure (find-class 'structure-class)) - (built-in (find-class 'built-in-class))) + (built-in (find-class 'built-in-class)) + (frc (find-class 'forward-referenced-class))) (flet ((specializer->metatype (x) (let ((meta-specializer (if (eq *boot-state* 'complete) @@ -585,18 +590,19 @@ ((*subtypep meta-specializer structure) 'structure-instance) ((*subtypep meta-specializer built-in) 'built-in-instance) ((*subtypep meta-specializer slot) 'slot-instance) + ((*subtypep meta-specializer frc) 'forward) (t (error "~@" - new-specializer - meta-specializer)))))) + new-specializer meta-specializer)))))) ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; - ;; NIL ===> - ;; X X ===> X - ;; X Y ===> CLASS + ;; NIL ===> + ;; X X ===> X + ;; X Y ===> CLASS (let ((new-metatype (specializer->metatype new-specializer))) (cond ((eq new-metatype 'slot-instance) 'class) + ((eq new-metatype 'forward) 'class) ((null metatype) new-metatype) ((eq metatype new-metatype) new-metatype) (t 'class)))))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 498c72d..36195fa 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -26,8 +26,6 @@ (defgeneric generic-function-p (object)) -(defgeneric legal-lambda-list-p (object x)) - (defgeneric method-combination-p (object)) (defgeneric method-p (object)) @@ -332,20 +330,6 @@ (defgeneric effective-slot-definition-class (class &rest initargs)) -(defgeneric legal-documentation-p (object x)) - -(defgeneric legal-method-function-p (object x)) - -(defgeneric legal-qualifier-p (object x)) - -(defgeneric legal-qualifiers-p (object x)) - -(defgeneric legal-slot-name-p (object x)) - -(defgeneric legal-specializer-p (object x)) - -(defgeneric legal-specializers-p (object x)) - (defgeneric make-boundp-method-function (class slot-name)) (defgeneric make-reader-method-function (class slot-name)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 4acbaae..92e94b8 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -72,101 +72,94 @@ (def update-instance-for-different-class ((old method) new &rest initargs) "No behaviour specified for ~S on method objects.")) -(defmethod legal-documentation-p ((object standard-method) x) - (if (or (null x) (stringp x)) - t - "a string or NULL")) - -(defmethod legal-lambda-list-p ((object standard-method) x) - (declare (ignore x)) - t) +(define-condition invalid-method-initarg (simple-program-error) + ((method :initarg :method :reader invalid-method-initarg-method)) + (:report + (lambda (c s) + (format s "~@" + (invalid-method-initarg-method c) + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(defun invalid-method-initarg (method format-control &rest args) + (error 'invalid-method-initarg :method method + :format-control format-control :format-arguments args)) + +(defun check-documentation (method doc) + (unless (or (null doc) (stringp doc)) + (invalid-method-initarg method "~@<~S of ~S is neither ~S nor a ~S.~@:>" + :documentation doc 'null 'string))) +(defun check-lambda-list (method ll) + nil) -(defmethod legal-method-function-p ((object standard-method) x) - (if (functionp x) - t - "a function")) +(defun check-method-function (method fun) + (unless (functionp fun) + (invalid-method-initarg method "~@<~S of ~S is not a ~S.~@:>" + :function fun 'function))) -(defmethod legal-qualifiers-p ((object standard-method) x) +(defun check-qualifiers (method qualifiers) (flet ((improper-list () - (return-from legal-qualifiers-p "Is not a proper list."))) - (dolist-carefully (q x improper-list) - (let ((ok (legal-qualifier-p object q))) - (unless (eq ok t) - (return-from legal-qualifiers-p - (format nil "Contains ~S which ~A" q ok))))) - t)) - -(defmethod legal-qualifier-p ((object standard-method) x) - (if (and x (atom x)) - t - "is not a non-null atom")) - -(defmethod legal-slot-name-p ((object standard-method) x) - (cond ((not (symbolp x)) "is not a symbol") - (t t))) - -(defmethod legal-specializers-p ((object standard-method) x) + (invalid-method-initarg method + "~@<~S of ~S is an improper list.~@:>" + :qualifiers qualifiers))) + (dolist-carefully (q qualifiers improper-list) + (unless (and q (atom q)) + (invalid-method-initarg method + "~@<~S, in ~S ~S, is not a non-~S atom.~@:>" + q :qualifiers qualifiers 'null))))) + +(defun check-slot-name (method name) + (unless (symbolp name) + (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>" + :slot-name name 'symbol))) + +(defun check-specializers (method specializers) (flet ((improper-list () - (return-from legal-specializers-p "Is not a proper list."))) - (dolist-carefully (s x improper-list) - (let ((ok (legal-specializer-p object s))) - (unless (eq ok t) - (return-from legal-specializers-p - (format nil "Contains ~S which ~A" s ok))))) - t)) - -(defvar *allow-experimental-specializers-p* nil) - -(defmethod legal-specializer-p ((object standard-method) x) - (if (if *allow-experimental-specializers-p* - (specializerp x) - (or (classp x) - (eql-specializer-p x))) - t - "is neither a class object nor an EQL specializer")) - -(defmethod shared-initialize :before ((method standard-method) - slot-names - &key qualifiers - lambda-list - specializers - function - fast-function - documentation) + (invalid-method-initarg method + "~@<~S of ~S is an improper list.~@:>" + :specializers specializers))) + (dolist-carefully (s specializers improper-list) + (unless (specializerp s) + (invalid-method-initarg method + "~@<~S, in ~S ~S, is not a ~S.~@:>" + s :specializers specializers 'specializer))) + ;; KLUDGE: ANSI says that it's not valid to have methods + ;; specializing on classes which are "not defined", leaving + ;; unclear what the definedness of a class is; AMOP suggests that + ;; forward-referenced-classes, since they have proper names and + ;; all, are at least worthy of some level of definition. We allow + ;; methods specialized on forward-referenced-classes, but it's + ;; non-portable and potentially dubious, so + (let ((frcs (remove-if-not #'forward-referenced-class-p specializers))) + (unless (null frcs) + (style-warn "~@" + (length frcs) frcs))))) + +(defmethod shared-initialize :before + ((method standard-method) slot-names &key + qualifiers lambda-list specializers function fast-function documentation) (declare (ignore slot-names)) - (flet ((lose (initarg value string) - (error "when initializing the method ~S:~%~ - The ~S initialization argument was: ~S.~%~ - which ~A." - method initarg value string))) - (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) - (check-lambda-list (legal-lambda-list-p method lambda-list)) - (check-specializers (legal-specializers-p method specializers)) - (check-fun (legal-method-function-p method - (or function - fast-function))) - (check-documentation (legal-documentation-p method documentation))) - (unless (eq check-qualifiers t) - (lose :qualifiers qualifiers check-qualifiers)) - (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) - (unless (eq check-specializers t) - (lose :specializers specializers check-specializers)) - (unless (eq check-fun t) - (lose :function function check-fun)) - (unless (eq check-documentation t) - (lose :documentation documentation check-documentation))))) - -(defmethod shared-initialize :before ((method standard-accessor-method) - slot-names - &key slot-name slot-definition) + ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get + ;; this extra paranoia and nothing else does; either everything + ;; should be aggressively checking initargs, or nothing much should. + ;; In either case, it would probably be better to have :type + ;; declarations in slots, which would then give a suitable type + ;; error (if we implement type-checking for slots...) rather than + ;; this hand-crafted thing. + (check-qualifiers method qualifiers) + (check-lambda-list method lambda-list) + (check-specializers method specializers) + (check-method-function method (or function fast-function)) + (check-documentation method documentation)) + +(defmethod shared-initialize :before + ((method standard-accessor-method) slot-names &key + slot-name slot-definition) (declare (ignore slot-names)) (unless slot-definition - (let ((legalp (legal-slot-name-p method slot-name))) - ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and - ;; ILLEGALP, and the convention redone to be less twisty - (unless (eq legalp t) - (error "The value of the :SLOT-NAME initarg ~A." legalp))))) + (check-slot-name method slot-name))) (defmethod shared-initialize :after ((method standard-method) slot-names &rest initargs diff --git a/tests/mop-22.impure-cload.lisp b/tests/mop-22.impure-cload.lisp new file mode 100644 index 0000000..75d9577 --- /dev/null +++ b/tests/mop-22.impure-cload.lisp @@ -0,0 +1,55 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; 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. + +;;; Forward-referenced classes as specializers. + +(defpackage "MOP-22" + (:use "CL" "SB-MOP")) + +(in-package "MOP-22") + +;;; It's generally unclear to me whether this should be allowed. On +;;; the one hand, FORWARD-REFERENCED-CLASS is a subclass of CLASS and +;;; hence of SPECIALIZER, and AMOP specifies that as-yet-undefined +;;; superclasses of STANDARD-CLASSes are FORWARD-REFERENCED-CLASSes of +;;; the appropriate proper name. On the other hand, ANSI specifies +;;; that DEFCLASS defines _a_ class, and that classes should be +;;; defined before they can be used as specializers in DEFMETHOD forms +;;; (though ANSI also allows implementations to extend the object +;;; system in this last respect). Future maintainers should feel free +;;; to cause this test to fail if it improves the lot of some other +;;; codepath. -- CSR, 2006-08-09 + +(defclass incomplete (forward) ()) + +(defgeneric incomplete/1 (x) + (:method ((x incomplete)) 'incomplete)) + +(defgeneric forward/1 (x) + (:method ((x forward)) 'forward)) + +;;; with many arguments to avoid the precomputed discriminating +;;; function generators +(defgeneric incomplete/7 (a b c d e f g) + (:method ((a incomplete) (b forward) + c (d integer) (e condition) (f class) g) t)) + +(defclass forward () ()) + +(assert (eq (incomplete/1 (make-instance 'incomplete)) 'incomplete)) +(assert (eq (forward/1 (make-instance 'forward)) 'forward)) +(assert (eq (incomplete/7 (make-instance 'incomplete) + (make-instance 'incomplete) + t 1 (make-condition 'error) + (find-class 'incomplete) 3) + t)) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 1fb05ee..31edb6d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.15.18" +"0.9.15.19"