+ (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))
+ ;; 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*)
+ (generic-function-name (when method-name (car method-name)))
+ (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
+ (mapcar (lambda (r s) (declare (ignore s)) r)
+ parameters
+ specializers))
+ (slots (mapcar #'list required-parameters))
+ (class-declarations
+ `(declare
+ ;; These declarations seem to be used by PCL to pass
+ ;; information to itself; when I tried to delete 'em
+ ;; ca. 0.6.10 it didn't work. I'm not sure how
+ ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
+ ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
+ ,@(remove nil
+ (mapcar (lambda (a s) (and (symbolp s)
+ (neq s t)
+ `(%class ,a ,s)))
+ parameters
+ specializers))
+ ;; These TYPE declarations weren't in the original
+ ;; PCL code, but the Python compiler likes them a
+ ;; lot. (We're telling the compiler about our
+ ;; knowledge of specialized argument types so that
+ ;; it can avoid run-time type dispatch overhead,
+ ;; which can be a huge win for Python.)
+ ;;
+ ;; KLUDGE: when I tried moving these to
+ ;; ADD-METHOD-DECLARATIONS, things broke. No idea
+ ;; why. -- CSR, 2004-06-16
+ ,@(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
+ ;; string is removed to make it easy for us to insert
+ ;; new declarations later, they will just go after the
+ ;; CADR of the method lambda. The class declarations
+ ;; are inserted to communicate the class of the method's
+ ;; arguments to the code walk.
+ `(lambda ,lambda-list
+ ;; The default ignorability of method parameters
+ ;; doesn't seem to be specified by ANSI. PCL had
+ ;; them basically ignorable but was a little
+ ;; inconsistent. E.g. even though the two
+ ;; method definitions
+ ;; (DEFMETHOD FOO ((X T) (Y T)) "Z")
+ ;; (DEFMETHOD FOO ((X T) Y) "Z")
+ ;; are otherwise equivalent, PCL treated Y as
+ ;; ignorable in the first definition but not in the
+ ;; second definition. We make all required
+ ;; parameters ignorable as a way of systematizing
+ ;; the old PCL behavior. -- WHN 2000-11-24
+ (declare (ignorable ,@required-parameters))
+ ,class-declarations
+ ,@declarations
+ (block ,(fun-name-block-name generic-function-name)
+ ,@real-body)))
+ (constant-value-p (and (null (cdr real-body))
+ (constantp (car real-body))))
+ (constant-value (and constant-value-p
+ (constant-form-value (car real-body))))
+ (plist (and constant-value-p
+ (or (typep constant-value
+ '(or number character))
+ (and (symbolp constant-value)
+ (symbol-package constant-value)))
+ (list :constant-value constant-value)))
+ (applyp (dolist (p lambda-list nil)
+ (cond ((memq p '(&optional &rest &key))
+ (return t))
+ ((eq p '&aux)
+ (return nil))))))
+ (multiple-value-bind
+ (walked-lambda call-next-method-p closurep
+ next-method-p-p setq-p
+ parameters-setqd)
+ (walk-method-lambda method-lambda
+ required-parameters
+ env
+ slots)
+ (multiple-value-bind (walked-lambda-body
+ walked-declarations
+ walked-documentation)
+ (parse-body (cddr walked-lambda))
+ (declare (ignore walked-documentation))
+ (when (some #'cdr slots)
+ (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))))
+ (values `(lambda (.method-args. .next-methods.)
+ (simple-lexical-method-functions
+ (,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)))
+
+;;; 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 ())