|#
-(declaim (notinline make-a-method
- add-named-method
+(declaim (notinline make-a-method add-named-method
ensure-generic-function-using-class
- add-method
- remove-method))
+ add-method remove-method))
(defvar *!early-functions*
- '((make-a-method early-make-a-method
- real-make-a-method)
- (add-named-method early-add-named-method
- real-add-named-method)
- ))
+ '((make-a-method early-make-a-method real-make-a-method)
+ (add-named-method early-add-named-method real-add-named-method)))
;;; For each of the early functions, arrange to have it point to its
;;; early definition. Do this in a way that makes sure that if we
;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
;;; to convert the few functions in the bootstrap which are supposed
;;; to be generic functions but can't be early on.
+;;;
+;;; each entry is a list of name and lambda-list, class names as
+;;; specializers, and method body function name.
(defvar *!generic-function-fixups*
'((add-method
- ((generic-function method) ;lambda-list
- (standard-generic-function method) ;specializers
- real-add-method)) ;method-function
+ ((generic-function method)
+ (standard-generic-function method)
+ real-add-method))
(remove-method
((generic-function method)
(standard-generic-function method)
((proto-generic-function proto-method lambda-expression environment)
(standard-generic-function standard-method t t)
real-make-method-lambda))
+ (make-method-specializers-form
+ ((proto-generic-function proto-method specializer-names environment)
+ (standard-generic-function standard-method t t)
+ real-make-method-specializers-form))
+ (parse-specializer-using-class
+ ((generic-function specializer)
+ (standard-generic-function t)
+ real-parse-specializer-using-class))
+ (unparse-specializer-using-class
+ ((generic-function specializer)
+ (standard-generic-function t)
+ real-unparse-specializer-using-class))
(make-method-initargs-form
((proto-generic-function proto-method
lambda-expression
(let ((car-option (car option)))
(case car-option
(declare
- (when (and
- (consp (cadr option))
- (member (first (cadr option))
- ;; FIXME: this list is slightly weird.
- ;; ANSI (on the DEFGENERIC page) in one
- ;; place allows only OPTIMIZE; in
- ;; another place gives this list of
- ;; disallowed declaration specifiers.
- ;; This seems to be the only place where
- ;; the FUNCTION declaration is
- ;; mentioned; TYPE seems to be missing.
- ;; Very strange. -- CSR, 2002-10-21
- '(declaration ftype function
- inline notinline special)))
- (error 'simple-program-error
- :format-control "The declaration specifier ~S ~
+ (dolist (spec (cdr option))
+ (unless (consp spec)
+ (error 'simple-program-error
+ :format-control "~@<Invalid declaration specifier in ~
+ DEFGENERIC: ~S~:@>"
+ :format-arguments (list spec)))
+ (when (member (first spec)
+ ;; FIXME: this list is slightly weird.
+ ;; ANSI (on the DEFGENERIC page) in one
+ ;; place allows only OPTIMIZE; in
+ ;; another place gives this list of
+ ;; disallowed declaration specifiers.
+ ;; This seems to be the only place where
+ ;; the FUNCTION declaration is
+ ;; mentioned; TYPE seems to be missing.
+ ;; Very strange. -- CSR, 2002-10-21
+ '(declaration ftype function
+ inline notinline special))
+ (error 'simple-program-error
+ :format-control "The declaration specifier ~S ~
is not allowed inside DEFGENERIC."
- :format-arguments (list (cadr option))))
- (push (cadr option) (initarg :declarations)))
+ :format-arguments (list spec)))
+ (if (or (eq 'optimize (first spec))
+ (info :declaration :recognized (first spec)))
+ (push spec (initarg :declarations))
+ (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S"
+ spec))))
(:method-combination
(when (initarg car-option)
(duplicate-option car-option))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',fun-name))
- (load-defgeneric ',fun-name ',lambda-list ,@initargs)
- ,@(mapcar #'expand-method-definition methods)
- (fdefinition ',fun-name)))))
+ (load-defgeneric ',fun-name ',lambda-list
+ (sb-c:source-location) ,@initargs)
+ ,@(mapcar #'expand-method-definition methods)
+ (fdefinition ',fun-name)))))
(defun compile-or-load-defgeneric (fun-name)
(proclaim-as-fun-name fun-name)
(setf (info :function :type fun-name)
(specifier-type 'function))))
-(defun load-defgeneric (fun-name lambda-list &rest initargs)
+(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
- (style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (warn 'sb-kernel:redefinition-with-defgeneric
+ :name fun-name
+ :new-location source-location)
(let ((fun (fdefinition fun-name)))
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
(apply #'ensure-generic-function
fun-name
:lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
+ :definition-source source-location
initargs))
(define-condition generic-function-lambda-list-error
;; belong here!
(aver (not morep)))))
\f
-(defmacro defmethod (&rest args &environment env)
- (multiple-value-bind (name qualifiers lambda-list body)
+(defmacro defmethod (name &rest args)
+ (multiple-value-bind (qualifiers lambda-list body)
(parse-defmethod args)
- (multiple-value-bind (proto-gf proto-method)
- (prototypes-for-make-method-lambda name)
- (expand-defmethod name
- proto-gf
- proto-method
- qualifiers
- lambda-list
- body
- env))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (compile-or-load-defgeneric ',name))
+ ;; KLUDGE: this double expansion is quite a monumental
+ ;; workaround: it comes about because of a fantastic interaction
+ ;; between the processing rules of CLHS 3.2.3.1 and the
+ ;; bizarreness of MAKE-METHOD-LAMBDA.
+ ;;
+ ;; MAKE-METHOD-LAMBDA can be called by the user, and if the
+ ;; lambda itself doesn't refer to outside bindings the return
+ ;; value must be compileable in the null lexical environment.
+ ;; However, the function must also refer somehow to the
+ ;; associated method object, so that it can call NO-NEXT-METHOD
+ ;; with the appropriate arguments if there is no next method --
+ ;; but when the function is generated, the method object doesn't
+ ;; exist yet.
+ ;;
+ ;; In order to resolve this issue, we insert a literal cons cell
+ ;; into the body of the method lambda, return the same cons cell
+ ;; as part of the second (initargs) return value of
+ ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills
+ ;; in the cell when the method is created. However, this
+ ;; strategy depends on having a fresh cons cell for every method
+ ;; lambda, which (without the workaround below) is skewered by
+ ;; the processing in CLHS 3.2.3.1, which permits implementations
+ ;; to macroexpand the bodies of EVAL-WHEN forms with both
+ ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once. The
+ ;; expansion below forces the double expansion in those cases,
+ ;; while expanding only once in the common case.
+ (eval-when (:load-toplevel)
+ (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))
+ (eval-when (:execute)
+ (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
+
+(defmacro %defmethod-expander
+ (name qualifiers lambda-list body &environment env)
+ (multiple-value-bind (proto-gf proto-method)
+ (prototypes-for-make-method-lambda name)
+ (expand-defmethod name proto-gf proto-method qualifiers
+ lambda-list body env)))
+
(defun prototypes-for-make-method-lambda (name)
- (if (not (eq *boot-state* 'complete))
+ (if (not (eq **boot-state** 'complete))
(values nil nil)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
(if (or (null gf?)
(not (generic-function-p gf?)))
;;;
;;; Note: During bootstrapping, this function is allowed to return NIL.
(defun method-prototype-for-gf (name)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
- (cond ((neq *boot-state* 'complete) nil)
+ (cond ((neq **boot-state** 'complete) nil)
((or (null gf?)
(not (generic-function-p gf?))) ; Someone else MIGHT
; error at load time.
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
\f
+;;; These are used to communicate the method name and lambda-list to
+;;; MAKE-METHOD-LAMBDA-INTERNAL.
+(defvar *method-name* nil)
+(defvar *method-lambda-list* nil)
+
(defun expand-defmethod (name
proto-gf
proto-method
lambda-list
body
env)
- (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
- (add-method-declarations name qualifiers lambda-list body env)
- (multiple-value-bind (method-function-lambda initargs)
- (make-method-lambda proto-gf proto-method method-lambda env)
- (let ((initargs-form (make-method-initargs-form proto-gf
- proto-method
- method-function-lambda
- initargs
- env)))
- `(progn
- ;; Note: We could DECLAIM the ftype of the generic function
- ;; here, since ANSI specifies that we create it if it does
- ;; not exist. However, I chose not to, because I think it's
- ;; more useful to support a style of programming where every
- ;; generic function has an explicit DEFGENERIC and any typos
- ;; in DEFMETHODs are warned about. Otherwise
- ;;
- ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
- ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
- ;;
- ;; compiles without raising an error and runs without
- ;; raising an error (since SIMPLE-VECTOR cases fall through
- ;; to VECTOR) but still doesn't do what was intended. I hate
- ;; that kind of bug (code which silently gives the wrong
- ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
- ,(make-defmethod-form name qualifiers specializers
- unspecialized-lambda-list
- (if proto-method
- (class-name (class-of proto-method))
- 'standard-method)
- initargs-form
- (getf (getf initargs :plist)
- :pv-table-symbol)))))))
+ (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+ (parse-specialized-lambda-list lambda-list)
+ (declare (ignore parameters))
+ (let ((method-lambda `(lambda ,unspecialized-lambda-list ,@body))
+ (*method-name* `(,name ,@qualifiers ,specializers))
+ (*method-lambda-list* lambda-list))
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form
+ proto-gf proto-method method-function-lambda
+ initargs env))
+ (specializers-form (make-method-specializers-form
+ proto-gf proto-method specializers env)))
+ `(progn
+ ;; Note: We could DECLAIM the ftype of the generic function
+ ;; here, since ANSI specifies that we create it if it does
+ ;; not exist. However, I chose not to, because I think it's
+ ;; more useful to support a style of programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH (X))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers-form
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form)))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
-(defun make-defmethod-form (name qualifiers specializers
- unspecialized-lambda-list method-class-name
- initargs-form &optional pv-table-symbol)
+(defun make-defmethod-form
+ (name qualifiers specializers unspecialized-lambda-list
+ method-class-name initargs-form)
(let (fn
fn-lambda)
(if (and (interned-symbol-p (fun-name-block-name name))
(if (consp s)
(and (eq (car s) 'eql)
(constantp (cadr s))
- (let ((sv (eval (cadr s))))
+ (let ((sv (constant-form-value (cadr s))))
(or (interned-symbol-p sv)
(integerp sv)
(and (characterp sv)
specializers)
(consp initargs-form)
(eq (car initargs-form) 'list*)
- (memq (cadr initargs-form) '(:function :fast-function))
+ (memq (cadr initargs-form) '(:function))
(consp (setq fn (caddr initargs-form)))
(eq (car fn) 'function)
(consp (setq fn-lambda (cadr fn)))
- (eq (car fn-lambda) 'lambda))
+ (eq (car fn-lambda) 'lambda)
+ (bug "Really got here"))
(let* ((specls (mapcar (lambda (specl)
(if (consp specl)
+ ;; CONSTANT-FORM-VALUE? What I
+ ;; kind of want to know, though,
+ ;; is what happens if we don't do
+ ;; this for some slow-method
+ ;; function because of a hairy
+ ;; lexenv -- is the only bad
+ ;; effect that the method
+ ;; function ends up unnamed? If
+ ;; so, couldn't we arrange to
+ ;; name it later?
`(,(car specl) ,(eval (cadr specl)))
specl))
specializers))
unspecialized-lambda-list method-class-name
`(list* ,(cadr initargs-form)
#',mname
- ,@(cdddr initargs-form))
- pv-table-symbol)))
+ ,@(cdddr initargs-form)))))
(make-defmethod-form-internal
name qualifiers
+ specializers
+ #+nil
`(list ,@(mapcar (lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
specializers))
unspecialized-lambda-list
method-class-name
- initargs-form
- pv-table-symbol))))
+ initargs-form))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
- method-class-name initargs-form &optional pv-table-symbol)
+ method-class-name initargs-form)
`(load-defmethod
',method-class-name
',name
,specializers-form
',unspecialized-lambda-list
,initargs-form
- ;; Paper over a bug in KCL by passing the cache-symbol here in
- ;; addition to in the list. FIXME: We should no longer need to do
- ;; this, since the CLOS code is now SBCL-specific, and doesn't
- ;; need to be ported to every buggy compiler in existence.
- ',pv-table-symbol))
+ (sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
- (make-method-function-internal method-lambda env))
-
-(defun make-method-function-internal (method-lambda &optional env)
(multiple-value-bind (proto-gf proto-method)
(prototypes-for-make-method-lambda nil)
(multiple-value-bind (method-function-lambda initargs)
initargs
env))))
-(defun add-method-declarations (name qualifiers lambda-list body env)
- (declare (ignore env))
- (multiple-value-bind (parameters unspecialized-lambda-list specializers)
- (parse-specialized-lambda-list lambda-list)
- (multiple-value-bind (real-body declarations documentation)
- (parse-body body)
- (values `(lambda ,unspecialized-lambda-list
- ,@(when documentation `(,documentation))
- ;; (Old PCL code used a somewhat different style of
- ;; list for %METHOD-NAME values. Our names use
- ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
- ;; method names look more like what you see in a
- ;; DEFMETHOD form.)
- ;;
- ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
- ;; least the code to set up named BLOCKs around the
- ;; bodies of methods, depends on the function's base
- ;; name being the first element of the %METHOD-NAME
- ;; list. It would be good to remove this dependency,
- ;; perhaps by building the BLOCK here, or by using
- ;; 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)))
- (declare (%method-lambda-list ,@lambda-list))
- ,@declarations
- ,@real-body)
- unspecialized-lambda-list specializers))))
-
(defun real-make-method-initargs-form (proto-gf proto-method
method-lambda initargs env)
(declare (ignore proto-gf proto-method))
(setf (gdefinition 'make-method-initargs-form)
(symbol-function 'real-make-method-initargs-form)))
+;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
+;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of
+;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the
+;;; REAL-MAKE-METHOD lambda is used as the body of the default method.
+;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function
+;;; so that changing it in a live image is easy, and changes actually
+;;; take effect.
(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
- (declare (ignore proto-gf proto-method))
- (make-method-lambda-internal method-lambda env))
+ (make-method-lambda-internal proto-gf proto-method method-lambda env))
-;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
- (cond ((and (consp specializer)
- (eq (car specializer) 'eql))
- ;; KLUDGE: ANSI, in its wisdom, says that
- ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
- ;; DEFMETHOD expansion time. Thus, although one might think
- ;; that in
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 12))
- ;; ..))
- ;; the PACKAGE and (EQL 12) forms are both parallel type
- ;; names, they're not, as is made clear when you do
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 'BAR)))
- ;; ..)
- ;; where Y needs to be a symbol named "BAR", not some cons
- ;; made by (CONS 'QUOTE 'BAR). I.e. when the
- ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
- ;; to be of type (EQL X). It'd be easy to transform one to
- ;; the other, but it'd be somewhat messier to do so while
- ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
- ;; once. (The new code wouldn't be messy, but it'd require a
- ;; big transformation of the old code.) So instead we punt.
- ;; -- WHN 20000610
- '(ignorable))
- ((member specializer
- ;; KLUDGE: For some low-level implementation
- ;; classes, perhaps because of some problems related
- ;; to the incomplete integration of PCL into SBCL's
- ;; type system, some specializer classes can't be
- ;; declared as argument types. E.g.
- ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
- ;; (DECLARE (TYPE SLOT-OBJECT X))
- ;; ..)
- ;; loses when
- ;; (DEFSTRUCT BAR A B)
- ;; (FOO (MAKE-BAR))
- ;; perhaps because of the way that STRUCTURE-OBJECT
- ;; inherits both from SLOT-OBJECT and from
- ;; SB-KERNEL:INSTANCE. In an effort to sweep such
- ;; problems under the rug, we exclude these problem
- ;; cases by blacklisting them here. -- WHN 2001-01-19
- '(slot-object))
- '(ignorable))
- ((not (eq *boot-state* 'complete))
- ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
- ;; types which don't match their specializers. (Specifically,
- ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
- ;; second argument.) Hopefully it only does this kind of
- ;; weirdness when bootstrapping.. -- WHN 20000610
- '(ignorable))
- ((var-globally-special-p parameter)
- ;; KLUDGE: Don't declare types for global special variables
- ;; -- our rebinding magic for SETQ cases don't work right
- ;; there.
- ;;
- ;; FIXME: It would be better to detect the SETQ earlier and
- ;; skip declarations for specials only when needed, not
- ;; always.
- ;;
- ;; --NS 2004-10-14
- '(ignorable))
- (t
- ;; Otherwise, we can usually make Python very happy.
- (let ((kind (info :type :kind specializer)))
- (ecase kind
- ((:primitive) `(type ,specializer ,parameter))
- ((:defined)
- (let ((class (find-class specializer nil)))
- ;; CLASS can be null here if the user has erroneously
- ;; tried to use a defined type as a specializer; it
- ;; can be a non-BUILT-IN-CLASS if the user defines a
- ;; type and calls (SETF FIND-CLASS) in a consistent
- ;; way.
- (when (and class (typep class 'built-in-class))
- `(type ,specializer ,parameter))))
- ((:instance nil)
- (let ((class (find-class specializer nil)))
- (cond
- (class
- (if (typep class '(or built-in-class structure-class))
- `(type ,specializer ,parameter)
- ;; don't declare CLOS classes as parameters;
- ;; it's too expensive.
- '(ignorable)))
- (t
- ;; we can get here, and still not have a failure
- ;; case, by doing MOP programming like (PROGN
- ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
- ;; ...)). Best to let the user know we haven't
- ;; been able to extract enough information:
- (style-warn
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- specializer
- 'parameter-specializer-declaration-in-defmethod)
- '(ignorable)))))
- ((:forthcoming-defclass-type) '(ignorable)))))))
-
-(defun make-method-lambda-internal (method-lambda &optional env)
+(unless (fboundp 'make-method-lambda)
+ (setf (gdefinition 'make-method-lambda)
+ (symbol-function 'real-make-method-lambda)))
+
+(defun declared-specials (declarations)
+ (loop for (declare . specifiers) in declarations
+ append (loop for specifier in specifiers
+ when (eq 'special (car specifier))
+ append (cdr specifier))))
+
+(defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
+ (declare (ignore proto-gf proto-method))
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
is not a lambda form."
method-lambda))
(multiple-value-bind (real-body declarations documentation)
(parse-body (cddr method-lambda))
- (let* ((name-decl (get-declaration '%method-name declarations))
- (sll-decl (get-declaration '%method-lambda-list declarations))
- (method-name (when (consp name-decl) (car name-decl)))
+ ;; We have the %METHOD-NAME declaration in the place where we expect it only
+ ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or
+ ;; unless they're fantastically unintrusive.
+ (let* ((method-name *method-name*)
+ (method-lambda-list *method-lambda-list*)
+ ;; Macroexpansion caused by code-walking may call make-method-lambda and
+ ;; end up with wrong values
+ (*method-name* nil)
+ (*method-lambda-list* nil)
(generic-function-name (when method-name (car method-name)))
- (specialized-lambda-list (or sll-decl (cadr method-lambda))))
+ (specialized-lambda-list (or method-lambda-list
+ (ecase (car method-lambda)
+ (lambda (second method-lambda))
+ (named-lambda (third method-lambda)))))
+ ;; the method-cell is a way of communicating what method a
+ ;; method-function implements, for the purpose of
+ ;; NO-NEXT-METHOD. We need something that can be shared
+ ;; between function and initargs, but not something that
+ ;; will be coalesced as a constant (because we are naughty,
+ ;; oh yes) with the expansion of any other methods in the
+ ;; same file. -- CSR, 2007-05-30
+ (method-cell (list (make-symbol "METHOD-CELL"))))
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(let* ((required-parameters
parameters
specializers))
(slots (mapcar #'list required-parameters))
- (calls (list nil))
(class-declarations
`(declare
;; These declarations seem to be used by PCL to pass
;; KLUDGE: when I tried moving these to
;; ADD-METHOD-DECLARATIONS, things broke. No idea
;; why. -- CSR, 2004-06-16
- ,@(mapcar #'parameter-specializer-declaration-in-defmethod
- parameters
- specializers)))
+ ,@(let ((specials (declared-specials declarations)))
+ (mapcar (lambda (par spec)
+ (parameter-specializer-declaration-in-defmethod
+ par spec specials env))
+ parameters
+ specializers))))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
(constant-value-p (and (null (cdr real-body))
(constantp (car real-body))))
(constant-value (and constant-value-p
- (eval (car real-body))))
+ (constant-form-value (car real-body))))
(plist (and constant-value-p
(or (typep constant-value
'(or number character))
(return nil))))))
(multiple-value-bind
(walked-lambda call-next-method-p closurep
- next-method-p-p setq-p)
+ next-method-p-p setq-p
+ parameters-setqd)
(walk-method-lambda method-lambda
required-parameters
env
- slots
- calls)
+ slots)
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
- (when (or next-method-p-p call-next-method-p)
- (setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
- (multiple-value-bind (slot-name-lists call-list)
- (slot-name-lists-from-slots slots calls)
- (let ((pv-table-symbol (make-symbol "pv-table")))
- (setq plist
- `(,@(when slot-name-lists
- `(:slot-name-lists ,slot-name-lists))
- ,@(when call-list
- `(:call-list ,call-list))
- :pv-table-symbol ,pv-table-symbol
- ,@plist))
- (setq walked-lambda-body
- `((pv-binding (,required-parameters
- ,slot-name-lists
- ,pv-table-symbol)
- ,@walked-lambda-body))))))
+ (let ((slot-name-lists (slot-name-lists-from-slots slots)))
+ (setq plist
+ `(,@(when slot-name-lists
+ `(:slot-name-lists ,slot-name-lists))
+ ,@plist))
+ (setq walked-lambda-body
+ `((pv-binding (,required-parameters
+ ,slot-name-lists
+ (load-time-value
+ (intern-pv-table
+ :slot-name-lists ',slot-name-lists)))
+ ,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let ((aux (memq '&aux lambda-list)))
- (setq lambda-list (nconc (ldiff lambda-list aux)
- (list '&allow-other-keys)
- aux))))
+ (setq lambda-list (nconc (ldiff lambda-list aux)
+ (list '&allow-other-keys)
+ aux))))
(values `(lambda (.method-args. .next-methods.)
(simple-lexical-method-functions
- (,lambda-list .method-args. .next-methods.
- :call-next-method-p
- ,call-next-method-p
- :next-method-p-p ,next-method-p-p
- :setq-p ,setq-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
- ,@walked-lambda-body))
- `(,@(when plist
- `(:plist ,plist))
- ,@(when documentation
- `(:documentation ,documentation)))))))))))
+ (,lambda-list .method-args. .next-methods.
+ :call-next-method-p
+ ,(when call-next-method-p t)
+ :next-method-p-p ,next-method-p-p
+ :setq-p ,setq-p
+ :parameters-setqd ,parameters-setqd
+ :method-cell ,method-cell
+ :closurep ,closurep
+ :applyp ,applyp)
+ ,@walked-declarations
+ (locally
+ (declare (disable-package-locks
+ %parameter-binding-modified))
+ (symbol-macrolet ((%parameter-binding-modified
+ ',@parameters-setqd))
+ (declare (enable-package-locks
+ %parameter-binding-modified))
+ ,@walked-lambda-body))))
+ `(,@(when call-next-method-p `(method-cell ,method-cell))
+ ,@(when (member call-next-method-p '(:simple nil))
+ '(simple-next-method-call t))
+ ,@(when plist `(plist ,plist))
+ ,@(when documentation `(:documentation ,documentation)))))))))))
+
+(defun real-make-method-specializers-form
+ (proto-gf proto-method specializer-names env)
+ (declare (ignore env proto-gf proto-method))
+ (flet ((parse (name)
+ (cond
+ ((and (eq **boot-state** 'complete)
+ (specializerp name))
+ name)
+ ((symbolp name) `(find-class ',name))
+ ((consp name) (ecase (car name)
+ ((eql) `(intern-eql-specializer ,(cadr name)))
+ ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))))
+ (t
+ ;; FIXME: Document CLASS-EQ specializers.
+ (error 'simple-reference-error
+ :format-control
+ "~@<~S is not a valid parameter specializer name.~@:>"
+ :format-arguments (list name)
+ :references (list '(:ansi-cl :macro defmethod)
+ '(:ansi-cl :glossary "parameter specializer name")))))))
+ `(list ,@(mapcar #'parse specializer-names))))
+
+(unless (fboundp 'make-method-specializers-form)
+ (setf (gdefinition 'make-method-specializers-form)
+ (symbol-function 'real-make-method-specializers-form)))
+
+(defun real-parse-specializer-using-class (generic-function specializer)
+ (let ((result (specializer-from-type specializer)))
+ (if (specializerp result)
+ result
+ (error "~@<~S cannot be parsed as a specializer for ~S.~@:>"
+ specializer generic-function))))
+
+(unless (fboundp 'parse-specializer-using-class)
+ (setf (gdefinition 'parse-specializer-using-class)
+ (symbol-function 'real-parse-specializer-using-class)))
+
+(defun real-unparse-specializer-using-class (generic-function specializer)
+ (if (specializerp specializer)
+ ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut:
+ ;; the idea is that we want to unparse permissively, so that the
+ ;; lazy (or rather the "portable") specializer extender (who
+ ;; does not define methods on these new SBCL-specific MOP
+ ;; functions) can still subclass specializer and define methods
+ ;; without everything going wrong. Making it cleaner and
+ ;; clearer that that is what we are defending against would be
+ ;; nice. -- CSR, 2007-06-01
+ (handler-case
+ (let ((type (specializer-type specializer)))
+ (if (and (consp type) (eq (car type) 'class))
+ (let* ((class (cadr type))
+ (class-name (class-name class)))
+ (if (eq class (find-class class-name nil))
+ class-name
+ type))
+ type))
+ (error () specializer))
+ (error "~@<~S is not a legal specializer for ~S.~@:>"
+ specializer generic-function)))
+
+(unless (fboundp 'unparse-specializer-using-class)
+ (setf (gdefinition 'unparse-specializer-using-class)
+ (symbol-function 'real-unparse-specializer-using-class)))
-(unless (fboundp 'make-method-lambda)
- (setf (gdefinition 'make-method-lambda)
- (symbol-function 'real-make-method-lambda)))
+;;; a helper function for creating Python-friendly type declarations
+;;; in DEFMETHOD forms.
+;;;
+;;; We're too lazy to cons up a new environment for this, so we just pass in
+;;; the list of locally declared specials in addition to the old environment.
+(defun parameter-specializer-declaration-in-defmethod
+ (parameter specializer specials env)
+ (cond ((and (consp specializer)
+ (eq (car specializer) 'eql))
+ ;; KLUDGE: ANSI, in its wisdom, says that
+ ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
+ ;; DEFMETHOD expansion time. Thus, although one might think
+ ;; that in
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 12))
+ ;; ..))
+ ;; the PACKAGE and (EQL 12) forms are both parallel type
+ ;; names, they're not, as is made clear when you do
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 'BAR)))
+ ;; ..)
+ ;; where Y needs to be a symbol named "BAR", not some cons
+ ;; made by (CONS 'QUOTE 'BAR). I.e. when the
+ ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
+ ;; to be of type (EQL X). It'd be easy to transform one to
+ ;; the other, but it'd be somewhat messier to do so while
+ ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
+ ;; once. (The new code wouldn't be messy, but it'd require a
+ ;; big transformation of the old code.) So instead we punt.
+ ;; -- WHN 20000610
+ '(ignorable))
+ ((member specializer
+ ;; KLUDGE: For some low-level implementation
+ ;; classes, perhaps because of some problems related
+ ;; to the incomplete integration of PCL into SBCL's
+ ;; type system, some specializer classes can't be
+ ;; declared as argument types. E.g.
+ ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
+ ;; (DECLARE (TYPE SLOT-OBJECT X))
+ ;; ..)
+ ;; loses when
+ ;; (DEFSTRUCT BAR A B)
+ ;; (FOO (MAKE-BAR))
+ ;; perhaps because of the way that STRUCTURE-OBJECT
+ ;; inherits both from SLOT-OBJECT and from
+ ;; SB-KERNEL:INSTANCE. In an effort to sweep such
+ ;; problems under the rug, we exclude these problem
+ ;; cases by blacklisting them here. -- WHN 2001-01-19
+ (list 'slot-object #+nil (find-class 'slot-object)))
+ '(ignorable))
+ ((not (eq **boot-state** 'complete))
+ ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
+ ;; types which don't match their specializers. (Specifically,
+ ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
+ ;; second argument.) Hopefully it only does this kind of
+ ;; weirdness when bootstrapping.. -- WHN 20000610
+ '(ignorable))
+ ((typep specializer 'eql-specializer)
+ `(type (eql ,(eql-specializer-object specializer)) ,parameter))
+ ((or (var-special-p parameter env) (member parameter specials))
+ ;; Don't declare types for special variables -- our rebinding magic
+ ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
+ ;; etc. make things undecidable.
+ '(ignorable))
+ (t
+ ;; Otherwise, we can usually make Python very happy.
+ ;;
+ ;; KLUDGE: Since INFO doesn't work right for class objects here,
+ ;; and they are valid specializers, see if the specializer is
+ ;; a named class, and use the name in that case -- otherwise
+ ;; the class instance is ok, since info will just return NIL, NIL.
+ ;;
+ ;; We still need to deal with the class case too, but at
+ ;; least #.(find-class 'integer) and integer as equivalent
+ ;; specializers with this.
+ (let* ((specializer-nameoid
+ (if (and (typep specializer 'class)
+ (let ((name (class-name specializer)))
+ (and name (symbolp name)
+ (eq specializer (find-class name nil)))))
+ (class-name specializer)
+ specializer))
+ (kind (info :type :kind specializer-nameoid)))
+
+ (flet ((specializer-nameoid-class ()
+ (typecase specializer-nameoid
+ (symbol (find-class specializer-nameoid nil))
+ (class specializer-nameoid)
+ (class-eq-specializer
+ (specializer-class specializer-nameoid))
+ (t nil))))
+ (ecase kind
+ ((:primitive) `(type ,specializer-nameoid ,parameter))
+ ((:defined)
+ (let ((class (specializer-nameoid-class)))
+ ;; CLASS can be null here if the user has
+ ;; erroneously tried to use a defined type as a
+ ;; specializer; it can be a non-BUILT-IN-CLASS if
+ ;; the user defines a type and calls (SETF
+ ;; FIND-CLASS) in a consistent way.
+ (when (and class (typep class 'built-in-class))
+ `(type ,(class-name class) ,parameter))))
+ ((:instance nil)
+ (let ((class (specializer-nameoid-class)))
+ (cond
+ (class
+ (if (typep class '(or built-in-class structure-class))
+ `(type ,class ,parameter)
+ ;; don't declare CLOS classes as parameters;
+ ;; it's too expensive.
+ '(ignorable)))
+ (t
+ ;; we can get here, and still not have a failure
+ ;; case, by doing MOP programming like (PROGN
+ ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+ ;; ...)). Best to let the user know we haven't
+ ;; been able to extract enough information:
+ (style-warn
+ "~@<can't find type for specializer ~S in ~S.~@:>"
+ specializer-nameoid
+ 'parameter-specializer-declaration-in-defmethod)
+ '(ignorable)))))
+ ((:forthcoming-defclass-type)
+ '(ignorable))))))))
+
+;;; For passing a list (groveled by the walker) of the required
+;;; parameters whose bindings are modified in the method body to the
+;;; optimized-slot-value* macros.
+(define-symbol-macro %parameter-binding-modified ())
(defmacro simple-lexical-method-functions ((lambda-list
method-args
&body body)
`(progn
,method-args ,next-methods
- (bind-simple-lexical-method-macros (,method-args ,next-methods)
- (bind-lexical-method-functions (,@lmf-options)
+ (bind-simple-lexical-method-functions (,method-args ,next-methods
+ ,lmf-options)
(bind-args (,lambda-list ,method-args)
- ,@body)))))
+ ,@body))))
(defmacro fast-lexical-method-functions ((lambda-list
next-method-call
rest-arg
&rest lmf-options)
&body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
- (bind-lexical-method-functions (,@lmf-options)
- (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
- ,@body))))
-
-(defmacro bind-simple-lexical-method-macros ((method-args next-methods)
- &body body)
- `(macrolet ((call-next-method-bind (&body body)
- `(let ((.next-method. (car ,',next-methods))
- (,',next-methods (cdr ,',next-methods)))
- .next-method. ,',next-methods
- ,@body))
- (check-cnm-args-body (&environment env method-name-declaration cnm-args)
- (if (safe-code-p env)
- `(%check-cnm-args ,cnm-args ,',method-args ',method-name-declaration)
- nil))
- (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)
- (apply #'call-no-next-method ',method-name-declaration
- (or ,cnm-args ,',method-args))))
- (next-method-p-body ()
- `(not (null .next-method.)))
- (with-rebound-original-args ((call-next-method-p setq-p)
- &body body)
- (declare (ignore call-next-method-p setq-p))
- `(let () ,@body)))
- ,@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)))))
+ `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options)
+ (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+ ,@body)))
+
+(defmacro bind-simple-lexical-method-functions
+ ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
+ parameters-setqd closurep applyp method-cell))
+ &body body
+ &environment env)
+ (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
+ `(locally
+ ,@body)
+ `(let ((.next-method. (car ,next-methods))
+ (,next-methods (cdr ,next-methods)))
+ (declare (ignorable .next-method. ,next-methods))
+ (flet (,@(and call-next-method-p
+ `((call-next-method (&rest cnm-args)
+ (declare (dynamic-extent cnm-args))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args
+ ,method-args
+ ',method-cell))
+ nil)
+ (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)
+ (apply #'call-no-next-method
+ ',method-cell
+ (or cnm-args ,method-args))))))
+ ,@(and next-method-p-p
+ '((next-method-p ()
+ (not (null .next-method.))))))
+ ,@body))))
+
+(defun call-no-next-method (method-cell &rest args)
+ (let ((method (car method-cell)))
+ (aver method)
+ ;; Can't easily provide a RETRY restart here, as the return value here is
+ ;; for the method, not the generic function.
+ (apply #'no-next-method (method-generic-function method)
+ method args)))
+
+(defun call-no-applicable-method (gf args)
+ (restart-case
+ (apply #'no-applicable-method gf args)
+ (retry ()
+ :report "Retry calling the generic function."
+ (apply gf args))))
+
+(defun call-no-primary-method (gf args)
+ (restart-case
+ (apply #'no-primary-method gf args)
+ (retry ()
+ :report "Retry calling the generic function."
+ (apply gf args))))
(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
+(defstruct (constant-method-call (:copier nil) (:include method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type method-call))
(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
- pv-cell
+ pv
next-method-call
arg-info)
+(defstruct (constant-fast-method-call
+ (:copier nil) (:include fast-method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
-(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
- `(funcall ,fn ,pv-cell ,next-method-call ,@args))
-
-(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
- `(fmc-funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
- (fast-method-call-next-method-call ,method-call)
- ,@required-args+rest-arg))
+;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs
+;; are handled. The first one will get REST-ARG as a single list (as
+;; the last argument), and will thus need to use APPLY. The second one
+;; will get them as a &MORE argument, so we can pass the arguments
+;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES.
+
+(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
+ `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
+ (fast-method-call-pv ,method-call)
+ (fast-method-call-next-method-call ,method-call)
+ ,@required-args+rest-arg))
+
+(defmacro invoke-fast-method-call/more (method-call
+ more-context
+ more-count
+ &rest required-args)
+ (macrolet ((generate-call (n)
+ ``(funcall (fast-method-call-function ,method-call)
+ (fast-method-call-pv ,method-call)
+ (fast-method-call-next-method-call ,method-call)
+ ,@required-args
+ ,@(loop for x below ,n
+ collect `(sb-c::%more-arg ,more-context ,x)))))
+ ;; The cases with only small amounts of required arguments passed
+ ;; are probably very common, and special-casing speeds them up by
+ ;; a factor of 2 with very little effect on the other
+ ;; cases. Though it'd be nice to have the generic case be equally
+ ;; fast.
+ `(case ,more-count
+ (0 ,(generate-call 0))
+ (1 ,(generate-call 1))
+ (t (multiple-value-call (fast-method-call-function ,method-call)
+ (values (fast-method-call-pv ,method-call))
+ (values (fast-method-call-next-method-call ,method-call))
+ ,@required-args
+ (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
(defstruct (fast-instance-boundp (:copier nil))
(index 0 :type fixnum))
(trace-emf-call-internal ,emf ,format ,args))))
(defmacro invoke-effective-method-function-fast
- (emf restp &rest required-args+rest-arg)
- `(progn
- (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
- (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
-
-(defmacro invoke-effective-method-function (emf restp
- &rest required-args+rest-arg)
- (unless (constantp restp)
- (error "The RESTP argument is not constant."))
- ;; FIXME: The RESTP handling here is confusing and maybe slightly
- ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
- ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
- ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
- (setq restp (eval restp))
+ (emf restp &key required-args rest-arg more-arg)
`(progn
- (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
- (cond ((typep ,emf 'fast-method-call)
- (invoke-fast-method-call ,emf ,@required-args+rest-arg))
- ;; "What," you may wonder, "do these next two clauses do?"
- ;; In that case, you are not a PCL implementor, for they
- ;; considered this to be self-documenting.:-| Or CSR, for
- ;; that matter, since he can also figure it out by looking
- ;; at it without breaking stride. For the rest of us,
- ;; though: From what the code is doing with .SLOTS. and
- ;; whatnot, evidently it's implementing SLOT-VALUEish and
- ;; GET-SLOT-VALUEish things. Then we can reason backwards
- ;; and conclude that setting EMF to a FIXNUM is an
- ;; optimized way to represent these slot access operations.
- ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let* ((.slots. (get-slots-or-nil
- ,(car required-args+rest-arg)))
- (value (when .slots. (clos-slots-ref .slots. ,emf))))
- (if (eq value +slot-unbound+)
- (slot-unbound-internal ,(car required-args+rest-arg)
- ,emf)
- value)))))
- ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let ((.new-value. ,(car required-args+rest-arg))
- (.slots. (get-slots-or-nil
- ,(cadr required-args+rest-arg))))
- (when .slots.
- (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
- ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
- ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
- ;; there was no explanation and presumably the code is 10+
- ;; years stale, I simply deleted it. -- WHN)
- (t
- (etypecase ,emf
- (method-call
- (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
- (function
- ,(if restp
- `(apply (the function ,emf) ,@required-args+rest-arg)
- `(funcall (the function ,emf)
- ,@required-args+rest-arg))))))))
+ (trace-emf-call ,emf ,restp (list ,@required-args rest-arg))
+ ,(if more-arg
+ `(invoke-fast-method-call/more ,emf
+ ,@more-arg
+ ,@required-args)
+ `(invoke-fast-method-call ,emf
+ ,restp
+ ,@required-args
+ ,@rest-arg))))
+
+(defun effective-method-optimized-slot-access-clause
+ (emf restp required-args)
+ ;; "What," you may wonder, "do these next two clauses do?" In that
+ ;; case, you are not a PCL implementor, for they considered this to
+ ;; be self-documenting.:-| Or CSR, for that matter, since he can
+ ;; also figure it out by looking at it without breaking stride. For
+ ;; the rest of us, though: From what the code is doing with .SLOTS.
+ ;; and whatnot, evidently it's implementing SLOT-VALUEish and
+ ;; GET-SLOT-VALUEish things. Then we can reason backwards and
+ ;; conclude that setting EMF to a FIXNUM is an optimized way to
+ ;; represent these slot access operations.
+ (when (not restp)
+ (let ((length (length required-args)))
+ (cond ((= 1 length)
+ `((fixnum
+ (let* ((.slots. (get-slots-or-nil
+ ,(car required-args)))
+ (value (when .slots. (clos-slots-ref .slots. ,emf))))
+ (if (eq value +slot-unbound+)
+ (slot-unbound-internal ,(car required-args)
+ ,emf)
+ value)))))
+ ((= 2 length)
+ `((fixnum
+ (let ((.new-value. ,(car required-args))
+ (.slots. (get-slots-or-nil
+ ,(cadr required-args))))
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
+ ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+ ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+ ;; there was no explanation and presumably the code is 10+
+ ;; years stale, I simply deleted it. -- WHN)
+ )))
+
+;;; Before SBCL 0.9.16.7 instead of
+;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
+;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
+;;; to make less work for the compiler we take a path that doesn't
+;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all.
+(macrolet ((def (name &optional narrow)
+ `(defmacro ,name (emf restp &key required-args rest-arg more-arg)
+ (unless (constantp restp)
+ (error "The RESTP argument is not constant."))
+ (setq restp (constant-form-value restp))
+ (with-unique-names (emf-n)
+ `(locally
+ (declare (optimize (sb-c:insert-step-conditions 0)))
+ (let ((,emf-n ,emf))
+ (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg))
+ (etypecase ,emf-n
+ (fast-method-call
+ ,(if more-arg
+ `(invoke-fast-method-call/more ,emf-n
+ ,@more-arg
+ ,@required-args)
+ `(invoke-fast-method-call ,emf-n
+ ,restp
+ ,@required-args
+ ,@rest-arg)))
+ ,@,(unless narrow
+ `(effective-method-optimized-slot-access-clause
+ emf-n restp required-args))
+ (method-call
+ (invoke-method-call ,emf-n ,restp ,@required-args
+ ,@rest-arg))
+ (function
+ ,(if restp
+ `(apply ,emf-n ,@required-args ,@rest-arg)
+ `(funcall ,emf-n ,@required-args
+ ,@rest-arg))))))))))
+ (def invoke-effective-method-function nil)
+ (def invoke-narrow-effective-method-function t))
(defun invoke-emf (emf args)
(trace-emf-call emf t args)
(restp (cdr arg-info))
(nreq (car arg-info)))
(if restp
- (let* ((rest-args (nthcdr nreq args))
- (req-args (ldiff args rest-args)))
- (apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
- (fast-method-call-next-method-call emf)
- (nconc req-args (list rest-args))))
+ (apply (fast-method-call-function emf)
+ (fast-method-call-pv emf)
+ (fast-method-call-next-method-call emf)
+ args)
(cond ((null args)
(if (eql nreq 0)
- (invoke-fast-method-call emf)
+ (invoke-fast-method-call emf nil)
(error 'simple-program-error
:format-control "invalid number of arguments: 0"
:format-arguments nil)))
((null (cdr args))
(if (eql nreq 1)
- (invoke-fast-method-call emf (car args))
+ (invoke-fast-method-call emf nil (car args))
(error 'simple-program-error
:format-control "invalid number of arguments: 1"
:format-arguments nil)))
((null (cddr args))
(if (eql nreq 2)
- (invoke-fast-method-call emf (car args) (cadr args))
+ (invoke-fast-method-call emf nil (car args) (cadr args))
(error 'simple-program-error
:format-control "invalid number of arguments: 2"
:format-arguments nil)))
(t
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args))))))
(method-call
(function
(apply emf args))))
\f
-(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
- &body body
- &environment env)
- (let* ((all-params (append args (when rest-arg (list rest-arg))))
- (rebindings (mapcar (lambda (x) (list x x)) all-params)))
- `(macrolet ((narrowed-emf (emf)
- ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
- ;; dispatch on the possibility that EMF might be of
- ;; type FIXNUM (as an optimized representation of a
- ;; slot accessor). But as far as I (WHN 2002-06-11)
- ;; can tell, it's impossible for such a representation
- ;; to end up as .NEXT-METHOD-CALL. By reassuring
- ;; INVOKE-E-M-F that when called from this context
- ;; it needn't worry about the FIXNUM case, we can
- ;; keep those cases from being compiled, which is
- ;; good both because it saves bytes and because it
- ;; avoids annoying type mismatch compiler warnings.
- ;;
- ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
- ;; system isn't smart enough about NOT and
- ;; intersection types to benefit from a (NOT FIXNUM)
- ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe
- ;; it is now... -- CSR, 2003-06-07)
- ;;
- ;; FIXME: Might the FUNCTION type be omittable here,
- ;; leaving only METHOD-CALLs? Failing that, could this
- ;; be documented somehow? (It'd be nice if the types
- ;; involved could be understood without solving the
- ;; halting problem.)
- `(the (or function method-call fast-method-call)
- ,emf))
- (call-next-method-bind (&body body)
- `(let () ,@body))
- (check-cnm-args-body (&environment env method-name-declaration cnm-args)
- (if (safe-code-p env)
- `(%check-cnm-args ,cnm-args (list ,@',args)
- ',method-name-declaration)
- nil))
- (call-next-method-body (method-name-declaration cnm-args)
- `(if ,',next-method-call
- ,(locally
- ;; This declaration suppresses a "deleting
- ;; unreachable code" note for the following IF
- ;; when REST-ARG is NIL. It is not nice for
- ;; debugging SBCL itself, but at least it
- ;; keeps us from annoying users.
- (declare (optimize (inhibit-warnings 3)))
- (if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- nil
- ,@(cdr cnm-args))
- (let ((call `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- ,',(not (null rest-arg))
- ,@',args
- ,@',(when rest-arg `(,rest-arg)))))
- `(if ,cnm-args
- (bind-args ((,@',args
- ,@',(when rest-arg
- `(&rest ,rest-arg)))
- ,cnm-args)
- ,call)
- ,call))))
- ,(locally
- ;; As above, this declaration suppresses code
- ;; deletion notes.
- (declare (optimize (inhibit-warnings 3)))
- (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)))
- (with-rebound-original-args ((cnm-p setq-p) &body body)
- (if (or cnm-p setq-p)
- `(let ,',rebindings
- (declare (ignorable ,@',all-params))
- ,@body)
- `(let () ,@body))))
- ,@body)))
-
-(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p setq-p
- closurep applyp method-name-declaration)
- &body body)
- (cond ((and (null call-next-method-p) (null next-method-p-p)
- (null closurep) (null applyp) (null setq-p))
- `(let () ,@body))
- (t
- `(call-next-method-bind
- (flet (,@(and call-next-method-p
- `((call-next-method (&rest cnm-args)
- (check-cnm-args-body ,method-name-declaration cnm-args)
- (call-next-method-body ,method-name-declaration cnm-args))))
- ,@(and next-method-p-p
- '((next-method-p ()
- (next-method-p-body)))))
- (with-rebound-original-args (,call-next-method-p ,setq-p)
- ,@body))))))
+
+(defmacro fast-call-next-method-body ((args next-method-call rest-arg)
+ method-cell
+ cnm-args)
+ `(if ,next-method-call
+ ,(let ((call `(invoke-narrow-effective-method-function
+ ,next-method-call
+ ,(not (null rest-arg))
+ :required-args ,args
+ :rest-arg ,(when rest-arg (list rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@args
+ ,@(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call))
+ (call-no-next-method ',method-cell
+ ,@args
+ ,@(when rest-arg
+ `(,rest-arg)))))
+
+(defmacro bind-fast-lexical-method-functions
+ ((args rest-arg next-method-call (&key
+ call-next-method-p
+ setq-p
+ parameters-setqd
+ method-cell
+ next-method-p-p
+ closurep
+ applyp))
+ &body body
+ &environment env)
+ (let* ((rebindings (when (or setq-p call-next-method-p)
+ (mapcar (lambda (x) (list x x)) parameters-setqd))))
+ (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
+ `(locally
+ ,@body)
+ `(flet (,@(when call-next-method-p
+ `((call-next-method (&rest cnm-args)
+ (declare (dynamic-extent cnm-args)
+ (muffle-conditions code-deletion-note)
+ (optimize (sb-c:insert-step-conditions 0)))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args (list ,@args)
+ ',method-cell))
+ nil)
+ (fast-call-next-method-body (,args
+ ,next-method-call
+ ,rest-arg)
+ ,method-cell
+ cnm-args))))
+ ,@(when next-method-p-p
+ `((next-method-p ()
+ (declare (optimize (sb-c:insert-step-conditions 0)))
+ (not (null ,next-method-call))))))
+ (let ,rebindings
+ ,@body)))))
;;; CMUCL comment (Gerd Moellmann):
;;;
;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such
;;; preconditions. That looks hairy and is probably not worth it,
;;; because this check will never be fast.
-(defun %check-cnm-args (cnm-args orig-args method-name-declaration)
+(defun %check-cnm-args (cnm-args orig-args method-cell)
+ ;; 1. Check for no arguments.
(when cnm-args
- (let* ((gf (fdefinition (caar method-name-declaration)))
- (omethods (compute-applicable-methods gf orig-args))
- (nmethods (compute-applicable-methods gf cnm-args)))
- (unless (equal omethods nmethods)
- (error "~@<The set of methods ~S applicable to argument~P ~
- ~{~S~^, ~} to call-next-method is different from ~
- the set of methods ~S applicable to the original ~
- method argument~P ~{~S~^, ~}.~@:>"
- nmethods (length cnm-args) cnm-args omethods
- (length orig-args) orig-args)))))
+ (let* ((gf (method-generic-function (car method-cell)))
+ (nreq (generic-function-nreq gf)))
+ (declare (fixnum nreq))
+ ;; 2. Requirement arguments pairwise: if all are EQL, the applicable
+ ;; methods must be the same. This takes care of the relatively common
+ ;; case of twiddling with &KEY arguments without being horribly
+ ;; expensive.
+ (unless (do ((orig orig-args (cdr orig))
+ (args cnm-args (cdr args))
+ (n nreq (1- nreq)))
+ ((zerop n) t)
+ (unless (and orig args (eql (car orig) (car args)))
+ (return nil)))
+ ;; 3. Only then do the full check.
+ (let ((omethods (compute-applicable-methods gf orig-args))
+ (nmethods (compute-applicable-methods gf cnm-args)))
+ (unless (equal omethods nmethods)
+ (error "~@<The set of methods ~S applicable to argument~P ~
+ ~{~S~^, ~} to call-next-method is different from ~
+ the set of methods ~S applicable to the original ~
+ method argument~P ~{~S~^, ~}.~@:>"
+ nmethods (length cnm-args) cnm-args omethods
+ (length orig-args) orig-args)))))))
(defmacro bind-args ((lambda-list args) &body body)
(let ((args-tail '.args-tail.)
(pop ,args-tail)
,(cadr var)))))
(t
- `((,(caddr var) ,args-tail)
+ `((,(caddr var) (not (null ,args-tail)))
(,(car var) (if ,args-tail
(pop ,args-tail)
,(cadr var)))))))
(car var)))
`((,key (get-key-arg-tail ',keyword
,args-tail))
- (,(caddr var) ,key)
+ (,(caddr var) (not (null,key)))
(,variable (if ,key
(car ,key)
,(cadr var))))))))
when (eq key keyword)
return tail))
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
- (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD
- ; should be in the method definition
- (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD
- ; was seen in the body of a method
- (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P
- ; should be in the method definition
- (setq-p nil))
+(defun walk-method-lambda (method-lambda required-parameters env slots)
+ (let (;; flag indicating that CALL-NEXT-METHOD should be in the
+ ;; method definition
+ (call-next-method-p nil)
+ ;; flag indicating that #'CALL-NEXT-METHOD was seen in the
+ ;; body of a method
+ (closurep nil)
+ ;; flag indicating that NEXT-METHOD-P should be in the method
+ ;; definition
+ (next-method-p-p nil)
+ ;; a list of all required parameters whose bindings might be
+ ;; modified in the method body.
+ (parameters-setqd nil))
(flet ((walk-function (form context env)
(cond ((not (eq context :eval)) form)
;; FIXME: Jumping to a conclusion from the way it's used
;; like :LOAD-TOPLEVEL.
((not (listp form)) form)
((eq (car form) 'call-next-method)
- (setq call-next-method-p t)
+ (setq call-next-method-p (if (cdr form)
+ t
+ :simple))
form)
((eq (car form) 'next-method-p)
(setq next-method-p-p t)
form)
((memq (car form) '(setq multiple-value-setq))
- ;; FIXME: this is possibly a little strong as
- ;; conditions go. Ideally we would want to detect
- ;; which, if any, of the method parameters are
- ;; being set, and communicate that information to
- ;; e.g. SPLIT-DECLARATIONS. However, the brute
- ;; force method doesn't really cost much; a little
- ;; loss of discrimination over IGNORED variables
- ;; should be all. -- CSR, 2004-07-01
- (setq setq-p t)
+ ;; The walker will split (SETQ A 1 B 2) to
+ ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
+ ;; only need to handle the simple case of SETQ
+ ;; here.
+ (let ((vars (if (eq (car form) 'setq)
+ (list (second form))
+ (second form))))
+ (dolist (var vars)
+ ;; Note that we don't need to check for
+ ;; %VARIABLE-REBINDING declarations like is
+ ;; done in CAN-OPTIMIZE-ACCESS1, since the
+ ;; bindings that will have that declation will
+ ;; never be SETQd.
+ (when (var-declaration '%class var env)
+ ;; If a parameter binding is shadowed by
+ ;; another binding it won't have a %CLASS
+ ;; declaration anymore, and this won't get
+ ;; executed.
+ (pushnew var parameters-setqd :test #'eq))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(t nil))))
((and (memq (car form)
'(slot-value set-slot-value slot-boundp))
- (constantp (caddr form)))
- (let ((parameter (can-optimize-access form
- required-parameters
- env)))
- (let ((fun (ecase (car form)
- (slot-value #'optimize-slot-value)
- (set-slot-value #'optimize-set-slot-value)
- (slot-boundp #'optimize-slot-boundp))))
- (funcall fun slots parameter form))))
- ((and (eq (car form) 'apply)
- (consp (cadr form))
- (eq (car (cadr form)) 'function)
- (generic-function-name-p (cadr (cadr form))))
- (optimize-generic-function-call
- form required-parameters env slots calls))
- ((generic-function-name-p (car form))
- (optimize-generic-function-call
- form required-parameters env slots calls))
+ (constantp (caddr form) env))
+ (let ((fun (ecase (car form)
+ (slot-value #'optimize-slot-value)
+ (set-slot-value #'optimize-set-slot-value)
+ (slot-boundp #'optimize-slot-boundp))))
+ (funcall fun form slots required-parameters env)))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
- (values walked-lambda
+ ;;; FIXME: the walker's rewriting of the source code causes
+ ;;; trouble when doing code coverage. The rewrites should be
+ ;;; removed, and the same operations done using
+ ;;; compiler-macros or tranforms.
+ (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
+ walked-lambda
+ method-lambda)
call-next-method-p
closurep
next-method-p-p
- setq-p)))))
+ (not (null parameters-setqd))
+ parameters-setqd)))))
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
- (gboundp name)
- (if (eq *boot-state* 'complete)
+ (fboundp name)
+ (if (eq **boot-state** 'complete)
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
-(defvar *method-function-plist* (make-hash-table :test 'eq))
-(defvar *mf1* nil)
-(defvar *mf1p* nil)
-(defvar *mf1cp* nil)
-(defvar *mf2* nil)
-(defvar *mf2p* nil)
-(defvar *mf2cp* nil)
-
-(defun method-function-plist (method-function)
- (unless (eq method-function *mf1*)
- (rotatef *mf1* *mf2*)
- (rotatef *mf1p* *mf2p*)
- (rotatef *mf1cp* *mf2cp*))
- (unless (or (eq method-function *mf1*) (null *mf1cp*))
- (setf (gethash *mf1* *method-function-plist*) *mf1p*))
- (unless (eq method-function *mf1*)
- (setf *mf1* method-function
- *mf1cp* nil
- *mf1p* (gethash method-function *method-function-plist*)))
- *mf1p*)
-
-(defun (setf method-function-plist)
- (val method-function)
- (unless (eq method-function *mf1*)
- (rotatef *mf1* *mf2*)
- (rotatef *mf1cp* *mf2cp*)
- (rotatef *mf1p* *mf2p*))
- (unless (or (eq method-function *mf1*) (null *mf1cp*))
- (setf (gethash *mf1* *method-function-plist*) *mf1p*))
- (setf *mf1* method-function
- *mf1cp* t
- *mf1p* val))
-
-(defun method-function-get (method-function key &optional default)
- (getf (method-function-plist method-function) key default))
-
-(defun (setf method-function-get)
- (val method-function key)
- (setf (getf (method-function-plist method-function) key) val))
-
-(defun method-function-pv-table (method-function)
- (method-function-get method-function :pv-table))
-
-(defun method-function-method (method-function)
- (method-function-get method-function :method))
-
-(defun method-function-needs-next-methods-p (method-function)
- (method-function-get method-function :needs-next-methods-p t))
+(defun method-plist-value (method key &optional default)
+ (let ((plist (if (consp method)
+ (getf (early-method-initargs method) 'plist)
+ (object-plist method))))
+ (getf plist key default)))
+
+(defun (setf method-plist-value) (new-value method key &optional default)
+ (if (consp method)
+ (setf (getf (getf (early-method-initargs method) 'plist) key default)
+ new-value)
+ (setf (getf (object-plist method) key default) new-value)))
\f
-(defmacro method-function-closure-generator (method-function)
- `(method-function-get ,method-function 'closure-generator))
-
-(defun load-defmethod
- (class name quals specls ll initargs &optional pv-table-symbol)
- (setq initargs (copy-tree initargs))
- (let ((method-spec (or (getf initargs :method-spec)
- (make-method-spec name quals specls))))
- (setf (getf initargs :method-spec) method-spec)
+(defun load-defmethod (class name quals specls ll initargs source-location)
+ (let ((method-cell (getf initargs 'method-cell)))
+ (setq initargs (copy-tree initargs))
+ (when method-cell
+ (setf (getf initargs 'method-cell) method-cell))
+ #+nil
+ (setf (getf (getf initargs 'plist) :name)
+ (make-method-spec name quals specls))
(load-defmethod-internal class name quals specls
- ll initargs pv-table-symbol)))
+ ll initargs source-location)))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
- initargs pv-table-symbol)
- (when pv-table-symbol
- (setf (getf (getf initargs :plist) :pv-table-symbol)
- pv-table-symbol))
- (when (and (eq *boot-state* 'complete)
+ initargs source-location)
+ (when (and (eq **boot-state** 'complete)
(fboundp gf-spec))
(let* ((gf (fdefinition gf-spec))
(method (and (generic-function-p gf)
(generic-function-methods gf)
- (find-method gf
- qualifiers
- (parse-specializers specializers)
- nil))))
+ (find-method gf qualifiers specializers nil))))
(when method
- (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (warn 'sb-kernel:redefinition-with-defmethod
+ :name gf-spec
+ :new-location source-location
+ :old-method method
+ :qualifiers qualifiers :specializers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
- :definition-source `((defmethod ,gf-spec
- ,@qualifiers
- ,specializers)
- ,*load-pathname*)
+ :definition-source source-location
initargs)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
method-class (class-name (class-of method))))
method))
-(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
- `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
+(defun make-method-spec (gf qualifiers specializers)
+ (let ((name (generic-function-name gf))
+ (unparsed-specializers (unparse-specializers gf specializers)))
+ `(slow-method ,name ,@qualifiers ,unparsed-specializers)))
-(defun initialize-method-function (initargs &optional return-function-p method)
+(defun initialize-method-function (initargs method)
(let* ((mf (getf initargs :function))
- (method-spec (getf initargs :method-spec))
- (plist (getf initargs :plist))
- (pv-table-symbol (getf plist :pv-table-symbol))
- (pv-table nil)
- (mff (getf initargs :fast-function)))
- (flet ((set-mf-property (p v)
- (when mf
- (setf (method-function-get mf p) v))
- (when mff
- (setf (method-function-get mff p) v))))
- (when method-spec
- (when mf
- (setq mf (set-fun-name mf method-spec)))
- (when mff
- (let ((name `(fast-method ,@(cdr method-spec))))
- (set-fun-name mff name)
- (unless mf
- (set-mf-property :name name)))))
- (when plist
- (let ((snl (getf plist :slot-name-lists))
- (cl (getf plist :call-list)))
- (when (or snl cl)
- (setq pv-table (intern-pv-table :slot-name-lists snl
- :call-list cl))
- (when pv-table (set pv-table-symbol pv-table))
- (set-mf-property :pv-table pv-table)))
- (loop (when (null plist) (return nil))
- (set-mf-property (pop plist) (pop plist)))
- (when method
- (set-mf-property :method method))
- (when return-function-p
- (or mf (method-function-from-fast-function mff)))))))
+ (mff (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+ (plist (getf initargs 'plist))
+ (name (getf plist :name))
+ (method-cell (getf initargs 'method-cell)))
+ (when method-cell
+ (setf (car method-cell) method))
+ (when name
+ (when mf
+ (setq mf (set-fun-name mf name)))
+ (when (and mff (consp name) (eq (car name) 'slow-method))
+ (let ((fast-name `(fast-method ,@(cdr name))))
+ (set-fun-name mff fast-name))))
+ (when plist
+ (let ((plist plist))
+ (let ((snl (getf plist :slot-name-lists)))
+ (when snl
+ (setf (method-plist-value method :pv-table)
+ (intern-pv-table :slot-name-lists snl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
(when (or allow-other-keys-p old-allowp)
'(&allow-other-keys)))))
*))))
-
-(defun defgeneric-declaration (spec lambda-list)
- `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(defun ensure-generic-function (fun-name
&rest all-keys
- &key environment
+ &key environment definition-source
&allow-other-keys)
(declare (ignore environment))
- (let ((existing (and (gboundp fun-name)
+ (let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
- (if (and existing
- (eq *boot-state* 'complete)
- (null (generic-function-p existing)))
- (generic-clobbers-function fun-name)
- (apply #'ensure-generic-function-using-class
- existing fun-name all-keys))))
+ (cond ((and existing
+ (eq **boot-state** 'complete)
+ (null (generic-function-p existing)))
+ (generic-clobbers-function fun-name)
+ (fmakunbound fun-name)
+ (apply #'ensure-generic-function fun-name all-keys))
+ (t
+ (apply #'ensure-generic-function-using-class
+ existing fun-name all-keys)))))
(defun generic-clobbers-function (fun-name)
- (error 'simple-program-error
- :format-control "~S already names an ordinary function or a macro."
- :format-arguments (list fun-name)))
+ (cerror "Replace the function binding"
+ 'simple-program-error
+ :format-control "~S already names an ordinary function or a macro."
+ :format-arguments (list fun-name)))
(defvar *sgf-wrapper*
- (boot-make-wrapper (early-class-size 'standard-generic-function)
- 'standard-generic-function))
+ (!boot-make-wrapper (early-class-size 'standard-generic-function)
+ 'standard-generic-function))
(defvar *sgf-slots-init*
(mapcar (lambda (canonical-slot)
+slot-unbound+))))
(early-collect-inheritance 'standard-generic-function)))
-(defvar *sgf-method-class-index*
+(defconstant +sgf-method-class-index+
(!bootstrap-slot-index 'standard-generic-function 'method-class))
(defun early-gf-p (x)
(and (fsc-instance-p x)
- (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+ (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+)
+slot-unbound+)))
-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+
(!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
- `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+ `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+))
-(defvar *sgf-arg-info-index*
+(defun safe-generic-function-methods (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (get-slots generic-function) +sgf-methods-index+)
+ (generic-function-methods generic-function)))
+
+(defconstant +sgf-arg-info-index+
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
(defmacro early-gf-arg-info (gf)
- `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
+ `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+))
-(defvar *sgf-dfun-state-index*
+(defconstant +sgf-dfun-state-index+
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
argument-precedence-order)
- (let* ((arg-info (if (eq *boot-state* 'complete)
+ (let* ((arg-info (if (eq **boot-state** 'complete)
(gf-arg-info gf)
(early-gf-arg-info gf)))
- (methods (if (eq *boot-state* 'complete)
+ (methods (if (eq **boot-state** 'complete)
(generic-function-methods gf)
(early-gf-methods gf)))
(was-valid-p (integerp (arg-info-number-optional arg-info)))
~S."
gf-keywords)))))))
+(defconstant +sm-specializers-index+
+ (!bootstrap-slot-index 'standard-method 'specializers))
+(defconstant +sm-%function-index+
+ (!bootstrap-slot-index 'standard-method '%function))
+(defconstant +sm-qualifiers-index+
+ (!bootstrap-slot-index 'standard-method 'qualifiers))
+
+;;; FIXME: we don't actually need this; we could test for the exact
+;;; class and deal with it as appropriate. In fact we probably don't
+;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
+;;; the standard reader method for METHOD-SPECIALIZERS. Probably.
+(dolist (s '(specializers %function))
+ (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s)))
+ (!bootstrap-slot-index 'standard-reader-method s)
+ (!bootstrap-slot-index 'standard-writer-method s)
+ (!bootstrap-slot-index 'standard-boundp-method s)
+ (!bootstrap-slot-index 'global-reader-method s)
+ (!bootstrap-slot-index 'global-writer-method s)
+ (!bootstrap-slot-index 'global-boundp-method s))))
+
+(defvar *standard-method-class-names*
+ '(standard-method standard-reader-method
+ standard-writer-method standard-boundp-method
+ global-reader-method global-writer-method
+ global-boundp-method))
+
+(declaim (list **standard-method-classes**))
+(defglobal **standard-method-classes** nil)
+
+(defun safe-method-specializers (method)
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-specializers-index+)
+ (method-specializers method)))
+(defun safe-method-fast-function (method)
+ (let ((mf (safe-method-function method)))
+ (and (typep mf '%method-function)
+ (%method-function-fast-function mf))))
+(defun safe-method-function (method)
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-%function-index+)
+ (method-function method)))
+(defun safe-method-qualifiers (method)
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+)
+ (method-qualifiers method)))
+
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(let* ((existing-p (and methods (cdr methods) new-method))
(nreq (length (arg-info-metatypes arg-info)))
nil)))
(when (arg-info-valid-p arg-info)
(dolist (method (if new-method (list new-method) methods))
- (let* ((specializers (if (or (eq *boot-state* 'complete)
+ (let* ((specializers (if (or (eq **boot-state** 'complete)
(not (consp method)))
- (method-specializers method)
+ (safe-method-specializers method)
(early-method-specializers method t)))
- (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+ (class (if (or (eq **boot-state** 'complete) (not (consp method)))
(class-of method)
(early-method-class method)))
- (new-type (when (and class
- (or (not (eq *boot-state* 'complete))
- (eq (generic-function-method-combination gf)
- *standard-method-combination*)))
- (cond ((eq class *the-class-standard-reader-method*)
- 'reader)
- ((eq class *the-class-standard-writer-method*)
- 'writer)
- ((eq class *the-class-standard-boundp-method*)
- 'boundp)))))
+ (new-type
+ (when (and class
+ (or (not (eq **boot-state** 'complete))
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*)))
+ (cond ((or (eq class *the-class-standard-reader-method*)
+ (eq class *the-class-global-reader-method*))
+ 'reader)
+ ((or (eq class *the-class-standard-writer-method*)
+ (eq class *the-class-global-writer-method*))
+ 'writer)
+ ((or (eq class *the-class-standard-boundp-method*)
+ (eq class *the-class-global-boundp-method*))
+ 'boundp)))))
(setq metatypes (mapcar #'raise-metatype metatypes specializers))
(setq type (cond ((null type) new-type)
((eq type new-type) type)
(unless (gf-info-c-a-m-emf-std-p arg-info)
(setf (gf-info-simple-accessor-type arg-info) t))))
(unless was-valid-p
- (let ((name (if (eq *boot-state* 'complete)
+ (let ((name (if (eq **boot-state** 'complete)
(generic-function-name gf)
(!early-gf-name gf))))
(setf (gf-precompute-dfun-and-emf-p arg-info)
(package (symbol-package symbol)))
(and (or (eq package *pcl-package*)
(memq package (package-use-list *pcl-package*)))
+ (not (eq package #.(find-package "CL")))
;; FIXME: this test will eventually be
;; superseded by the *internal-pcl...* test,
;; above. While we are in a process of
;; remain.
(not (find #\Space (symbol-name symbol))))))))))
(setf (gf-info-fast-mf-p arg-info)
- (or (not (eq *boot-state* 'complete))
+ (or (not (eq **boot-state** 'complete))
(let* ((method-class (generic-function-method-class gf))
(methods (compute-applicable-methods
#'make-method-lambda
&key (lambda-list nil
lambda-list-p)
argument-precedence-order
+ definition-source
+ documentation
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing
- argument-precedence-order)
- (error "The function ~S is not already defined." spec)))
+ argument-precedence-order definition-source
+ documentation)
+ (bug "The function ~S is not already defined." spec)))
(existing
- (error "~S should be on the list ~S."
- spec
- '*!generic-function-fixups*))
+ (bug "~S should be on the list ~S."
+ spec '*!generic-function-fixups*))
(t
(pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p nil
- argument-precedence-order))))
+ argument-precedence-order definition-source
+ documentation))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order)
- (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
+ function argument-precedence-order source-location
+ documentation)
+ (let ((fin (allocate-standard-funcallable-instance
+ *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
fin
(or function
has not been set." fin)))))
(setf (gdefinition spec) fin)
(!bootstrap-set-slot 'standard-generic-function fin 'name spec)
- (!bootstrap-set-slot 'standard-generic-function
- fin
- 'source
- *load-pathname*)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ 'source source-location)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ '%documentation documentation)
(set-fun-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(when lambda-list-p
- (proclaim (defgeneric-declaration spec lambda-list))
+ (setf (info :function :type spec)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list spec))
+ (info :function :where-from spec) :defined-method)
(if argument-precedence-order
(set-arg-info fin
:lambda-list lambda-list
(set-arg-info fin :lambda-list lambda-list))))
fin))
+(defun safe-gf-dfun-state (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+)
+ (gf-dfun-state generic-function)))
+(defun (setf safe-gf-dfun-state) (new-value generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (setf (clos-slots-ref (fsc-instance-slots generic-function)
+ +sgf-dfun-state-index+)
+ new-value)
+ (setf (gf-dfun-state generic-function) new-value)))
+
(defun set-dfun (gf &optional dfun cache info)
- (when cache
- (setf (cache-owner cache) gf))
(let ((new-state (if (and dfun (or cache info))
(list* dfun cache info)
dfun)))
- (if (eq *boot-state* 'complete)
- (setf (gf-dfun-state gf) new-state)
- (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
- new-state)))
+ (cond
+ ((eq **boot-state** 'complete)
+ ;; Check that we are under the lock.
+ #+sb-thread
+ (aver (eq sb-thread:*current-thread* (sb-thread:mutex-owner (gf-lock gf))))
+ (setf (safe-gf-dfun-state gf) new-state))
+ (t
+ (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)
+ new-state))))
dfun)
(defun gf-dfun-cache (gf)
- (let ((state (if (eq *boot-state* 'complete)
- (gf-dfun-state gf)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (let ((state (if (eq **boot-state** 'complete)
+ (safe-gf-dfun-state gf)
+ (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
(typecase state
(function nil)
(cons (cadr state)))))
(defun gf-dfun-info (gf)
- (let ((state (if (eq *boot-state* 'complete)
- (gf-dfun-state gf)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (let ((state (if (eq **boot-state** 'complete)
+ (safe-gf-dfun-state gf)
+ (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
(typecase state
(function nil)
(cons (cddr state)))))
-(defvar *sgf-name-index*
+(defconstant +sgf-name-index+
(!bootstrap-slot-index 'standard-generic-function 'name))
(defun !early-gf-name (gf)
- (clos-slots-ref (get-slots gf) *sgf-name-index*))
+ (clos-slots-ref (get-slots gf) +sgf-name-index+))
(defun gf-lambda-list (gf)
- (let ((arg-info (if (eq *boot-state* 'complete)
+ (let ((arg-info (if (eq **boot-state** 'complete)
(gf-arg-info gf)
(early-gf-arg-info gf))))
(if (eq :no-lambda-list (arg-info-lambda-list arg-info))
- (let ((methods (if (eq *boot-state* 'complete)
+ (let ((methods (if (eq **boot-state** 'complete)
(generic-function-methods gf)
(early-gf-methods gf))))
(if (null methods)
(error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
class nor a symbol that names a class."
,gf-class)))
+ (unless (class-finalized-p ,gf-class)
+ (if (class-has-a-forward-referenced-superclass-p ,gf-class)
+ ;; FIXME: reference MOP documentation -- this is an
+ ;; additional requirement on our users
+ (error "The generic function class ~S is not finalizeable" ,gf-class)
+ (finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
- (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
- (unless (eq combin '.shes-not-there.)
- (setf (getf ,all-keys :method-combination)
- (find-method-combination (class-prototype ,gf-class)
- (car combin)
- (cdr combin)))))
+ (let ((combin (getf ,all-keys :method-combination)))
+ (etypecase combin
+ (cons
+ (setf (getf ,all-keys :method-combination)
+ (find-method-combination (class-prototype ,gf-class)
+ (car combin)
+ (cdr combin))))
+ ((or null method-combination))))
(let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
(unless (eq method-class '.shes-not-there.)
(setf (getf ,all-keys :method-class)
method-class)
(t (find-class method-class t ,env))))))))
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+ (unless lambda-list-p
+ ;; Use the existing lambda-list, if any. It is reasonable to do eg.
+ ;;
+ ;; (if (fboundp name)
+ ;; (ensure-generic-function name)
+ ;; (ensure-generic-function name :lambda-list '(foo)))
+ ;;
+ ;; in which case we end up here with no lambda-list in the first leg.
+ (setf (values lambda-list lambda-list-p)
+ (handler-case
+ (values (generic-function-lambda-list (fdefinition fun-name))
+ t)
+ ((or warning error) ()
+ (values nil nil)))))
+ (let ((gf-type
+ (specifier-type
+ (if lambda-list-p
+ (ftype-declaration-from-lambda-list lambda-list fun-name)
+ 'function)))
+ (old-type nil))
+ ;; FIXME: Ideally we would like to not clobber it, but because generic
+ ;; functions assert their FTYPEs callers believing the FTYPE are left with
+ ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type
+ ;; is a subtype of the old one, though -- even though the type is not
+ ;; trusted anymore, the warning is still not quite as interesting.
+ (when (and (eq :declared (info :function :where-from fun-name))
+ (not (csubtypep gf-type (setf old-type (info :function :type fun-name)))))
+ (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~S ~
+ for the same name with ~S.~:@>"
+ fun-name 'ftype
+ (type-specifier old-type)
+ (type-specifier gf-type)))
+ (setf (info :function :type fun-name) gf-type
+ (info :function :where-from fun-name) :defined-method)
+ fun-name))
+
(defun real-ensure-gf-using-class--generic-function
(existing
fun-name
&rest all-keys
&key environment (lambda-list nil lambda-list-p)
- (generic-function-class 'standard-generic-function gf-class-p)
+ (generic-function-class 'standard-generic-function)
&allow-other-keys)
(real-ensure-gf-internal generic-function-class all-keys environment)
- (unless (or (null gf-class-p)
- (eq (class-of existing) generic-function-class))
+ ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS,
+ ;; which is what makes the next line work
+ (unless (eq (class-of existing) generic-function-class)
(change-class existing generic-function-class))
(prog1
(apply #'reinitialize-instance existing all-keys)
- (when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
(defun real-ensure-gf-using-class--null
(existing
(setf (gdefinition fun-name)
(apply #'make-instance generic-function-class
:name fun-name all-keys))
- (when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
\f
+(defun safe-gf-arg-info (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (fsc-instance-slots generic-function)
+ +sgf-arg-info-index+)
+ (gf-arg-info generic-function)))
+
+;;; FIXME: this function took on a slightly greater role than it
+;;; previously had around 2005-11-02, when CSR fixed the bug whereby
+;;; having more than one subclass of standard-generic-function caused
+;;; the whole system to die horribly through a metacircle in
+;;; GF-ARG-INFO. The fix is to be slightly more disciplined about
+;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
+;;; computing discriminating functions, so we need to be careful about
+;;; having a base case for the recursion, and we provide that with the
+;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet)
+;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
+;;; that stage, where all potentially dangerous cases are enumerated
+;;; and stopped. -- CSR, 2005-11-02.
(defun get-generic-fun-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(early-gf-arg-info gf)
- (gf-arg-info gf)))
+ (safe-gf-arg-info gf)))
(metatypes (arg-info-metatypes arg-info)))
(values (arg-info-applyp arg-info)
metatypes
arg-info))
- (values (length metatypes) applyp metatypes
- (count-if (lambda (x) (neq x t)) metatypes)
- arg-info)))
+ (let ((nreq 0)
+ (nkeys 0))
+ (declare (fixnum nreq nkeys))
+ (dolist (x metatypes)
+ (incf nreq)
+ (unless (eq x t)
+ (incf nkeys)))
+ (values nreq applyp metatypes
+ nkeys
+ arg-info))))
+
+(defun generic-function-nreq (gf)
+ (let* ((arg-info (if (early-gf-p gf)
+ (early-gf-arg-info gf)
+ (safe-gf-arg-info gf)))
+ (metatypes (arg-info-metatypes arg-info)))
+ (declare (list metatypes))
+ (length metatypes)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &optional slot-name)
- (initialize-method-function initargs)
+ &key slot-name object-class method-class-function
+ definition-source)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
specializers))
(setq unparsed specializers
parsed ()))
- (list :early-method ;This is an early method dammit!
-
- (getf initargs :function)
- (getf initargs :fast-function)
-
- parsed ;The parsed specializers. This is used
- ;by early-method-specializers to cache
- ;the parse. Note that this only comes
- ;into play when there is more than one
- ;early method on an early gf.
-
- (list class ;A list to which real-make-a-method
- qualifiers ;can be applied to make a real method
- arglist ;corresponding to this early one.
- unparsed
- initargs
- doc
- slot-name))))
+ (let ((result
+ (list :early-method
+
+ (getf initargs :function)
+ (let ((mf (getf initargs :function)))
+ (aver mf)
+ (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+
+ ;; the parsed specializers. This is used by
+ ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
+ ;; Note that this only comes into play when there is
+ ;; more than one early method on an early gf.
+ parsed
+
+ ;; A list to which REAL-MAKE-A-METHOD can be applied
+ ;; to make a real method corresponding to this early
+ ;; one.
+ (append
+ (list class qualifiers arglist unparsed
+ initargs doc)
+ (when slot-name
+ (list :slot-name slot-name :object-class object-class
+ :method-class-function method-class-function))
+ (list :definition-source definition-source)))))
+ (initialize-method-function initargs result)
+ result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &optional slot-name)
- (setq specializers (parse-specializers specializers))
- (apply #'make-instance class
- :qualifiers qualifiers
- :lambda-list lambda-list
- :specializers specializers
- :documentation doc
- :slot-name slot-name
- :allow-other-keys t
- initargs))
+ &rest args &key slot-name object-class method-class-function
+ definition-source)
+ (if method-class-function
+ (let* ((object-class (if (classp object-class) object-class
+ (find-class object-class)))
+ (slots (class-direct-slots object-class))
+ (slot-definition (find slot-name slots
+ :key #'slot-definition-name)))
+ (aver slot-name)
+ (aver slot-definition)
+ (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list
+ :specializers specializers :documentation doc
+ :slot-definition slot-definition
+ :slot-name slot-name initargs)))
+ (apply #'make-instance
+ (apply method-class-function object-class slot-definition
+ initargs)
+ :definition-source definition-source
+ initargs)))
+ (apply #'make-instance class :qualifiers qualifiers
+ :lambda-list lambda-list :specializers specializers
+ :documentation doc (append args initargs))))
(defun early-method-function (early-method)
(values (cadr early-method) (caddr early-method)))
(eq class 'standard-boundp-method))))
(defun early-method-standard-accessor-slot-name (early-method)
- (seventh (fifth early-method)))
+ (eighth (fifth early-method)))
;;; Fetch the specializers of an early method. This is basically just
;;; a simple accessor except that when the second argument is t, this
(setf (fourth early-method)
(mapcar #'find-class (cadddr (fifth early-method))))))
(t
- (cadddr (fifth early-method))))
+ (fourth (fifth early-method))))
(error "~S is not an early-method." early-method)))
(defun early-method-qualifiers (early-method)
- (cadr (fifth early-method)))
+ (second (fifth early-method)))
(defun early-method-lambda-list (early-method)
- (caddr (fifth early-method)))
-
-(defun early-add-named-method (generic-function-name
- qualifiers
- specializers
- arglist
- &rest initargs)
- (let* ((gf (ensure-generic-function generic-function-name))
+ (third (fifth early-method)))
+
+(defun early-method-initargs (early-method)
+ (fifth (fifth early-method)))
+
+(defun (setf early-method-initargs) (new-value early-method)
+ (setf (fifth (fifth early-method)) new-value))
+
+(defun early-add-named-method (generic-function-name qualifiers
+ specializers arglist &rest initargs
+ &key documentation definition-source
+ &allow-other-keys)
+ (let* (;; we don't need to deal with the :generic-function-class
+ ;; argument here because the default,
+ ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
+ ;; functions. (See REAL-ADD-NAMED-METHOD)
+ (gf (ensure-generic-function generic-function-name))
(existing
(dolist (m (early-gf-methods gf))
(when (and (equal (early-method-specializers m) specializers)
(equal (early-method-qualifiers m) qualifiers))
- (return m))))
- (new (make-a-method 'standard-method
- qualifiers
- arglist
- specializers
- initargs
- ())))
- (when existing (remove-method gf existing))
- (add-method gf new)))
+ (return m)))))
+ (setf (getf (getf initargs 'plist) :name)
+ (make-method-spec gf qualifiers specializers))
+ (let ((new (make-a-method 'standard-method qualifiers arglist
+ specializers initargs documentation
+ :definition-source definition-source)))
+ (when existing (remove-method gf existing))
+ (add-method gf new))))
;;; This is the early version of ADD-METHOD. Later this will become a
;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has
(gf (gdefinition fspec))
(methods (mapcar (lambda (method)
(let* ((lambda-list (first method))
- (specializers (second method))
+ (specializers (mapcar #'find-class (second method)))
(method-fn-name (third method))
(fn-name (or method-fn-name fspec))
(fn (fdefinition fn-name))
;;; is really implemented.
(defun parse-defmethod (cdr-of-form)
(declare (list cdr-of-form))
- (let ((name (pop cdr-of-form))
- (qualifiers ())
+ (let ((qualifiers ())
(spec-ll ()))
(loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
(push (pop cdr-of-form) qualifiers)
(return (setq qualifiers (nreverse qualifiers)))))
(setq spec-ll (pop cdr-of-form))
- (values name qualifiers spec-ll cdr-of-form)))
+ (values qualifiers spec-ll cdr-of-form)))
-(defun parse-specializers (specializers)
+(defun parse-specializers (generic-function specializers)
(declare (list specializers))
(flet ((parse (spec)
- (let ((result (specializer-from-type spec)))
- (if (specializerp result)
- result
- (if (symbolp spec)
- (error "~S was used as a specializer,~%~
- but is not the name of a class."
- spec)
- (error "~S is not a legal specializer." spec))))))
+ (parse-specializer-using-class generic-function spec)))
(mapcar #'parse specializers)))
-(defun unparse-specializers (specializers-or-method)
- (if (listp specializers-or-method)
- (flet ((unparse (spec)
- (if (specializerp spec)
- (let ((type (specializer-type spec)))
- (if (and (consp type)
- (eq (car type) 'class))
- (let* ((class (cadr type))
- (class-name (class-name class)))
- (if (eq class (find-class class-name nil))
- class-name
- type))
- type))
- (error "~S is not a legal specializer." spec))))
- (mapcar #'unparse specializers-or-method))
- (unparse-specializers (method-specializers specializers-or-method))))
-
-(defun parse-method-or-spec (spec &optional (errorp t))
- (let (gf method name temp)
- (if (method-p spec)
- (setq method spec
- gf (method-generic-function method)
- temp (and gf (generic-function-name gf))
- name (if temp
- (make-method-spec temp
- (method-qualifiers method)
- (unparse-specializers
- (method-specializers method)))
- (make-symbol (format nil "~S" method))))
- (multiple-value-bind (gf-spec quals specls)
- (parse-defmethod spec)
- (and (setq gf (and (or errorp (gboundp gf-spec))
- (gdefinition gf-spec)))
- (let ((nreq (compute-discriminating-function-arglist-info gf)))
- (setq specls (append (parse-specializers specls)
- (make-list (- nreq (length specls))
- :initial-element
- *the-class-t*)))
- (and
- (setq method (get-method gf quals specls errorp))
- (setq name
- (make-method-spec
- gf-spec quals (unparse-specializers specls))))))))
- (values gf method name)))
+(defun unparse-specializers (generic-function specializers)
+ (declare (list specializers))
+ (flet ((unparse (spec)
+ (unparse-specializer-using-class generic-function spec)))
+ (mapcar #'unparse specializers)))
\f
(defun extract-parameters (specialized-lambda-list)
(multiple-value-bind (parameters ignore1 ignore2)
(t
(multiple-value-bind (parameters lambda-list specializers required)
(parse-specialized-lambda-list (cdr arglist))
+ ;; Check for valid arguments.
+ (unless (or (and (symbolp arg) (not (null arg)))
+ (and (consp arg)
+ (consp (cdr arg))
+ (null (cddr arg))))
+ (error 'specialized-lambda-list-error
+ :format-control "arg is not a non-NIL symbol or a list of two elements: ~A"
+ :format-arguments (list arg)))
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons (if (listp arg) (car arg) arg) lambda-list)
(cons (if (listp arg) (cadr arg) t) specializers)
(cons (if (listp arg) (car arg) arg) required)))))))
\f
-(setq *boot-state* 'early)
+(setq **boot-state** 'early)
\f
;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
;;; which used %WALKER stuff. That suggests to me that maybe the code
;;; walker stuff was only used for implementing stuff like that; maybe
;;; it's not needed any more? Hunt down what it was used for and see.
+(defun extract-the (form)
+ (cond ((and (consp form) (eq (car form) 'the))
+ (aver (proper-list-of-length-p form 3))
+ (third form))
+ (t
+ form)))
+
(defmacro with-slots (slots instance &body body)
(let ((in (gensym)))
`(let ((,in ,instance))
(declare (ignorable ,in))
- ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
- (third instance)
- instance)))
+ ,@(let ((instance (extract-the instance)))
(and (symbolp instance)
`((declare (%variable-rebinding ,in ,instance)))))
,in
(let ((in (gensym)))
`(let ((,in ,instance))
(declare (ignorable ,in))
- ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
- (third instance)
- instance)))
+ ,@(let ((instance (extract-the instance)))
(and (symbolp instance)
`((declare (%variable-rebinding ,in ,instance)))))
,in
projects / sbcl.git / blobdiff