(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))
(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)
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)
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))
+ (eq (car constant) :mcase))
(let ((alist (mapcar (lambda (k+m)
(cons (car k+m)
(convert-methods (cdr k+m)
(format t "~&make-unordered-methods-emf ~S~%"
(generic-function-name generic-function)))
(lambda (&rest args)
- (let* ((types (types-from-arguments generic-function args 'eql))
+ (let* ((types (types-from-args generic-function args 'eql))
(smethods (sort-applicable-methods generic-function
methods
types))
;;; 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 ())