(logand mask result)
(the fixnum (1+ (logand mask result))))))
\f
-;;; 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)
((*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 "~@<PCL cannot handle the specializer ~S ~
(meta-specializer ~S).~@:>"
- 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 <anything> ===> <anything>
- ;; X X ===> X
- ;; X Y ===> CLASS
+ ;; NIL <anything> ===> <anything>
+ ;; 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))))))
(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 "~@<In initialization of ~S:~2I~_~?~@:>"
+ (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 "~@<Defining a method using ~
+ ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
+ as ~2:*~V[~;a specializer~:;specializers~].~@:>"
+ (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
--- /dev/null
+;;;; 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
projects / sbcl.git / commitdiff