(declaim (notinline make-a-method
add-named-method
ensure-generic-function-using-class
-
add-method
remove-method))
standard-compute-effective-method))))
\f
(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)))
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
(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)))
(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)
(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-truename*)
+ initargs))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
(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)))
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*)
`(,(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)
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))))
(extract-declarations 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)).
+ (declare (%method-name (,name
+ ,@qualifiers
+ ,specializers)))
(declare (%method-lambda-list ,@lambda-list))
,@declarations
,@real-body)
(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))
;; 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)
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)
#-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))
\f
;;;; effective method functions
&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
(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
(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)))
\f
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body body)
- `(macrolet ((call-next-method-bind (&body body)
- `(let () ,@body))
+ `(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 (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")))
+ `(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))))
+ (error "no next method")))
(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)
(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
(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)))
(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))
`(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))
\f
(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)
(noptional 0)
(keysp nil)
(restp nil)
+ (nrest 0)
(allow-other-keys-p nil)
(keywords ())
(keyword-parameters ())
(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)))))
'(&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)))))
'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*
(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)
(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))
(when (consp gf-keywords)
(unless (or (and restp (not keysp))
allow-other-keys-p
- (every #'(lambda (k) (memq k keywords)) gf-keywords))
+ (every (lambda (k) (memq k keywords)) gf-keywords))
(lose "the method does not accept each of the &KEY arguments~%~
~S."
gf-keywords)))))))
(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))))
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name lambda-list)))))
\f
-(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)
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
;; 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
(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)
(/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)
(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
;; 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)
()
(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))))
(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))))