- (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))
- (calls (list nil))
- (class-declarations
- `(declare
- ;; FIXME: These nonstandard (DECLARE (SB-PCL::CLASS FOO BAR))
- ;; declarations should go away but as of 0.6.9.10, it's not
- ;; as simple as just deleting them.
- ,@(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 Python likes them a lot. (We're
- ;; telling the compiler about our knowledge of
- ;; specialized argument types so that it can avoid
- ;; run-time type overhead, which can be a big win
- ;; for Python.)
- ,@(mapcar (lambda (a s)
- (cond ((and (consp s)
- (eql (car s) '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))
- ((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))
- (t
- ;; Otherwise, we can make Python
- ;; very happy.
- `(type ,s ,a))))
- 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 ,(sb-int:function-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
- (eval (car real-body))))
- ;; FIXME: This can become a bare AND (no IF), just like
- ;; the expression for CONSTANT-VALUE just above.
- (plist (if (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)
- (walk-method-lambda method-lambda
- required-parameters
- env
- slots
- calls)
- (multiple-value-bind
- (ignore walked-declarations walked-lambda-body)
- (extract-declarations (cddr walked-lambda))
- (declare (ignore ignore))
- (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))))))
- (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
- ,call-next-method-p
- :next-method-p-p ,next-method-p-p
- :closurep ,closurep
- :applyp ,applyp)
- ,@walked-declarations
- ,@walked-lambda-body))
- `(,@(when plist
- `(:plist ,plist))
- ,@(when documentation
- `(:documentation ,documentation)))))))))))
+ (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))
+ (calls (list nil))
+ (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
+ ,@(mapcar #'parameter-specializer-declaration-in-defmethod
+ 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)
+ (walk-method-lambda method-lambda
+ required-parameters
+ env
+ slots
+ calls)
+ (multiple-value-bind (walked-lambda-body
+ walked-declarations
+ walked-documentation)
+ (parse-body (cddr walked-lambda))
+ (declare (ignore walked-documentation))
+ (when (some #'cdr slots)
+ (multiple-value-bind (slot-name-lists call-list)
+ (slot-name-lists-from-slots slots calls)
+ (setq plist
+ `(,@(when slot-name-lists
+ `(:slot-name-lists ,slot-name-lists))
+ ,@(when call-list
+ `(:call-list ,call-list))
+ ,@plist))
+ (setq walked-lambda-body
+ `((pv-binding (,required-parameters
+ ,slot-name-lists
+ (load-time-value
+ (intern-pv-table
+ :slot-name-lists ',slot-name-lists
+ :call-list ',call-list)))
+ ,@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
+ ,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)))))))))))