X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=083dfc44e3daa2a4445b61e6dc007615e680857c;hb=cce46771e6d734c275f3e2d5620004da3b5d09ee;hp=f8df4fd31dd93a4064f35c147da709cf210db665;hpb=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f8df4fd..083dfc4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -78,19 +78,9 @@ bootstrapping. ;;; then things break.) (declaim (declaration class)) -;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a -;;; separate function. Instead, we should define a simple placeholder -;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where -;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just -;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY -;;; overwrite it. -(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook) - #'check-wrapper-validity) - (declaim (notinline make-a-method add-named-method ensure-generic-function-using-class - add-method remove-method)) @@ -162,6 +152,7 @@ bootstrapping. (error 'simple-program-error :format-control "illegal generic function name ~S" :format-arguments (list fun-name))) + (check-gf-lambda-list lambda-list) (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) @@ -174,18 +165,57 @@ bootstrapping. (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) - (generic-function-initial-methods #',fun-name))))) + (generic-function-initial-methods (fdefinition ',fun-name)))))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) (case car-option (declare - (push (cdr option) (initarg :declarations))) - ((:argument-precedence-order :method-combination) - (if (initarg car-option) - (duplicate-option car-option) - (setf (initarg car-option) - `',(cdr option)))) + (when (and + (consp (cadr option)) + (member (first (cadr option)) + ;; FIXME: this list is slightly weird. + ;; ANSI (on the DEFGENERIC page) in one + ;; place allows only OPTIMIZE; in + ;; another place gives this list of + ;; disallowed declaration specifiers. + ;; This seems to be the only place where + ;; the FUNCTION declaration is + ;; mentioned; TYPE seems to be missing. + ;; Very strange. -- CSR, 2002-10-21 + '(declaration ftype function + inline notinline special))) + (error 'simple-program-error + :format-control "The declaration specifier ~S ~ + is not allowed inside DEFGENERIC." + :format-arguments (list (cadr option)))) + (push (cadr option) (initarg :declarations))) + (:method-combination + (when (initarg car-option) + (duplicate-option car-option)) + (unless (symbolp (cadr option)) + (error 'simple-program-error + :format-control "METHOD-COMBINATION name not a ~ + symbol: ~S" + :format-arguments (list (cadr option)))) + (setf (initarg car-option) + `',(cdr option))) + (:argument-precedence-order + (let* ((required (parse-lambda-list lambda-list)) + (supplied (cdr option))) + (unless (= (length required) (length supplied)) + (error 'simple-program-error + :format-control "argument count discrepancy in ~ + :ARGUMENT-PRECEDENCE-ORDER clause." + :format-arguments nil)) + (when (set-difference required supplied) + (error 'simple-program-error + :format-control "unequal sets for ~ + :ARGUMENT-PRECEDENCE-ORDER clause: ~ + ~S and ~S" + :format-arguments (list required supplied))) + (setf (initarg car-option) + `',(cdr option)))) ((:documentation :generic-function-class :method-class) (unless (proper-list-of-length-p option 2) (error "bad list length for ~S" option)) @@ -209,19 +239,19 @@ bootstrapping. (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) - #',fun-name)))) + (fdefinition ',fun-name))))) (defun compile-or-load-defgeneric (fun-name) - (sb-kernel:proclaim-as-fun-name fun-name) - (sb-kernel:note-name-defined fun-name :function) + (proclaim-as-fun-name fun-name) + (note-name-defined fun-name :function) (unless (eq (info :function :where-from fun-name) :declared) (setf (info :function :where-from fun-name) :defined) (setf (info :function :type fun-name) - (sb-kernel:specifier-type 'function)))) + (specifier-type 'function)))) (defun load-defgeneric (fun-name lambda-list &rest initargs) (when (fboundp fun-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name) + (style-warn "redefining ~S in DEFGENERIC" fun-name) (let ((fun (fdefinition fun-name))) (when (generic-function-p fun) (loop for method in (generic-function-initial-methods fun) @@ -230,8 +260,52 @@ bootstrapping. (apply #'ensure-generic-function fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-truename*) + :definition-source `((defgeneric ,fun-name) ,*load-pathname*) initargs)) + +(define-condition generic-function-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 2))))) + +(defun check-gf-lambda-list (lambda-list) + (flet ((ensure (arg ok) + (unless ok + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) + (multiple-value-bind (required optional restp rest keyp keys allowp + auxp aux morep more-context more-count) + (parse-lambda-list lambda-list) + (declare (ignore required)) ; since they're no different in a gf ll + (declare (ignore restp rest)) ; since they're no different in a gf ll + (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way + (declare (ignore aux)) ; since we require AUXP=NIL + (declare (ignore more-context more-count)) ; safely ignored unless MOREP + ;; no defaults allowed for &OPTIONAL arguments + (dolist (i optional) + (ensure i (or (symbolp i) + (and (consp i) (symbolp (car i)) (null (cdr i)))))) + ;; no defaults allowed for &KEY arguments + (when keyp + (dolist (i keys) + (ensure i (or (symbolp i) + (and (consp i) + (or (symbolp (car i)) + (and (consp (car i)) + (symbolp (caar i)) + (symbolp (cadar i)) + (null (cddar i)))) + (null (cdr i))))))) + ;; no &AUX allowed + (when auxp + (error "&AUX is not allowed in a generic function lambda list: ~S" + lambda-list)) + ;; Oh, *puhlease*... not specifically as per section 3.4.2 of + ;; the ANSI spec, but the CMU CL &MORE extension does not + ;; belong here! + (aver (not morep))))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) @@ -282,11 +356,6 @@ bootstrapping. (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) -(defvar *optimize-asv-funcall-p* nil) -(defvar *asv-readers*) -(defvar *asv-writers*) -(defvar *asv-boundps*) - (defun expand-defmethod (name proto-gf proto-method @@ -294,53 +363,43 @@ bootstrapping. lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*optimize-asv-funcall-p* t) - (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) - (declare (special *make-instance-function-keys*)) - (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) - (add-method-declarations name qualifiers lambda-list body env) - (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic - ;; function here, since ANSI specifies that we create it - ;; if it does not exist. However, I chose not to, because - ;; I think it's more useful to support a style of - ;; programming where every generic function has an - ;; explicit DEFGENERIC and any typos in DEFMETHODs are - ;; warned about. Otherwise - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall - ;; through to VECTOR) but still doesn't do what was - ;; intended. I hate that kind of bug (code which silently - ;; gives the wrong answer), so we don't do a DECLAIM - ;; here. -- WHN 20000229 - ,@(when *make-instance-function-keys* - `((get-make-instance-functions - ',*make-instance-function-keys*))) - ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) - `((initialize-internal-slot-gfs* - ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol)))))))) + (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) + (add-method-declarations name qualifiers lambda-list body env) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form proto-gf + proto-method + method-function-lambda + initargs + env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs :plist) + :pv-table-symbol))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -377,23 +436,15 @@ bootstrapping. specializers)) (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) - ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil) - ;; (We bind *PACKAGE* to - ;; KEYWORD here as a way to - ;; force symbols to be printed - ;; with explicit package - ;; prefixes.) - (*package* *keyword-package*)) - (format nil "~S" mname))))) + ,name ,@qualifiers ,specls))) `(progn - (defun ,mname-sym ,(cadr fn-lambda) + (defun ,mname ,(cadr fn-lambda) ,@(cddr fn-lambda)) ,(make-defmethod-form-internal name qualifiers `',specls unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) - #',mname-sym + #',mname ,@(cdddr initargs-form)) pv-table-symbol))) (make-defmethod-form-internal @@ -401,7 +452,7 @@ bootstrapping. `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) - ,,(cadr specializer)) + ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list @@ -440,11 +491,11 @@ bootstrapping. env)))) (defun add-method-declarations (name qualifiers lambda-list body env) + (declare (ignore env)) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) - (declare (ignore parameters)) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body env) + (multiple-value-bind (real-body declarations documentation) + (parse-body body) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) ;; (Old PCL code used a somewhat different style of @@ -462,6 +513,13 @@ bootstrapping. ;; another declaration (e.g. %BLOCK-NAME), so that ;; our method debug names are free to have any format, ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). + ;; + ;; Further, as of sbcl-0.7.9.10, the code to + ;; implement NO-NEXT-METHOD is coupled to the form of + ;; this declaration; see the definition of + ;; CALL-NO-NEXT-METHOD (and the passing of + ;; METHOD-NAME-DECLARATION arguments around the + ;; various CALL-NEXT-METHOD logic). (declare (%method-name (,name ,@qualifiers ,specializers))) @@ -541,17 +599,46 @@ bootstrapping. ;; second argument.) Hopefully it only does this kind of ;; weirdness when bootstrapping.. -- WHN 20000610 '(ignorable)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(ignorable)) (t - ;; Otherwise, we can make Python very happy. - `(type ,specializer ,parameter)))) + ;; Otherwise, we can usually make Python very happy. + (let ((type (info :type :kind specializer))) + (ecase type + ((:primitive :defined :instance :forthcoming-defclass-type) + `(type ,specializer ,parameter)) + ((nil) + (let ((class (find-class specializer nil))) + (if class + `(type ,(class-name class) ,parameter) + (progn + ;; we can get here, and still not have a failure + ;; case, by doing MOP programming like (PROGN + ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) + ;; ...)). Best to let the user know we haven't + ;; been able to extract enough information: + (style-warn + "~@" + specializer + 'parameter-specializer-declaration-in-defmethod) + '(ignorable)))))))))) (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 (documentation declarations real-body) - (extract-declarations (cddr method-lambda) env) + (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))) @@ -585,8 +672,9 @@ bootstrapping. ;; it can avoid run-time type dispatch overhead, ;; which can be a huge win for Python.) ;; - ;; FIXME: Perhaps these belong in - ;; ADD-METHOD-DECLARATIONS instead of here? + ;; 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))) @@ -632,16 +720,18 @@ bootstrapping. ((eq p '&aux) (return nil)))))) (multiple-value-bind - (walked-lambda call-next-method-p closurep next-method-p-p) + (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 - (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) + (multiple-value-bind (walked-lambda-body + walked-declarations + walked-documentation) + (parse-body (cddr walked-lambda)) + (declare (ignore walked-documentation)) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p t plist))) (when (some #'cdr slots) @@ -672,6 +762,15 @@ bootstrapping. :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 @@ -703,29 +802,47 @@ bootstrapping. rest-arg &rest lmf-options) &body body) - `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) - (bind-lexical-method-functions (,@lmf-options) - (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) - ,@body)))) + `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) + (bind-lexical-method-functions (,@lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body)))) (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) `(macrolet ((call-next-method-bind (&body body) - `(let ((.next-method. (car ,',next-methods)) - (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods - ,@body)) - (call-next-method-body (cnm-args) - `(if .next-method. - (funcall (if (std-instance-p .next-method.) - (method-function .next-method.) - .next-method.) ; for early methods - (or ,cnm-args ,',method-args) - ,',next-methods) - (error "no next method"))) + `(let ((.next-method. (car ,',next-methods)) + (,',next-methods (cdr ,',next-methods))) + .next-method. ,',next-methods + ,@body)) + (call-next-method-body (method-name-declaration cnm-args) + `(if .next-method. + (funcall (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.) ; for early methods + (or ,cnm-args ,',method-args) + ,',next-methods) + (apply #'call-no-next-method ',method-name-declaration + (or ,cnm-args ,',method-args)))) (next-method-p-body () - `(not (null .next-method.)))) - ,@body)) + `(not (null .next-method.))) + (with-rebound-original-args ((call-next-method-p setq-p) + &body body) + (declare (ignore call-next-method-p setq-p)) + `(let () ,@body))) + ,@body)) + +(defun call-no-next-method (method-name-declaration &rest args) + (destructuring-bind (name) method-name-declaration + (destructuring-bind (name &rest qualifiers-and-specializers) name + ;; KLUDGE: inefficient traversal, but hey. This should only + ;; happen on the slow error path anyway. + (let* ((qualifiers (butlast qualifiers-and-specializers)) + (specializers (car (last qualifiers-and-specializers))) + (method (find-method (gdefinition name) qualifiers specializers))) + (apply #'no-next-method + (method-generic-function method) + method + args))))) (defstruct (method-call (:copier nil)) (function #'identity :type function) @@ -771,11 +888,8 @@ bootstrapping. #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp)) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defvar *allow-emf-call-tracing-p* nil) -(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) - -) ; EVAL-WHEN + (defvar *allow-emf-call-tracing-p* nil) + (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t)) ;;;; effective method functions @@ -825,26 +939,25 @@ bootstrapping. &rest required-args+rest-arg) (unless (constantp restp) (error "The RESTP argument is not constant.")) + ;; FIXME: The RESTP handling here is confusing and maybe slightly + ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if + ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) + ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. (setq restp (eval restp)) - `(locally - - ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings - ;; about type mismatches in unreachable code when we - ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and - ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline - ;; function instead of a macro, which seems sufficient to solve - ;; the problem all by itself (probably because of some quirk in - ;; the relative order of expansion and type inference) but we - ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it - ;; looks as though (1) inlining isn't that much of a win anyway, - ;; and (2a) once you miss the FAST-METHOD-CALL clause you're - ;; going to be slow anyway, but (2b) code bloat still hurts even - ;; when it's off the critical path. - (declare (notinline get-slots-or-nil)) - + `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + ;; "What," you may wonder, "do these next two clauses do?" + ;; In that case, you are not a PCL implementor, for they + ;; considered this to be self-documenting.:-| Or CSR, for + ;; that matter, since he can also figure it out by looking + ;; at it without breaking stride. For the rest of us, + ;; though: From what the code is doing with .SLOTS. and + ;; whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards + ;; and conclude that setting EMF to a FIXNUM is an + ;; optimized way to represent these slot access operations. ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let* ((.slots. (get-slots-or-nil @@ -858,19 +971,13 @@ bootstrapping. `(((typep ,emf 'fixnum) (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - #|| - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fast-instance-boundp) - (let ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) - (and .slots. - (not (eq (clos-slots-ref - .slots. (fast-instance-boundp-index ,emf)) - +slot-unbound+))))))) - ||# + ,(cadr required-args+rest-arg)))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) + ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN + ;; ...) clause here to handle SLOT-BOUNDish stuff. Since + ;; there was no explanation and presumably the code is 10+ + ;; years stale, I simply deleted it. -- WHN) (t (etypecase ,emf (method-call @@ -937,94 +1044,109 @@ bootstrapping. +slot-unbound+))))) (function (apply emf args)))) - -;; KLUDGE: A comment from the original PCL said "This can be improved alot." -(defun gf-make-function-from-emf (gf emf) - (etypecase emf - (fast-method-call (let* ((arg-info (gf-arg-info gf)) - (nreq (arg-info-number-required arg-info)) - (restp (arg-info-applyp arg-info))) - (lambda (&rest args) - (trace-emf-call emf t args) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args - rest-args))) - (nconc req-args rest-args)) - args))))) - (method-call (lambda (&rest args) - (trace-emf-call emf t args) - (apply (method-call-function emf) - args - (method-call-call-method-args emf)))) - (function emf))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) - `(macrolet ((call-next-method-bind (&body body) - `(let () ,@body)) - (call-next-method-body (cnm-args) - `(if ,',next-method-call - ,(locally - ;; This declaration suppresses a "deleting - ;; unreachable code" note for the following IF when - ;; REST-ARG is NIL. It is not nice for debugging - ;; SBCL itself, but at least it keeps us from - ;; annoying users. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - ,',next-method-call nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - ,',next-method-call - ,',(not (null rest-arg)) - ,@',args - ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) - ,cnm-args) - ,call) - ,call)))) - (error "no next method"))) - (next-method-p-body () - `(not (null ,',next-method-call)))) - ,@body)) + (let* ((all-params (append args (when rest-arg (list rest-arg)))) + (rebindings (mapcar (lambda (x) (list x x)) all-params))) + `(macrolet ((narrowed-emf (emf) + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to + ;; dispatch on the possibility that EMF might be of + ;; type FIXNUM (as an optimized representation of a + ;; slot accessor). But as far as I (WHN 2002-06-11) + ;; can tell, it's impossible for such a representation + ;; to end up as .NEXT-METHOD-CALL. By reassuring + ;; INVOKE-E-M-F that when called from this context + ;; it needn't worry about the FIXNUM case, we can + ;; keep those cases from being compiled, which is + ;; good both because it saves bytes and because it + ;; avoids annoying type mismatch compiler warnings. + ;; + ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type + ;; system isn't smart enough about NOT and + ;; intersection types to benefit from a (NOT FIXNUM) + ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe + ;; it is now... -- CSR, 2003-06-07) + ;; + ;; FIXME: Might the FUNCTION type be omittable here, + ;; leaving only METHOD-CALLs? Failing that, could this + ;; be documented somehow? (It'd be nice if the types + ;; involved could be understood without solving the + ;; halting problem.) + `(the (or function method-call fast-method-call) + ,emf)) + (call-next-method-bind (&body body) + `(let () ,@body)) + (call-next-method-body (method-name-declaration cnm-args) + `(if ,',next-method-call + ,(locally + ;; This declaration suppresses a "deleting + ;; unreachable code" note for the following IF + ;; when REST-ARG is NIL. It is not nice for + ;; debugging SBCL itself, but at least it + ;; keeps us from annoying users. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args + ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call)))) + ,(locally + ;; As above, this declaration suppresses code + ;; deletion notes. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(call-no-next-method ',method-name-declaration + ,@(cdr cnm-args)) + `(call-no-next-method ',method-name-declaration + ,@',args + ,@',(when rest-arg + `(,rest-arg))))))) + (next-method-p-body () + `(not (null ,',next-method-call))) + (with-rebound-original-args ((cnm-p setq-p) &body body) + (if (or cnm-p setq-p) + `(let ,',rebindings + (declare (ignorable ,@',all-params)) + ,@body) + `(let () ,@body)))) + ,@body))) (defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p closurep applyp) + ((&key call-next-method-p next-method-p-p setq-p + closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) - (null applyp)) + (null closurep) (null applyp) (null setq-p)) `(let () ,@body)) - ((and (null closurep) - (null applyp)) - ;; OK to use MACROLET, and all args are mandatory - ;; (else APPLYP would be true). - `(call-next-method-bind - (macrolet ((call-next-method (&rest cnm-args) - `(call-next-method-body ,(when cnm-args - `(list ,@cnm-args)))) - (next-method-p () - `(next-method-p-body))) - ,@body))) (t `(call-next-method-bind (flet (,@(and call-next-method-p - '((call-next-method (&rest cnm-args) - (call-next-method-body cnm-args)))) + `((call-next-method (&rest cnm-args) + (call-next-method-body + ,method-name-declaration + cnm-args)))) ,@(and next-method-p-p '((next-method-p () - (next-method-p-body))))) - ,@body))))) + (next-method-p-body))))) + (with-rebound-original-args (,call-next-method-p ,setq-p) + ,@body)))))) (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) @@ -1060,8 +1182,9 @@ bootstrapping. ,(cadr var))))))) (rest `((,var ,args-tail))) (key (cond ((not (consp var)) - `((,var (get-key-arg ,(keywordicate var) - ,args-tail)))) + `((,var (car + (get-key-arg-tail ,(keywordicate var) + ,args-tail))))) ((null (cddr var)) (multiple-value-bind (keyword variable) (if (consp (car var)) @@ -1069,8 +1192,9 @@ bootstrapping. (cadar var)) (values (keywordicate (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) - (,variable (if (consp ,key) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,variable (if ,key (car ,key) ,(cadr var)))))) (t @@ -1080,35 +1204,42 @@ bootstrapping. (cadar var)) (values (keywordicate (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) (,(caddr var) ,key) - (,variable (if (consp ,key) + (,variable (if ,key (car ,key) ,(cadr var)))))))) (aux `(,var)))))) (let ((bindings (mapcan #'process-var lambda-list))) `(let* ((,args-tail ,args) - ,@bindings) - (declare (ignorable ,args-tail)) + ,@bindings + (.dummy0. + ,@(when (eq state 'optional) + `((unless (null ,args-tail) + (error 'simple-program-error + :format-control "surplus arguments: ~S" + :format-arguments (list ,args-tail))))))) + (declare (ignorable ,args-tail .dummy0.)) ,@body))))) -(defun get-key-arg (keyword list) - (loop (when (atom list) (return nil)) - (when (eq (car list) keyword) (return (cadr list))) - (setq list (cddr list)))) - -(defun get-key-arg1 (keyword list) - (loop (when (atom list) (return nil)) - (when (eq (car list) keyword) (return (cdr list))) - (setq list (cddr list)))) +(defun get-key-arg-tail (keyword list) + (loop for (key . tail) on list by #'cddr + when (null tail) do + ;; FIXME: Do we want to export this symbol? Or maybe use an + ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? + (sb-c::%odd-key-args-error) + when (eq key keyword) + return tail)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD ; should be in the method definition (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD ; was seen in the body of a method - (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P + (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P ; should be in the method definition + (setq-p nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used @@ -1123,6 +1254,17 @@ bootstrapping. ((eq (car form) 'next-method-p) (setq next-method-p-p t) form) + ((eq (car form) 'setq) + ;; FIXME: this is possibly a little strong as + ;; conditions go. Ideally we would want to detect + ;; which, if any, of the method parameters are + ;; being set, and communicate that information to + ;; e.g. SPLIT-DECLARATIONS. However, the brute + ;; force method doesn't really cost much; a little + ;; loss of discrimination over IGNORED variables + ;; should be all. -- CSR, 2004-07-01 + (setq setq-p t) + form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p t) @@ -1153,20 +1295,14 @@ bootstrapping. ((generic-function-name-p (car form)) (optimize-generic-function-call form required-parameters env slots calls)) - ((and (eq (car form) 'asv-funcall) - *optimize-asv-funcall-p*) - (case (fourth form) - (reader (push (third form) *asv-readers*)) - (writer (push (third form) *asv-writers*)) - (boundp (push (third form) *asv-boundps*))) - `(,(second form) ,@(cddddr form))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) (values walked-lambda call-next-method-p closurep - next-method-p-p))))) + next-method-p-p + setq-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) @@ -1246,19 +1382,20 @@ bootstrapping. (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) (method (and (generic-function-p gf) + (generic-function-methods gf) (find-method gf qualifiers (parse-specializers specializers) nil)))) (when method - (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" - gf-spec qualifiers specializers)))) + (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" + gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) - ,*load-truename*) + ,*load-pathname*) initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) @@ -1292,20 +1429,7 @@ bootstrapping. (when mf (setq mf (set-fun-name mf method-spec))) (when mff - (let ((name `(,(or (get (car method-spec) 'fast-sym) - (setf (get (car method-spec) 'fast-sym) - ;; KLUDGE: If we're going to be - ;; interning private symbols in our - ;; a this way, it would be cleanest - ;; to use a separate package - ;; %PCL-PRIVATE or something, and - ;; failing that, to use a special - ;; symbol prefix denoting privateness. - ;; -- WHN 19991201 - (intern (format nil "FAST-~A" - (car method-spec)) - *pcl-package*))) - ,@(cdr method-spec)))) + (let ((name `(fast-method ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -1380,15 +1504,15 @@ bootstrapping. (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead? - (old-ftype (if (sb-kernel:fun-type-p old) old nil)) - (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype))) + (old-ftype (if (fun-type-p old) old nil)) + (old-restp (and old-ftype (fun-type-rest old-ftype))) (old-keys (and old-ftype - (mapcar #'sb-kernel:key-info-name - (sb-kernel:fun-type-keywords + (mapcar #'key-info-name + (fun-type-keywords old-ftype)))) - (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype))) + (old-keysp (and old-ftype (fun-type-keyp old-ftype))) (old-allowp (and old-ftype - (sb-kernel:fun-type-allowp old-ftype))) + (fun-type-allowp old-ftype))) (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) `(function ,(append (make-list nrequired :initial-element t) (when (plusp noptional) @@ -1406,8 +1530,6 @@ bootstrapping. *)))) (defun defgeneric-declaration (spec lambda-list) - (when (consp spec) - (setq spec (get-setf-fun-name (cadr spec)))) `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) ;;;; early generic function support @@ -1507,11 +1629,17 @@ bootstrapping. ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) - (let ((valsym (gensym "value"))) + (with-unique-names (valsym) `(let ((,valsym ,val)) (unless (equal ,pos ,valsym) (setf ,pos ,valsym))))) +(defun create-gf-lambda-list (lambda-list) + ;;; Create a gf lambda list from a method lambda list + (loop for x in lambda-list + collect (if (consp x) (list (car x)) x) + if (eq x '&key) do (loop-finish))) + (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) @@ -1539,8 +1667,10 @@ bootstrapping. (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) - (when lambda-list-p - (esetf (arg-info-lambda-list arg-info) lambda-list)) + (esetf (arg-info-lambda-list arg-info) + (if lambda-list-p + lambda-list + (create-gf-lambda-list lambda-list))) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) (esetf (arg-info-precedence arg-info) @@ -1564,12 +1694,11 @@ bootstrapping. (early-method-lambda-list method) (method-lambda-list method))) (flet ((lose (string &rest args) - (error - "attempt to add the method ~S to the generic function ~S.~%~ - But ~A" - method - gf - (apply #'format nil string args))) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list method gf string args))) (comparison-description (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) @@ -1585,14 +1714,14 @@ bootstrapping. "the method has ~A optional arguments than the generic function." (comparison-description nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) - (error - "The method and generic function differ in whether they accept~%~ + (lose + "the method and generic function differ in whether they accept~_~ &REST or &KEY arguments.")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the &KEY arguments~%~ + (lose "the method does not accept each of the &KEY arguments~2I~_~ ~S." gf-keywords))))))) @@ -1644,12 +1773,21 @@ bootstrapping. (generic-function-name gf) (!early-gf-name gf)))) (esetf (gf-precompute-dfun-and-emf-p arg-info) - (let* ((sym (if (atom name) name (cadr name))) - (pkg-list (cons *pcl-package* - (package-use-list *pcl-package*)))) - (and sym (symbolp sym) - (not (null (memq (symbol-package sym) pkg-list))) - (not (find #\space (symbol-name sym)))))))) + (cond + ((and (consp name) + (member (car name) + *internal-pcl-generalized-fun-name-symbols*)) + nil) + (t (let* ((symbol (fun-name-block-name name)) + (package (symbol-package symbol))) + (and (or (eq package *pcl-package*) + (memq package (package-use-list *pcl-package*))) + ;; FIXME: this test will eventually be + ;; superseded by the *internal-pcl...* test, + ;; above. While we are in a process of + ;; transition, however, it should probably + ;; remain. + (not (find #\Space (symbol-name symbol)))))))))) (esetf (gf-info-fast-mf-p arg-info) (or (not (eq *boot-state* 'complete)) (let* ((method-class (generic-function-method-class gf)) @@ -1678,13 +1816,17 @@ bootstrapping. (defun ensure-generic-function-using-class (existing spec &rest keys &key (lambda-list nil lambda-list-p) + argument-precedence-order &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) + (when lambda-list-p + (set-arg-info existing :lambda-list lambda-list)) existing) ((assoc spec *!generic-function-fixups* :test #'equal) (if existing - (make-early-gf spec lambda-list lambda-list-p existing) + (make-early-gf spec lambda-list lambda-list-p existing + argument-precedence-order) (error "The function ~S is not already defined." spec))) (existing (error "~S should be on the list ~S." @@ -1692,18 +1834,20 @@ bootstrapping. '*!generic-function-fixups*)) (t (pushnew spec *!early-generic-functions* :test #'equal) - (make-early-gf spec lambda-list lambda-list-p)))) + (make-early-gf spec lambda-list lambda-list-p nil + argument-precedence-order)))) -(defun make-early-gf (spec &optional lambda-list lambda-list-p function) +(defun make-early-gf (spec &optional lambda-list lambda-list-p + function argument-precedence-order) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) - (set-funcallable-instance-fun + (set-funcallable-instance-function fin (or function (if (eq spec 'print-object) - #'(sb-kernel:instance-lambda (instance stream) + #'(instance-lambda (instance stream) (print-unreadable-object (instance stream :identity t) (format stream "std-instance"))) - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ has not been set." fin))))) @@ -1712,13 +1856,17 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-truename*) + *load-pathname*) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p (proclaim (defgeneric-declaration spec lambda-list)) - (set-arg-info fin :lambda-list lambda-list))) + (if argument-precedence-order + (set-arg-info fin + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info fin :lambda-list lambda-list)))) fin)) (defun set-dfun (gf &optional dfun cache info) @@ -1770,11 +1918,8 @@ bootstrapping. (let* ((method (car (last methods))) (ll (if (consp method) (early-method-lambda-list method) - (method-lambda-list method))) - (k (member '&key ll))) - (if k - (append (ldiff ll (cdr k)) '(&allow-other-keys)) - ll)))) + (method-lambda-list method)))) + (create-gf-lambda-list ll)))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) @@ -1797,7 +1942,7 @@ bootstrapping. (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (find-class method-class t ,env)))))) (defun real-ensure-gf-using-class--generic-function (existing @@ -2145,11 +2290,10 @@ bootstrapping. gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-fun-name - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method)))) + (make-method-spec temp + (method-qualifiers method) + (unparse-specializers + (method-specializers method))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) @@ -2163,9 +2307,8 @@ bootstrapping. (and (setq method (get-method gf quals specls errorp)) (setq name - (intern-fun-name (make-method-spec gf-spec - quals - specls)))))))) + (make-method-spec + gf-spec quals (unparse-specializers specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) @@ -2192,19 +2335,38 @@ bootstrapping. (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) -(defun parse-specialized-lambda-list (arglist &optional post-keyword) - ;;(declare (values parameters lambda-list specializers required-parameters)) +(define-condition specialized-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 3))))) + +(defun parse-specialized-lambda-list + (arglist + &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) + &aux (specialized-lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux))) (let ((arg (car arglist))) (cond ((null arglist) (values nil nil nil nil)) ((eq arg '&aux) - (values nil arglist nil)) + (values nil arglist nil nil)) ((memq arg lambda-list-keywords) - (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) - ;; Now, since we try to conform to ANSI, non-standard - ;; lambda-list-keywords should be treated as errors. - (error 'simple-program-error - :format-control "unrecognized lambda-list keyword ~S ~ - in arglist.~%" + ;; non-standard lambda-list-keywords are errors. + (unless (memq arg specialized-lambda-list-keywords) + (error 'specialized-lambda-list-error + :format-control "unknown specialized-lambda-list ~ + keyword ~S~%" + :format-arguments (list arg))) + ;; no multiple &rest x &rest bla specifying + (when (memq arg supplied-keywords) + (error 'specialized-lambda-list-error + :format-control "multiple occurrence of ~ + specialized-lambda-list keyword ~S~%" + :format-arguments (list arg))) + ;; And no placing &key in front of &optional, either. + (unless (memq arg allowed-keywords) + (error 'specialized-lambda-list-error + :format-control "misplaced specialized-lambda-list ~ + keyword ~S~%" :format-arguments (list arg))) ;; When we are at a lambda-list keyword, the parameters ;; don't include the lambda-list keyword; the lambda-list @@ -2212,22 +2374,34 @@ bootstrapping. ;; specializers are allowed to follow the lambda-list ;; keywords (at least for now). (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) t) - (when (eq arg '&rest) - ;; check, if &rest is followed by a var ... - (when (or (null lambda-list) - (memq (car lambda-list) lambda-list-keywords)) - (error "Error in lambda-list:~%~ - After &REST, a DEFMETHOD lambda-list ~ - must be followed by at least one variable."))) + (parse-specialized-lambda-list (cdr arglist) + (cons arg supplied-keywords) + (if (eq arg '&key) + (cons '&allow-other-keys + (cdr (member arg allowed-keywords))) + (cdr (member arg allowed-keywords)))) + (when (and (eq arg '&rest) + (or (null lambda-list) + (memq (car lambda-list) + specialized-lambda-list-keywords) + (not (or (null (cadr lambda-list)) + (memq (cadr lambda-list) + specialized-lambda-list-keywords))))) + (error 'specialized-lambda-list-error + :format-control + "in a specialized-lambda-list, excactly one ~ + variable must follow &REST.~%" + :format-arguments nil)) (values parameters (cons arg lambda-list) () ()))) - (post-keyword + (supplied-keywords ;; After a lambda-list keyword there can be no specializers. (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) t) + (parse-specialized-lambda-list (cdr arglist) + supplied-keywords + allowed-keywords) (values (cons (if (listp arg) (car arg) arg) parameters) (cons arg lambda-list) ()