(let ((check-qualifiers (legal-qualifiers-p method qualifiers))
(check-lambda-list (legal-lambda-list-p method lambda-list))
(check-specializers (legal-specializers-p method specializers))
- (check-function (legal-method-function-p method
- (or function
- fast-function)))
+ (check-fun (legal-method-function-p method
+ (or function
+ fast-function)))
(check-documentation (legal-documentation-p method documentation)))
(unless (eq check-qualifiers t)
(lose :qualifiers qualifiers check-qualifiers))
(lose :lambda-list lambda-list check-lambda-list))
(unless (eq check-specializers t)
(lose :specializers specializers check-specializers))
- (unless (eq check-function t)
- (lose :function function check-function))
+ (unless (eq check-fun t)
+ (lose :function function check-fun))
(unless (eq check-documentation t)
(lose :documentation documentation check-documentation)))))
lambda-list lambda-list-p))
(when namep
- (set-function-name generic-function name))
+ (set-fun-name generic-function name))
(flet ((initarg-error (initarg value string)
(error "when initializing the generic function ~S:~%~
&rest other-initargs)
(unless (and (fboundp generic-function-name)
(typep (fdefinition generic-function-name) 'generic-function))
- (sb-kernel::style-warn "implicitly creating new generic function ~S"
- generic-function-name))
+ (style-warn "implicitly creating new generic function ~S"
+ generic-function-name))
;; XXX What about changing the class of the generic function if
;; there is one? Whose job is that, anyway? Do we need something
;; kind of like CLASS-FOR-REDEFINITION?
&optional (errorp t))
(let ((hit
(dolist (method (generic-function-methods generic-function))
- (when (and (equal qualifiers (method-qualifiers method))
- (every #'same-specializer-p specializers
- (method-specializers method)))
- (return method)))))
+ (let ((mspecializers (method-specializers method)))
+ (when (and (equal qualifiers (method-qualifiers method))
+ (= (length specializers) (length mspecializers))
+ (every #'same-specializer-p specializers
+ (method-specializers method)))
+ (return method))))))
(cond (hit hit)
((null errorp) nil)
(t
;; in the usual sort of way. For efficiency don't bother to
;; keep specialized-argument-positions sorted, rather depend
;; on our caller to do that.
- (iterate ((type-spec (list-elements (method-specializers method)))
- (pos (interval :from 0)))
- (unless (eq type-spec *the-class-t*)
- (pushnew pos specialized-argument-positions)))
+ (let ((pos 0))
+ (dolist (type-spec (method-specializers method))
+ (unless (eq type-spec *the-class-t*)
+ (pushnew pos specialized-argument-positions))
+ (incf pos)))
;; Finally merge the values for this method into the values
;; for the exisiting methods and return them. Note that if
;; num-of-requireds is NIL it means this is the first method
specialized-argument-positions)))
(defun make-discriminating-function-arglist (number-required-arguments restp)
- (nconc (gathering ((args (collecting)))
- (iterate ((i (interval :from 0 :below number-required-arguments)))
- (gather (intern (format nil "Discriminating Function Arg ~D" i))
- args)))
+ (nconc (let ((args nil))
+ (dotimes (i number-required-arguments)
+ (push (intern (format nil "Discriminating Function Arg ~D" i))
+ args))
+ (nreverse args))
(when restp
`(&rest ,(intern "Discriminating Function &rest Arg")))))
\f
+(defmethod generic-function-argument-precedence-order
+ ((gf standard-generic-function))
+ (aver (eq *boot-state* 'complete))
+ (loop with arg-info = (gf-arg-info gf)
+ with lambda-list = (arg-info-lambda-list arg-info)
+ for argument-position in (arg-info-precedence arg-info)
+ collect (nth argument-position lambda-list)))
+
(defmethod generic-function-lambda-list ((gf generic-function))
(gf-lambda-list gf))
(real-add-method gf (pop methods) methods)))
(defun real-add-method (generic-function method &optional skip-dfun-update-p)
- (if (method-generic-function method)
- (error "The method ~S is already part of the generic~@
- function ~S. It can't be added to another generic~@
- function until it is removed from the first one."
- method (method-generic-function method))
-
+ (when (method-generic-function method)
+ (error "The method ~S is already part of the generic~@
+ function ~S. It can't be added to another generic~@
+ function until it is removed from the first one."
+ method (method-generic-function method)))
+ (flet ((similar-lambda-lists-p (method-a method-b)
+ (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
+ (analyze-lambda-list (method-lambda-list method-a))
+ (multiple-value-bind (b-nreq b-nopt b-keyp b-restp)
+ (analyze-lambda-list (method-lambda-list method-b))
+ (and (= a-nreq b-nreq)
+ (= a-nopt b-nopt)
+ (eq (or a-keyp a-restp)
+ (or b-keyp b-restp)))))))
(let* ((name (generic-function-name generic-function))
(qualifiers (method-qualifiers method))
(specializers (method-specializers method))
specializers
nil)))
- ;; If there is already a method like this one then we must
- ;; get rid of it before proceeding. Note that we call the
- ;; generic function remove-method to remove it rather than
- ;; doing it in some internal way.
- (when existing (remove-method generic-function existing))
+ ;; If there is already a method like this one then we must get
+ ;; rid of it before proceeding. Note that we call the generic
+ ;; function REMOVE-METHOD to remove it rather than doing it in
+ ;; some internal way.
+ (when (and existing (similar-lambda-lists-p existing method))
+ (remove-method generic-function existing))
(setf (method-generic-function method) generic-function)
(pushnew method (generic-function-methods generic-function))
(dolist (specializer specializers)
(add-direct-method specializer method))
- (set-arg-info generic-function :new-method method)
+
+ ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
+ ;; detecting attempts to add methods with incongruent lambda
+ ;; lists. However, according to Gerd Moellmann on cmucl-imp,
+ ;; it also depends on the new method already having been added
+ ;; to the generic function. Therefore, we need to remove it
+ ;; again on error:
+ (let ((remove-again-p t))
+ (unwind-protect
+ (progn
+ (set-arg-info generic-function :new-method method)
+ (setq remove-again-p nil))
+ (when remove-again-p
+ (remove-method generic-function method))))
(unless skip-dfun-update-p
- (when (member name
- '(make-instance default-initargs
- allocate-instance shared-initialize
- initialize-instance))
- (update-make-instance-function-table (type-class
- (car specializers))))
+ (update-ctors 'add-method
+ :generic-function generic-function
+ :method method)
(update-dfun generic-function))
method)))
(dolist (specializer (method-specializers method))
(remove-direct-method specializer method))
(set-arg-info generic-function)
- (when (member name
- '(make-instance
- default-initargs
- allocate-instance shared-initialize initialize-instance))
- (update-make-instance-function-table (type-class (car specializers))))
+ (update-ctors 'remove-method
+ :generic-function generic-function
+ :method method)
(update-dfun generic-function)
generic-function)))
\f
(defun compute-applicable-methods-function (generic-function arguments)
(values (compute-applicable-methods-using-types
generic-function
- (types-from-arguments generic-function arguments 'eql))))
+ (types-from-args generic-function arguments 'eql))))
(defmethod compute-applicable-methods
((generic-function generic-function) arguments)
(values (compute-applicable-methods-using-types
generic-function
- (types-from-arguments generic-function arguments 'eql))))
+ (types-from-args generic-function arguments 'eql))))
(defmethod compute-applicable-methods-using-classes
((generic-function generic-function) classes)
(compute-applicable-methods-using-types
generic-function
- (types-from-arguments generic-function classes 'class-eq)))
+ (types-from-args generic-function classes 'class-eq)))
(defun proclaim-incompatible-superclasses (classes)
- (setq classes (mapcar #'(lambda (class)
- (if (symbolp class)
- (find-class class)
- class))
+ (setq classes (mapcar (lambda (class)
+ (if (symbolp class)
+ (find-class class)
+ class))
classes))
(dolist (class classes)
(dolist (other-class classes)
(pushnew other-class (class-incompatible-superclass-list class))))))
(defun superclasses-compatible-p (class1 class2)
- (let ((cpl1 (class-precedence-list class1))
- (cpl2 (class-precedence-list class2)))
+ (let ((cpl1 (cpl-or-nil class1))
+ (cpl2 (cpl-or-nil class2)))
(dolist (sc1 cpl1 t)
(dolist (ic (class-incompatible-superclass-list sc1))
(when (memq ic cpl2)
(make-internal-reader-method-function
'standard-generic-function 'arg-info)
t)))
- #'(lambda (&rest args) (funcall mf args nil))))
+ (lambda (&rest args) (funcall mf args nil))))
(defun error-need-at-least-n-args (function n)
- (error "~@<The function ~2I~_~S ~I~_requires at least ~D argument~:P.~:>"
+ (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
function
n))
-(defun types-from-arguments (generic-function arguments
- &optional type-modifier)
+(defun types-from-args (generic-function arguments &optional type-modifier)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore applyp metatypes nkeys))
(let ((types-rev nil))
(dotimes-fixnum (i nreq)
:constant-value)))
(defun default-secondary-dispatch-function (generic-function)
- #'(lambda (&rest args)
- (let ((methods (compute-applicable-methods generic-function args)))
- (if methods
- (let ((emf (get-effective-method-function generic-function
- methods)))
- (invoke-emf emf args))
- (apply #'no-applicable-method generic-function args)))))
+ (lambda (&rest args)
+ (let ((methods (compute-applicable-methods generic-function args)))
+ (if methods
+ (let ((emf (get-effective-method-function generic-function
+ methods)))
+ (invoke-emf emf args))
+ (apply #'no-applicable-method generic-function args)))))
(defun list-eq (x y)
(loop (when (atom x) (return (eq x y)))
(defun update-all-c-a-m-gf-info (c-a-m-gf)
(let ((methods (generic-function-methods c-a-m-gf)))
(if (and *old-c-a-m-gf-methods*
- (every #'(lambda (old-method)
- (member old-method methods))
+ (every (lambda (old-method)
+ (member old-method methods))
*old-c-a-m-gf-methods*))
(let ((gfs-to-do nil)
(gf-classes-to-do nil))
(pushnew (specializer-object specl) gfs-to-do)
(pushnew (specializer-class specl) gf-classes-to-do)))))
(map-all-generic-functions
- #'(lambda (gf)
- (when (or (member gf gfs-to-do)
- (dolist (class gf-classes-to-do nil)
- (member class
- (class-precedence-list (class-of gf)))))
- (update-c-a-m-gf-info gf)))))
+ (lambda (gf)
+ (when (or (member gf gfs-to-do)
+ (dolist (class gf-classes-to-do nil)
+ (member class
+ (class-precedence-list (class-of gf)))))
+ (update-c-a-m-gf-info gf)))))
(map-all-generic-functions #'update-c-a-m-gf-info))
(setq *old-c-a-m-gf-methods* methods)))
(eq spec *the-class-structure-object*)))
(let ((sc (class-direct-subclasses spec)))
(when sc
- (mapcan #'(lambda (class)
- (mec-all-classes-internal class precompute-p))
+ (mapcan (lambda (class)
+ (mec-all-classes-internal class precompute-p))
sc))))))
(defun mec-all-classes (spec precompute-p)
precompute-p))
(all-class-lists (mec-all-class-lists (cdr spec-list)
precompute-p)))
- (mapcan #'(lambda (list)
- (mapcar #'(lambda (c) (cons c list)) car-all-classes))
+ (mapcan (lambda (list)
+ (mapcar (lambda (c) (cons c list)) car-all-classes))
all-class-lists))))
(defun make-emf-cache (generic-function valuep cache classes-list new-class)
((eq valuep :constant-value)
(value-for-caching generic-function
classes)))))
- (setq cache (fill-cache cache wrappers value t))))))))
+ (setq cache (fill-cache cache wrappers value))))))))
(if classes-list
(mapc #'add-class-list classes-list)
(dolist (method (generic-function-methods generic-function))
(cond ((eq class *the-class-t*)
t)
((eq class *the-class-slot-object*)
- `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class)))
+ `(not (typep (classoid-of ,arg)
+ 'built-in-classoid)))
((eq class *the-class-std-object*)
`(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
((eq class *the-class-standard-object*)
;;; This is CASE, but without gensyms.
(defmacro scase (arg &rest clauses)
`(let ((.case-arg. ,arg))
- (cond ,@(mapcar #'(lambda (clause)
- (list* (cond ((null (car clause))
- nil)
- ((consp (car clause))
- (if (null (cdar clause))
- `(eql .case-arg.
- ',(caar clause))
- `(member .case-arg.
- ',(car clause))))
- ((member (car clause) '(t otherwise))
- `t)
- (t
- `(eql .case-arg. ',(car clause))))
- nil
- (cdr clause)))
+ (cond ,@(mapcar (lambda (clause)
+ (list* (cond ((null (car clause))
+ nil)
+ ((consp (car clause))
+ (if (null (cdar clause))
+ `(eql .case-arg.
+ ',(caar clause))
+ `(member .case-arg.
+ ',(car clause))))
+ ((member (car clause) '(t otherwise))
+ `t)
+ (t
+ `(eql .case-arg. ',(car clause))))
+ nil
+ (cdr clause)))
clauses))))
(defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses))
(precedence (arg-info-precedence arg-info)))
(generate-discrimination-net-internal
generic-function methods types
- #'(lambda (methods known-types)
- (if (or sorted-p
- (block one-order-p
- (let ((sorted-methods nil))
- (map-all-orders
- (copy-list methods) precedence
- #'(lambda (methods)
- (when sorted-methods (return-from one-order-p nil))
- (setq sorted-methods methods)))
- (setq methods sorted-methods))
- t))
- `(methods ,methods ,known-types)
- `(unordered-methods ,methods ,known-types)))
- #'(lambda (position type true-value false-value)
- (let ((arg (dfun-arg-symbol position)))
- (if (eq (car type) 'eql)
- (let* ((false-case-p (and (consp false-value)
- (or (eq (car false-value) 'scase)
- (eq (car false-value) 'mcase))
- (eq arg (cadr false-value))))
- (false-clauses (if false-case-p
- (cddr false-value)
- `((t ,false-value))))
- (case-sym (if (and (dnet-methods-p true-value)
- (if false-case-p
- (eq (car false-value) 'mcase)
- (dnet-methods-p false-value)))
- 'mcase
- 'scase))
- (type-sym `(,(cadr type))))
- `(,case-sym ,arg
- (,type-sym ,true-value)
- ,@false-clauses))
- `(if ,(let ((arg (dfun-arg-symbol position)))
- (case (car type)
- (class `(class-test ,arg ,(cadr type)))
- (class-eq `(class-eq-test ,arg ,(cadr type)))))
- ,true-value
- ,false-value))))
+ (lambda (methods known-types)
+ (if (or sorted-p
+ (block one-order-p
+ (let ((sorted-methods nil))
+ (map-all-orders
+ (copy-list methods) precedence
+ (lambda (methods)
+ (when sorted-methods (return-from one-order-p nil))
+ (setq sorted-methods methods)))
+ (setq methods sorted-methods))
+ t))
+ `(methods ,methods ,known-types)
+ `(unordered-methods ,methods ,known-types)))
+ (lambda (position type true-value false-value)
+ (let ((arg (dfun-arg-symbol position)))
+ (if (eq (car type) 'eql)
+ (let* ((false-case-p (and (consp false-value)
+ (or (eq (car false-value) 'scase)
+ (eq (car false-value) 'mcase))
+ (eq arg (cadr false-value))))
+ (false-clauses (if false-case-p
+ (cddr false-value)
+ `((t ,false-value))))
+ (case-sym (if (and (dnet-methods-p true-value)
+ (if false-case-p
+ (eq (car false-value) 'mcase)
+ (dnet-methods-p false-value)))
+ 'mcase
+ 'scase))
+ (type-sym `(,(cadr type))))
+ `(,case-sym ,arg
+ (,type-sym ,true-value)
+ ,@false-clauses))
+ `(if ,(let ((arg (dfun-arg-symbol position)))
+ (case (car type)
+ (class `(class-test ,arg ,(cadr type)))
+ (class-eq `(class-eq-test ,arg ,(cadr type)))))
+ ,true-value
+ ,false-value))))
#'identity)))
(defun class-from-type (type)
(classes-list nil))
(generate-discrimination-net-internal
gf methods nil
- #'(lambda (methods known-types)
- (when methods
- (when classes-list-p
- (push (mapcar #'class-from-type known-types) classes-list))
- (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
- methods))))
- (map-all-orders
- methods precedence
- #'(lambda (methods)
- (get-secondary-dispatch-function1
- gf methods known-types
- nil caching-p no-eql-specls-p))))))
- #'(lambda (position type true-value false-value)
- (declare (ignore position type true-value false-value))
- nil)
- #'(lambda (type)
- (if (and (consp type) (eq (car type) 'eql))
- `(class-eq ,(class-of (cadr type)))
- type)))
+ (lambda (methods known-types)
+ (when methods
+ (when classes-list-p
+ (push (mapcar #'class-from-type known-types) classes-list))
+ (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
+ methods))))
+ (map-all-orders
+ methods precedence
+ (lambda (methods)
+ (get-secondary-dispatch-function1
+ gf methods known-types
+ nil caching-p no-eql-specls-p))))))
+ (lambda (position type true-value false-value)
+ (declare (ignore position type true-value false-value))
+ nil)
+ (lambda (type)
+ (if (and (consp type) (eq (car type) 'eql))
+ `(class-eq ,(class-of (cadr type)))
+ type)))
classes-list))
;;; We know that known-type implies neither new-type nor `(not ,new-type).
(list known-type))))
(unless (eq (car new-type) 'not)
(setq so-far
- (mapcan #'(lambda (type)
- (unless (*subtypep new-type type)
- (list type)))
+ (mapcan (lambda (type)
+ (unless (*subtypep new-type type)
+ (list type)))
so-far)))
(if (null so-far)
new-type
`(and ,new-type ,@so-far)))))
(defun generate-discrimination-net-internal
- (gf methods types methods-function test-function type-function)
+ (gf methods types methods-function test-fun type-function)
(let* ((arg-info (gf-arg-info gf))
(precedence (arg-info-precedence arg-info))
(nreq (arg-info-number-required arg-info))
known-types))))
(cond ((determined-to-be nil) (do-if nil t))
((determined-to-be t) (do-if t t))
- (t (funcall test-function position type
+ (t (funcall test-fun position type
(do-if t) (do-if nil))))))))))
(do-column precedence methods ()))))
(case (car form)
(mcase
(let* ((mp (compute-mcase-parameters (cddr form)))
- (list (mapcar #'(lambda (clause)
- (let ((key (car clause))
- (meth (cadr clause)))
- (cons (if (consp key) (car key) key)
- (methods-converter
- meth generic-function))))
+ (list (mapcar (lambda (clause)
+ (let ((key (car clause))
+ (meth (cadr clause)))
+ (cons (if (consp key) (car key) key)
+ (methods-converter
+ meth generic-function))))
(cddr form)))
(default (car (last list))))
- (list (list* ':mcase mp (nbutlast list))
+ (list (list* :mcase mp (nbutlast list))
(cdr default))))
(t
(default-constant-converter form))))))
(defun convert-table (constant method-alist wrappers)
(cond ((and (consp constant)
- (eq (car constant) ':mcase))
- (let ((alist (mapcar #'(lambda (k+m)
- (cons (car k+m)
- (convert-methods (cdr k+m)
- method-alist
- wrappers)))
+ (eq (car constant) :mcase))
+ (let ((alist (mapcar (lambda (k+m)
+ (cons (car k+m)
+ (convert-methods (cdr k+m)
+ method-alist
+ wrappers)))
(cddr constant)))
(mp (cadr constant)))
(ecase (cadr mp)
(make-dfun-lambda-list metatypes applyp)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
- (get-function1 `(,(if function-p
- 'sb-kernel:instance-lambda
- 'lambda)
- ,arglist
- ,@(unless function-p
- `((declare (ignore .pv-cell.
- .next-method-call.))))
- (locally (declare #.*optimize-speed*)
- (let ((emf ,net))
- ,(make-emf-call metatypes applyp 'emf))))
- #'net-test-converter
- #'net-code-converter
- #'(lambda (form)
- (net-constant-converter form generic-function)))
- #'(lambda (method-alist wrappers)
- (let* ((alist (list nil))
- (alist-tail alist))
- (dolist (constant constants)
- (let* ((a (or (dolist (a alist nil)
- (when (eq (car a) constant)
- (return a)))
- (cons constant
- (or (convert-table
- constant method-alist wrappers)
- (convert-methods
- constant method-alist wrappers)))))
- (new (list a)))
- (setf (cdr alist-tail) new)
- (setf alist-tail new)))
- (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
- (if function-p
- function
- (make-fast-method-call
- :function (set-function-name function
- `(sdfun-method ,name))
- :arg-info fmc-arg-info))))))))))
+ (get-fun1 `(,(if function-p
+ 'instance-lambda
+ 'lambda)
+ ,arglist
+ ,@(unless function-p
+ `((declare (ignore .pv-cell.
+ .next-method-call.))))
+ (locally (declare #.*optimize-speed*)
+ (let ((emf ,net))
+ ,(make-emf-call metatypes applyp 'emf))))
+ #'net-test-converter
+ #'net-code-converter
+ (lambda (form)
+ (net-constant-converter form generic-function)))
+ (lambda (method-alist wrappers)
+ (let* ((alist (list nil))
+ (alist-tail alist))
+ (dolist (constant constants)
+ (let* ((a (or (dolist (a alist nil)
+ (when (eq (car a) constant)
+ (return a)))
+ (cons constant
+ (or (convert-table
+ constant method-alist wrappers)
+ (convert-methods
+ constant method-alist wrappers)))))
+ (new (list a)))
+ (setf (cdr alist-tail) new)
+ (setf alist-tail new)))
+ (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
+ (if function-p
+ function
+ (make-fast-method-call
+ :function (set-fun-name function `(sdfun-method ,name))
+ :arg-info fmc-arg-info))))))))))
(defvar *show-make-unordered-methods-emf-calls* nil)
(when *show-make-unordered-methods-emf-calls*
(format t "~&make-unordered-methods-emf ~S~%"
(generic-function-name generic-function)))
- #'(lambda (&rest args)
- (let* ((types (types-from-arguments generic-function args 'eql))
- (smethods (sort-applicable-methods generic-function
- methods
- types))
- (emf (get-effective-method-function generic-function smethods)))
- (invoke-emf emf args))))
+ (lambda (&rest args)
+ (let* ((types (types-from-args generic-function args 'eql))
+ (smethods (sort-applicable-methods generic-function
+ methods
+ types))
+ (emf (get-effective-method-function generic-function smethods)))
+ (invoke-emf emf args))))
\f
;;; The value returned by compute-discriminating-function is a function
;;; object. It is called a discriminating function because it is called
;;; the funcallable instance function of the generic function for which
;;; it was computed.
;;;
-;;; More precisely, if compute-discriminating-function is called with an
-;;; argument <gf1>, and returns a result <df1>, that result must not be
-;;; passed to apply or funcall directly. Rather, <df1> must be stored as
-;;; the funcallable instance function of the same generic function <gf1>
-;;; (using set-funcallable-instance-fun). Then the generic function
-;;; can be passed to funcall or apply.
+;;; More precisely, if compute-discriminating-function is called with
+;;; an argument <gf1>, and returns a result <df1>, that result must
+;;; not be passed to apply or funcall directly. Rather, <df1> must be
+;;; stored as the funcallable instance function of the same generic
+;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
+;;; generic function can be passed to funcall or apply.
;;;
;;; An important exception is that methods on this generic function are
;;; permitted to return a function which itself ends up calling the value
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; (let ((std (call-next-method)))
-;;; #'(lambda (arg)
+;;; (lambda (arg)
;;; (print (list 'call-to-gf gf arg))
;;; (funcall std arg))))
;;;
;;; itself in accordance with this protocol:
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
-;;; #'(lambda (arg)
+;;; (lambda (arg)
;;; (cond (<some condition>
;;; <store some info in the generic function>
-;;; (set-funcallable-instance-fun
+;;; (set-funcallable-instance-function
;;; gf
;;; (compute-discriminating-function gf))
;;; (funcall gf arg))
;;; Whereas this code would not be legal:
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
-;;; #'(lambda (arg)
+;;; (lambda (arg)
;;; (cond (<some condition>
-;;; (set-funcallable-instance-fun
+;;; (set-funcallable-instance-function
;;; gf
-;;; #'(lambda (a) ..))
+;;; (lambda (a) ..))
;;; (funcall gf arg))
;;; (t
;;; <call-a-method-of-gf>))))
(nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
(analyze-lambda-list ll)
(declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
- (remove-if #'(lambda (s)
- (or (memq s keyword-parameters)
- (eq s '&allow-other-keys)))
+ (remove-if (lambda (s)
+ (or (memq s keyword-parameters)
+ (eq s '&allow-other-keys)))
ll)))
\f
;;; This is based on the rules of method lambda list congruency defined in
;;; into account at all yet.
(defmethod generic-function-pretty-arglist
((generic-function standard-generic-function))
- (let ((methods (generic-function-methods generic-function))
- (arglist ()))
- (when methods
- (multiple-value-bind (required optional rest key allow-other-keys)
- (method-pretty-arglist (car methods))
- (dolist (m (cdr methods))
- (multiple-value-bind (method-key-keywords
- method-allow-other-keys
- method-key)
- (function-keywords m)
- ;; we've modified function-keywords to return what we want as
- ;; the third value, no other change here.
- (declare (ignore method-key-keywords))
- (setq key (union key method-key))
- (setq allow-other-keys (or allow-other-keys
- method-allow-other-keys))))
- (when allow-other-keys
- (setq arglist '(&allow-other-keys)))
- (when key
- (setq arglist (nconc (list '&key) key arglist)))
- (when rest
- (setq arglist (nconc (list '&rest rest) arglist)))
- (when optional
- (setq arglist (nconc (list '&optional) optional arglist)))
- (nconc required arglist)))))
+ (let ((methods (generic-function-methods generic-function)))
+ (if methods
+ (let ((arglist ()))
+ ;; arglist is constructed from the GF's methods - maybe with
+ ;; keys and rest stuff added
+ (multiple-value-bind (required optional rest key allow-other-keys)
+ (method-pretty-arglist (car methods))
+ (dolist (m (cdr methods))
+ (multiple-value-bind (method-key-keywords
+ method-allow-other-keys
+ method-key)
+ (function-keywords m)
+ ;; we've modified function-keywords to return what we want as
+ ;; the third value, no other change here.
+ (declare (ignore method-key-keywords))
+ (setq key (union key method-key))
+ (setq allow-other-keys (or allow-other-keys
+ method-allow-other-keys))))
+ (when allow-other-keys
+ (setq arglist '(&allow-other-keys)))
+ (when key
+ (setq arglist (nconc (list '&key) key arglist)))
+ (when rest
+ (setq arglist (nconc (list '&rest rest) arglist)))
+ (when optional
+ (setq arglist (nconc (list '&optional) optional arglist)))
+ (nconc required arglist)))
+ ;; otherwise we take the lambda-list from the GF directly, with no
+ ;; other 'keys' added ...
+ (let ((lambda-list (generic-function-lambda-list generic-function)))
+ lambda-list))))
(defmethod method-pretty-arglist ((method standard-method))
(let ((required ())
projects / sbcl.git / blobdiff