(eval-when (:execute)
(%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
-(defmacro %defmethod-expander
+(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))
(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)
(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))
(unless (fboundp 'make-method-lambda)
(setf (gdefinition 'make-method-lambda)
(symbol-function 'real-make-method-lambda)))
+(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)))
+ (generic-function-name (when method-name (car method-name)))
+ (specialized-lambda-list (or sll-decl (cadr 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
+ ,@(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
+ 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
+ ,call-next-method-p
+ :next-method-p-p ,next-method-p-p
+ :setq-p ,setq-p
+ :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 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))
;;; optimized-slot-value* macros.
(define-symbol-macro %parameter-binding-modified ())
-(defun make-method-lambda-internal (method-lambda &optional env)
- (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)))
- (generic-function-name (when method-name (car method-name)))
- (specialized-lambda-list (or sll-decl (cadr 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))
- (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
- parameters-setqd)
- (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
- :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 plist `(plist ,plist))
- ,@(when documentation `(:documentation ,documentation)))))))))))
-
(defmacro simple-lexical-method-functions ((lambda-list
method-args
next-methods
(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
- pv-cell
+ pv
next-method-call
arg-info)
(defstruct (constant-fast-method-call
(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-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
&rest required-args)
(macrolet ((generate-call (n)
``(funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args
,@(loop for x below ,n
(0 ,(generate-call 0))
(1 ,(generate-call 1))
(t (multiple-value-call (fast-method-call-function ,method-call)
- (values (fast-method-call-pv-cell ,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))))))
(nreq (car arg-info)))
(if restp
(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)
(cond ((null args)
: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
when (eq key keyword)
return tail))
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(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)
(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))))
+ (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)))
(set-fun-name mff fast-name))))
(when plist
(let ((plist plist))
- (let ((snl (getf plist :slot-name-lists))
- (cl (getf plist :call-list)))
- (when (or snl cl)
+ (let ((snl (getf plist :slot-name-lists)))
+ (when snl
(setf (method-plist-value method :pv-table)
- (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+ (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?
lambda-list-p)
argument-precedence-order
source-location
+ 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 source-location)
+ argument-precedence-order source-location
+ documentation)
(bug "The function ~S is not already defined." spec)))
(existing
(bug "~S should be on the list ~S."
(t
(pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p nil
- argument-precedence-order source-location))))
+ argument-precedence-order source-location
+ documentation))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order source-location)
+ function argument-precedence-order source-location
+ documentation)
(let ((fin (allocate-standard-funcallable-instance
*sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-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
- source-location)
+ (!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)
(setf (getf (getf initargs 'plist) :name)
(make-method-spec gf qualifiers specializers))
(let ((new (make-a-method 'standard-method qualifiers arglist
- specializers initargs ())))
+ specializers initargs (getf initargs :documentation))))
(when existing (remove-method gf existing))
(add-method gf new))))
;;; 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 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