X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=f385fb5050782dc21d133ffd911d01338d068b92;hb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;hp=27196f3cbbb47950c812ba81bc597f4019caad3e;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 27196f3..f385fb5 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -109,7 +109,7 @@ bootstrapping. (let ((name (car fns)) (early-name (cadr fns))) (setf (gdefinition name) - (set-function-name + (set-fun-name (lambda (&rest args) (apply (fdefinition early-name) args)) name)))) @@ -131,12 +131,12 @@ bootstrapping. (standard-generic-function t t) real-get-method)) (ensure-generic-function-using-class - ((generic-function function-name + ((generic-function fun-name &key generic-function-class environment &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) - ((generic-function function-name + ((generic-function fun-name &key generic-function-class environment &allow-other-keys) (null t) @@ -156,14 +156,11 @@ bootstrapping. (generic-function standard-method-combination t) standard-compute-effective-method)))) -(defmacro defgeneric (function-name lambda-list &body options) - (expand-defgeneric function-name lambda-list options)) - -(defun expand-defgeneric (function-name lambda-list options) +(defmacro defgeneric (fun-name lambda-list &body options) (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) - (error 'sb-kernel:simple-program-error + (error 'simple-program-error :format-control "The option ~S appears more than once." :format-arguments (list name))) (expand-method-definition (qab) ; QAB = qualifiers, arglist, body @@ -171,12 +168,7 @@ bootstrapping. (arglist (elt qab arglist-pos)) (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) - (when (not (equal (cadr (getf initargs :method-combination)) - qualifiers)) - (error "bad method specification in DEFGENERIC ~A~%~ - -- qualifier mismatch for lambda list ~A" - function-name arglist)) - `(defmethod ,function-name ,@qualifiers ,arglist ,@body)))) + `(defmethod ,fun-name ,@qualifiers ,arglist ,@body)))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -199,7 +191,7 @@ bootstrapping. (t ;; ANSI requires that unsupported things must get a ;; PROGRAM-ERROR. - (error 'sb-kernel:simple-program-error + (error 'simple-program-error :format-control "unsupported option ~S" :format-arguments (list option)))))) @@ -208,27 +200,26 @@ bootstrapping. `',(initarg :declarations)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (compile-or-load-defgeneric ',function-name)) - (load-defgeneric ',function-name ',lambda-list ,@initargs) + (compile-or-load-defgeneric ',fun-name)) + (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) - `,(function ,function-name))))) - -(defun compile-or-load-defgeneric (function-name) - (sb-kernel:proclaim-as-function-name function-name) - (sb-kernel:note-name-defined function-name :function) - (unless (eq (info :function :where-from function-name) :declared) - (setf (info :function :where-from function-name) :defined) - (setf (info :function :type function-name) + `,(function ,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) + (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)))) -(defun load-defgeneric (function-name lambda-list &rest initargs) - (when (fboundp function-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name)) +(defun load-defgeneric (fun-name lambda-list &rest initargs) + (when (fboundp fun-name) + (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)) (apply #'ensure-generic-function - function-name + fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,function-name) - ,*load-truename*) + :definition-source `((defgeneric ,fun-name) ,*load-truename*) initargs)) (defmacro defmethod (&rest args &environment env) @@ -348,18 +339,18 @@ bootstrapping. initargs-form &optional pv-table-symbol) (let (fn fn-lambda) - (if (and (interned-symbol-p (function-name-block-name name)) + (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*) @@ -396,11 +387,11 @@ 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 initargs-form @@ -549,7 +540,7 @@ bootstrapping. ;; These declarations seem to be used by PCL to pass ;; information to itself; when I tried to delete 'em ;; ca. 0.6.10 it didn't work. I'm not sure how - ;; they work, but note the (VARIABLE-DECLARATION '%CLASS ..) + ;; they work, but note the (VAR-DECLARATION '%CLASS ..) ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 ,@(remove nil (mapcar (lambda (a s) (and (symbolp s) @@ -593,8 +584,7 @@ bootstrapping. (declare (ignorable ,@required-parameters)) ,class-declarations ,@declarations - (block ,(function-name-block-name - generic-function-name) + (block ,(fun-name-block-name generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) @@ -806,7 +796,22 @@ bootstrapping. (unless (constantp restp) (error "The RESTP argument is not constant.")) (setq restp (eval restp)) - `(progn + `(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)) + (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)) @@ -909,22 +914,22 @@ bootstrapping. (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)))) + (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) @@ -963,8 +968,8 @@ bootstrapping. (null closurep) (null applyp)) `(let () ,@body)) - ((and (null closurep) - (null applyp)) + ((and (null closurep) + (null applyp)) ;; OK to use MACROLET, and all args are mandatory ;; (else APPLYP would be true). `(call-next-method-bind @@ -1094,8 +1099,9 @@ bootstrapping. ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) (constantp (caddr form))) - (let ((parameter - (can-optimize-access form required-parameters env))) + (let ((parameter (can-optimize-access form + required-parameters + env))) (let ((fun (ecase (car form) (slot-value #'optimize-slot-value) (set-slot-value #'optimize-set-slot-value) @@ -1126,7 +1132,7 @@ bootstrapping. next-method-p-p))))) (defun generic-function-name-p (name) - (and (legal-function-name-p name) + (and (legal-fun-name-p name) (gboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) @@ -1190,7 +1196,6 @@ bootstrapping. (let ((method-spec (or (getf initargs ':method-spec) (make-method-spec name quals specls)))) (setf (getf initargs ':method-spec) method-spec) - (record-definition 'method method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) @@ -1248,7 +1253,7 @@ bootstrapping. (setf (method-function-get mff p) v)))) (when method-spec (when mf - (setq mf (set-function-name mf method-spec))) + (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) @@ -1264,7 +1269,7 @@ bootstrapping. (car method-spec)) *pcl-package*))) ,@(cdr method-spec)))) - (set-function-name mff name) + (set-fun-name mff name) (unless mf (set-mf-property :name name))))) (when plist @@ -1284,7 +1289,7 @@ bootstrapping. (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? - (parse-keyword-argument (arg) + (parse-key-argument (arg) (if (listp arg) (if (listp (car arg)) (caar arg) @@ -1294,6 +1299,7 @@ bootstrapping. (noptional 0) (keysp nil) (restp nil) + (nrest 0) (allow-other-keys-p nil) (keywords ()) (keyword-parameters ()) @@ -1314,9 +1320,13 @@ bootstrapping. (ecase state (required (incf nrequired)) (optional (incf noptional)) - (key (push (parse-keyword-argument x) keywords) + (key (push (parse-key-argument 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))))) @@ -1333,15 +1343,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:function-type-p old) old nil)) - (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype))) + (old-ftype (if (sb-kernel:fun-type-p old) old nil)) + (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype))) (old-keys (and old-ftype (mapcar #'sb-kernel:key-info-name - (sb-kernel:function-type-keywords + (sb-kernel:fun-type-keywords old-ftype)))) - (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype))) + (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype))) (old-allowp (and old-ftype - (sb-kernel:function-type-allowp old-ftype))) + (sb-kernel: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) @@ -1351,8 +1361,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))))) @@ -1360,45 +1370,44 @@ bootstrapping. (defun defgeneric-declaration (spec lambda-list) (when (consp spec) - (setq spec (get-setf-function-name (cadr spec)))) + (setq spec (get-setf-fun-name (cadr spec)))) `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) ;;;; early generic function support (defvar *!early-generic-functions* ()) -(defun ensure-generic-function (function-name +(defun ensure-generic-function (fun-name &rest all-keys &key environment &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp function-name) - (gdefinition function-name)))) + (let ((existing (and (gboundp fun-name) + (gdefinition fun-name)))) (if (and existing (eq *boot-state* 'complete) (null (generic-function-p existing))) - (generic-clobbers-function function-name) + (generic-clobbers-function fun-name) (apply #'ensure-generic-function-using-class - existing function-name all-keys)))) + existing fun-name all-keys)))) -(defun generic-clobbers-function (function-name) - (error 'sb-kernel:simple-program-error - :format-control - "~S already names an ordinary function or a macro." - :format-arguments (list function-name))) +(defun generic-clobbers-function (fun-name) + (error 'simple-program-error + :format-control "~S already names an ordinary function or a macro." + :format-arguments (list fun-name))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) '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* @@ -1425,17 +1434,17 @@ bootstrapping. (!bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info - (:conc-name nil) - (:constructor make-arg-info ()) - (:copier nil)) + (:conc-name nil) + (:constructor make-arg-info ()) + (:copier nil)) (arg-info-lambda-list :no-lambda-list) arg-info-precedence arg-info-metatypes arg-info-number-optional arg-info-key/rest-p - arg-info-keywords ;nil no keyword or rest allowed - ;(k1 k2 ..) each method must accept these keyword arguments - ;T must have &key or &rest + arg-info-keys ;nil no &KEY or &REST allowed + ;(k1 k2 ..) Each method must accept these &KEY arguments. + ;T must have &KEY or &REST gf-info-simple-accessor-type ; nil, reader, writer, boundp (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info @@ -1457,7 +1466,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) @@ -1503,7 +1512,7 @@ bootstrapping. (esetf (arg-info-metatypes arg-info) (make-list nreq)) (esetf (arg-info-number-optional arg-info) nopt) (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (esetf (arg-info-keywords arg-info) + (esetf (arg-info-keys arg-info) (if lambda-list-p (if allow-other-keys-p t keywords) (arg-info-key/rest-p arg-info))))) @@ -1524,20 +1533,20 @@ bootstrapping. method gf (apply #'format nil string args))) - (compare (x y) + (comparison-description (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) (gf-key/rest-p (arg-info-key/rest-p arg-info)) - (gf-keywords (arg-info-keywords arg-info))) + (gf-keywords (arg-info-keys arg-info))) (unless (= nreq gf-nreq) (lose "the method has ~A required arguments than the generic function." - (compare nreq gf-nreq))) + (comparison-description nreq gf-nreq))) (unless (= nopt gf-nopt) (lose - "the method has ~S optional arguments than the generic function." - (compare nopt gf-nopt))) + "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~%~ @@ -1545,8 +1554,8 @@ bootstrapping. (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 keyword arguments~%~ + (every (lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the &KEY arguments~%~ ~S." gf-keywords))))))) @@ -1650,7 +1659,7 @@ bootstrapping. (defun make-early-gf (spec &optional lambda-list lambda-list-p function) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) - (set-funcallable-instance-function + (set-funcallable-instance-fun fin (or function (if (eq spec 'print-object) @@ -1667,7 +1676,7 @@ bootstrapping. fin 'source *load-truename*) - (set-function-name fin spec) + (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p @@ -1747,11 +1756,15 @@ bootstrapping. (setf (getf ,all-keys :method-combination) (find-method-combination (class-prototype ,gf-class) (car combin) - (cdr combin))))))) + (cdr combin))))) + (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)))))) (defun real-ensure-gf-using-class--generic-function (existing - function-name + fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function gf-class-p) @@ -1763,11 +1776,11 @@ bootstrapping. (prog1 (apply #'reinitialize-instance existing all-keys) (when lambda-list-p - (proclaim (defgeneric-declaration function-name lambda-list))))) + (proclaim (defgeneric-declaration fun-name lambda-list))))) (defun real-ensure-gf-using-class--null (existing - function-name + fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function) @@ -1775,11 +1788,11 @@ bootstrapping. (declare (ignore existing)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 - (setf (gdefinition function-name) + (setf (gdefinition fun-name) (apply #'make-instance generic-function-class - :name function-name all-keys)) + :name fun-name all-keys)) (when lambda-list-p - (proclaim (defgeneric-declaration function-name lambda-list))))) + (proclaim (defgeneric-declaration fun-name lambda-list))))) (defun get-generic-function-info (gf) ;; values nreq applyp metatypes nkeys arg-info @@ -1792,7 +1805,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 @@ -1808,10 +1821,10 @@ 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 ())) @@ -1995,13 +2008,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) @@ -2016,27 +2029,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-function-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) @@ -2095,7 +2108,7 @@ bootstrapping. gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-function-name + (intern-fun-name (make-method-spec temp (method-qualifiers method) (unparse-specializers @@ -2113,9 +2126,9 @@ bootstrapping. (and (setq method (get-method gf quals specls errorp)) (setq name - (intern-function-name (make-method-spec gf-spec - quals - specls)))))))) + (intern-fun-name (make-method-spec gf-spec + quals + specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) @@ -2150,17 +2163,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 @@ -2168,6 +2176,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) () @@ -2205,17 +2220,17 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((variable-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,variable-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)))) @@ -2229,10 +2244,9 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((variable-name (car slot-entry)) + (symbol-macrolet ,(mapcar (lambda (slot-entry) + (let ((var-name (car slot-entry)) (accessor-name (cadr slot-entry))) - `(,variable-name - (,accessor-name ,in)))) - slots) + `(,var-name (,accessor-name ,in)))) + slots) ,@body))))