;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
- slot-names &key)
- (declare (ignore slot-names))
- (with-slots (allocation class)
- slotd
- (setq allocation (if (eq allocation :class) class allocation))))
-
-(defmethod shared-initialize :after ((slotd structure-slot-definition)
- slot-names
- &key (allocation :instance))
- (declare (ignore slot-names))
- (unless (eq allocation :instance)
- (error "Structure slots must have :INSTANCE allocation.")))
-
-(defmethod inform-type-system-about-class ((class structure-class) (name t))
- nil)
;;; methods
;;;
(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:~%~
(cond ((or (null (fboundp generic-function-name))
(not (generic-function-p
(setq generic-function
- (symbol-function generic-function-name)))))
+ (fdefinition generic-function-name)))))
(error "~S does not name a generic function."
generic-function-name))
((null (setq method (get-method generic-function
lambda-list
&rest other-initargs)
(unless (and (fboundp generic-function-name)
- (typep (symbol-function generic-function-name)
- 'generic-function))
- (sb-kernel::style-warn "implicitly creating new generic function ~S"
- generic-function-name))
+ (typep (fdefinition generic-function-name) 'generic-function))
+ (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 types-from-arguments (generic-function arguments
- &optional type-modifier)
+
+(defun error-need-at-least-n-args (function n)
+ (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
+ function
+ n))
+
+(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)
i
(unless arguments
- (error "The function ~S requires at least ~D arguments"
- (generic-function-name generic-function)
- nreq))
+ (error-need-at-least-n-args (generic-function-name generic-function)
+ nreq))
(let ((arg (pop arguments)))
(push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
(values (nreverse types-rev) arg-info))))
(defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
(let* ((w wrappers) (w-tail w) (mt-tail metatypes))
(dolist (class (if (listp classes) classes (list classes)))
- (unless (eq 't (car mt-tail))
+ (unless (eq t (car mt-tail))
(let ((c-w (class-wrapper class)))
(unless c-w (return-from get-wrappers-from-classes nil))
(if (eql nkeys 1)
: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))
(defmacro class-test (arg class)
(cond ((eq class *the-class-t*)
- '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)
- (if (or (atom type) (eq (car type) 't))
+ (if (or (atom type) (eq (car type) t))
*the-class-t*
(case (car type)
(and (dolist (type (cdr type) *the-class-t*)
(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).
(defun augment-type (new-type known-type)
- (if (or (eq known-type 't)
+ (if (or (eq known-type t)
(eq (car new-type) 'eql))
new-type
(let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
(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))
(if p-tail
(let* ((position (car p-tail))
(known-type (or (nth position types) t)))
- (if (eq (nth position metatypes) 't)
+ (if (eq (nth position metatypes) t)
(do-column (cdr p-tail) contenders
(cons (cons position known-type)
known-types))
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 ()))))
(defvar *case-table-limit* 10)
(defun compute-mcase-parameters (case-list)
- (unless (eq 't (caar (last case-list)))
+ (unless (eq t (caar (last case-list)))
(error "The key for the last case arg to mcase was not T"))
(let* ((eq-p (dolist (case case-list t)
- (unless (or (eq (car case) 't)
+ (unless (or (eq (car case) t)
(symbolp (caar case)))
(return nil))))
(len (1- (length case-list)))
(list eq-p type)))
(defmacro mlookup (key info default &optional eq-p type)
- (unless (or (eq eq-p 't) (null eq-p))
+ (unless (or (eq eq-p t) (null eq-p))
(error "Invalid eq-p argument"))
(ecase type
(:simple
(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-function). 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-function
;;; 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-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 ())
(state 'required)
(arglist (method-lambda-list method)))
(dolist (arg arglist)
- (cond ((eq arg '&optional) (setq state 'optional))
- ((eq arg '&rest) (setq state 'rest))
- ((eq arg '&key) (setq state 'key))
- ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
- ((memq arg lambda-list-keywords))
+ (cond ((eq arg '&optional) (setq state 'optional))
+ ((eq arg '&rest) (setq state 'rest))
+ ((eq arg '&key) (setq state 'key))
+ ((eq arg '&allow-other-keys) (setq allow-other-keys t))
+ ((memq arg lambda-list-keywords))
(t
(ecase state
(required (push arg required))