X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=09719c948cf2de5b6342ce9764de5c05316e75ff;hb=1eec7e16cc38e8eba97364ef2d2af1b089764016;hp=221647a8d02ede23071d8c3bd91cf5bd0c3aec73;hpb=89eb73c035f05ae53b1148ef8a83e1d4030b2dd8;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 221647a..09719c9 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)) @@ -157,6 +147,12 @@ bootstrapping. standard-compute-effective-method)))) (defmacro defgeneric (fun-name lambda-list &body options) + (declare (type list lambda-list)) + (unless (legal-fun-name-p fun-name) + (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) @@ -168,13 +164,32 @@ bootstrapping. (arglist (elt qab arglist-pos)) (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) - `(defmethod ,fun-name ,@qualifiers ,arglist ,@body)))) + `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) + (generic-function-initial-methods #',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))) + (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))) ((:argument-precedence-order :method-combination) (if (initarg car-option) (duplicate-option car-option) @@ -202,8 +217,8 @@ bootstrapping. (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) - ,@(mapcar #'expand-method-definition methods) - `,(function ,fun-name))))) + ,@(mapcar #'expand-method-definition methods) + #',fun-name)))) (defun compile-or-load-defgeneric (fun-name) (sb-kernel:proclaim-as-fun-name fun-name) @@ -215,12 +230,61 @@ bootstrapping. (defun load-defgeneric (fun-name lambda-list &rest initargs) (when (fboundp fun-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)) + (sb-kernel::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) + do (remove-method fun method)) + (setf (generic-function-initial-methods fun) '())))) (apply #'ensure-generic-function - fun-name - :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-truename*) - initargs)) + fun-name + :lambda-list lambda-list + :definition-source `((defgeneric ,fun-name) ,*load-pathname*) + initargs)) + +;;; As per section 3.4.2 of the ANSI spec, generic function lambda +;;; lists have some special limitations, which we check here. +(defun check-gf-lambda-list (lambda-list) + (flet ((ensure (arg ok) + (unless ok + (error + ;; (s/invalid/non-ANSI-conforming/ because the old PCL + ;; implementation allowed this, so people got used to + ;; it, and maybe this phrasing will help them to guess + ;; why their program which worked under PCL no longer works.) + "~@" + 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) @@ -283,10 +347,8 @@ bootstrapping. lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*optimize-asv-funcall-p* t) + (let ((*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) @@ -316,9 +378,6 @@ bootstrapping. ;; 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*))) @@ -328,8 +387,8 @@ bootstrapping. (class-name (class-of proto-method)) 'standard-method) initargs-form - (getf (getf initargs ':plist) - ':pv-table-symbol)))))))) + (getf (getf initargs :plist) + :pv-table-symbol)))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -341,16 +400,16 @@ bootstrapping. fn-lambda) (if (and (interned-symbol-p (fun-name-block-name name)) (every #'interned-symbol-p qualifiers) - (every #'(lambda (s) - (if (consp s) - (and (eq (car s) 'eql) - (constantp (cadr s)) - (let ((sv (eval (cadr s)))) - (or (interned-symbol-p sv) - (integerp sv) - (and (characterp sv) - (standard-char-p sv))))) - (interned-symbol-p s))) + (every (lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) specializers) (consp initargs-form) (eq (car initargs-form) 'list*) @@ -364,7 +423,7 @@ bootstrapping. `(,(car specl) ,(eval (cadr specl))) specl)) specializers)) - (mname `(,(if (eq (cadr initargs-form) ':function) + (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) (mname-sym (intern (let ((*print-pretty* nil) @@ -387,13 +446,14 @@ bootstrapping. pv-table-symbol))) (make-defmethod-form-internal name qualifiers - `(list ,@(mapcar #'(lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) - ,,(cadr specializer)) - `',specializer)) + `(list ,@(mapcar (lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) + ,,(cadr specializer)) + `',specializer)) specializers)) - unspecialized-lambda-list method-class-name + unspecialized-lambda-list + method-class-name initargs-form pv-table-symbol)))) @@ -431,11 +491,35 @@ bootstrapping. (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 env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) - (declare (%method-name ,(list name qualifiers specializers))) + ;; (Old PCL code used a somewhat different style of + ;; list for %METHOD-NAME values. Our names use + ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the + ;; method names look more like what you see in a + ;; DEFMETHOD form.) + ;; + ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at + ;; least the code to set up named BLOCKs around the + ;; bodies of methods, depends on the function's base + ;; name being the first element of the %METHOD-NAME + ;; list. It would be good to remove this dependency, + ;; perhaps by building the BLOCK here, or by using + ;; 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))) (declare (%method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) @@ -444,7 +528,8 @@ bootstrapping. (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) - (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (unless (and (consp method-lambda) + (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ is not a lambda form." method-lambda)) @@ -520,8 +605,8 @@ bootstrapping. (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) env) (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))) @@ -608,10 +693,11 @@ bootstrapping. 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) env) + (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) @@ -642,6 +728,14 @@ bootstrapping. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-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 @@ -673,10 +767,10 @@ 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) @@ -685,18 +779,32 @@ bootstrapping. (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) - (call-next-method-body (cnm-args) + (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) - (error "no next method"))) + (apply #'call-no-next-method ',method-name-declaration + (or ,cnm-args ,',method-args)))) (next-method-p-body () `(not (null .next-method.)))) ,@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) call-method-args) @@ -741,11 +849,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 @@ -795,26 +900,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 @@ -829,18 +933,12 @@ bootstrapping. (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+))))))) - ||# + (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 @@ -907,83 +1005,96 @@ 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 - ,(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"))) + `(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: 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)))) - ,@body)) + `(not (null ,',next-method-call)))) + ,@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 + closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) (null closurep) (null applyp)) `(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))))) @@ -1023,8 +1134,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)) @@ -1032,8 +1144,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 @@ -1043,9 +1156,10 @@ 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)))))) @@ -1055,15 +1169,14 @@ bootstrapping. (declare (ignorable ,args-tail)) ,@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 @@ -1073,7 +1186,7 @@ bootstrapping. (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P ; should be in the method definition (flet ((walk-function (form context env) - (cond ((not (eq context ':eval)) form) + (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used ;; above, perhaps CONTEXT should be called SITUATION ;; (after the term used in the ANSI specification of @@ -1193,9 +1306,9 @@ bootstrapping. (defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) (setq initargs (copy-tree initargs)) - (let ((method-spec (or (getf initargs ':method-spec) + (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) - (setf (getf initargs ':method-spec) method-spec) + (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) @@ -1203,7 +1316,7 @@ bootstrapping. (method-class gf-spec qualifiers specializers lambda-list initargs pv-table-symbol) (when pv-table-symbol - (setf (getf (getf initargs ':plist) :pv-table-symbol) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) (when (and (eq *boot-state* 'complete) (fboundp gf-spec)) @@ -1221,7 +1334,7 @@ bootstrapping. :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))) @@ -1240,12 +1353,12 @@ bootstrapping. `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) - (let* ((mf (getf initargs ':function)) - (method-spec (getf initargs ':method-spec)) - (plist (getf initargs ':plist)) - (pv-table-symbol (getf plist ':pv-table-symbol)) + (let* ((mf (getf initargs :function)) + (method-spec (getf initargs :method-spec)) + (plist (getf initargs :plist)) + (pv-table-symbol (getf plist :pv-table-symbol)) (pv-table nil) - (mff (getf initargs ':fast-function))) + (mff (getf initargs :fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) @@ -1289,7 +1402,7 @@ bootstrapping. (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? - (parse-key-argument (arg) + (parse-key-arg (arg) (if (listp arg) (if (listp (car arg)) (caar arg) @@ -1299,6 +1412,7 @@ bootstrapping. (noptional 0) (keysp nil) (restp nil) + (nrest 0) (allow-other-keys-p nil) (keywords ()) (keyword-parameters ()) @@ -1319,9 +1433,13 @@ bootstrapping. (ecase state (required (incf nrequired)) (optional (incf noptional)) - (key (push (parse-key-argument x) keywords) + (key (push (parse-key-arg x) keywords) (push x keyword-parameters)) - (rest ())))) + (rest (incf nrest))))) + (when (and restp (zerop nrest)) + (error "Error in lambda-list:~%~ + After &REST, a DEFGENERIC lambda-list ~ + must be followed by at least one variable.")) (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords) (reverse keyword-parameters))))) @@ -1356,8 +1474,8 @@ bootstrapping. '(&rest t)) (when (or keysp old-keysp) (append '(&key) - (mapcar #'(lambda (key) - `(,key t)) + (mapcar (lambda (key) + `(,key t)) keywords) (when (or allow-other-keys-p old-allowp) '(&allow-other-keys))))) @@ -1396,13 +1514,13 @@ bootstrapping. 'standard-generic-function)) (defvar *sgf-slots-init* - (mapcar #'(lambda (canonical-slot) - (if (memq (getf canonical-slot :name) '(arg-info source)) - +slot-unbound+ - (let ((initfunction (getf canonical-slot :initfunction))) - (if initfunction - (funcall initfunction) - +slot-unbound+)))) + (mapcar (lambda (canonical-slot) + (if (memq (getf canonical-slot :name) '(arg-info source)) + +slot-unbound+ + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + +slot-unbound+)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* @@ -1461,7 +1579,7 @@ bootstrapping. (length (arg-info-metatypes arg-info))) (defun arg-info-nkeys (arg-info) - (count-if #'(lambda (x) (neq x t)) (arg-info-metatypes arg-info))) + (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) @@ -1484,7 +1602,7 @@ bootstrapping. (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p (and first-p - (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) + (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list lambda-list) (when (and methods (not first-p)) @@ -1522,12 +1640,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)) @@ -1543,14 +1660,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~%~ + (every (lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the &KEY arguments~2I~_~ ~S." gf-keywords))))))) @@ -1636,13 +1753,15 @@ 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)) 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." @@ -1650,9 +1769,11 @@ 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 fin @@ -1670,13 +1791,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) @@ -1717,7 +1842,7 @@ bootstrapping. (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) - (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) + (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) (let ((methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) @@ -1789,7 +1914,7 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) -(defun get-generic-function-info (gf) +(defun get-generic-fun-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) @@ -1800,7 +1925,7 @@ bootstrapping. metatypes arg-info)) (values (length metatypes) applyp metatypes - (count-if #'(lambda (x) (neq x t)) metatypes) + (count-if (lambda (x) (neq x t)) metatypes) arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc @@ -1816,17 +1941,17 @@ bootstrapping. ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. - (if (every #'(lambda (s) (not (symbolp s))) specializers) + (if (every (lambda (s) (not (symbolp s))) specializers) (setq parsed specializers - unparsed (mapcar #'(lambda (s) - (if (eq s t) t (class-name s))) + unparsed (mapcar (lambda (s) + (if (eq s t) t (class-name s))) specializers)) (setq unparsed specializers parsed ())) (list :early-method ;This is an early method dammit! - (getf initargs ':function) - (getf initargs ':fast-function) + (getf initargs :function) + (getf initargs :fast-function) parsed ;The parsed specializers. This is used ;by early-method-specializers to cache @@ -2003,13 +2128,13 @@ bootstrapping. (dolist (early-gf-spec *!early-generic-functions*) (/show early-gf-spec) (let* ((gf (gdefinition early-gf-spec)) - (methods (mapcar #'(lambda (early-method) - (let ((args (copy-list (fifth - early-method)))) - (setf (fourth args) - (early-method-specializers - early-method t)) - (apply #'real-make-a-method args))) + (methods (mapcar (lambda (early-method) + (let ((args (copy-list (fifth + early-method)))) + (setf (fourth args) + (early-method-specializers + early-method t)) + (apply #'real-make-a-method args))) (early-gf-methods gf)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) @@ -2024,27 +2149,27 @@ bootstrapping. (/show fixup) (let* ((fspec (car fixup)) (gf (gdefinition fspec)) - (methods (mapcar #'(lambda (method) - (let* ((lambda-list (first method)) - (specializers (second method)) - (method-fn-name (third method)) - (fn-name (or method-fn-name fspec)) - (fn (fdefinition fn-name)) - (initargs - (list :function - (set-fun-name - #'(lambda (args next-methods) - (declare (ignore - next-methods)) - (apply fn args)) - `(call ,fn-name))))) - (declare (type function fn)) - (make-a-method 'standard-method - () - lambda-list - specializers - initargs - nil))) + (methods (mapcar (lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (fdefinition fn-name)) + (initargs + (list :function + (set-fun-name + (lambda (args next-methods) + (declare (ignore + next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) (cdr fixup)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) @@ -2158,17 +2283,12 @@ bootstrapping. (values nil arglist nil)) ((memq arg lambda-list-keywords) (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) - ;; Warn about non-standard lambda-list-keywords, but then - ;; go on to treat them like a standard lambda-list-keyword - ;; what with the warning its probably ok. - ;; - ;; FIXME: This shouldn't happen now that this is maintained - ;; as part of SBCL, should it? Perhaps this is now - ;; "internal error: unrecognized lambda-list keyword ~S"? - (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ - Assuming that the symbols following it are parameters,~%~ - and not allowing any parameter specializers to follow it." - arg)) + ;; 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.~%" + :format-arguments (list arg))) ;; When we are at a lambda-list keyword, the parameters ;; don't include the lambda-list keyword; the lambda-list ;; does include the lambda-list keyword; and no @@ -2176,6 +2296,13 @@ bootstrapping. ;; 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."))) (values parameters (cons arg lambda-list) () @@ -2213,17 +2340,17 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((var-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,var-name - (slot-value ,in ',slot-name)))) + (symbol-macrolet ,(mapcar (lambda (slot-entry) + (let ((var-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,var-name + (slot-value ,in ',slot-name)))) slots) ,@body)))) @@ -2237,9 +2364,9 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((var-name (car slot-entry)) (accessor-name (cadr slot-entry))) `(,var-name (,accessor-name ,in)))) - slots) + slots) ,@body))))