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 (real-body declarations documentation)
- (parse-body body env)
+ (parse-body body)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
;; (Old PCL code used a somewhat different style of
is not a lambda form."
method-lambda))
(multiple-value-bind (real-body declarations documentation)
- (parse-body (cddr method-lambda) env)
+ (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)))
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
- (parse-body (cddr walked-lambda) env)
+ (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)))
(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))
+ `(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
+ `(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) &body body)
+ (declare (ignore call-next-method-p))
+ `(let () ,@body)))
+ ,@body))
(defun call-no-next-method (method-name-declaration &rest args)
(destructuring-bind (name) method-name-declaration
\f
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body 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)
+ (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))))
- ,@body))
+ (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) &body body)
+ (if cnm-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 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))
`(let () ,@body))
(t
`(call-next-method-bind
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)
+ ,@body))))))
(defmacro bind-args ((lambda-list args) &body body)
(let ((args-tail '.args-tail.)
(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)
(method-lambda-list method)))
(k (member '&key ll)))
(if k
- (append (ldiff ll (cdr k)) '(&allow-other-keys))
+ (ldiff ll (cdr k))
ll))))
(arg-info-lambda-list arg-info))))
(declare (ignore ignore1 ignore2 ignore3))
required-parameters))
-(defun parse-specialized-lambda-list (arglist &optional post-keyword)
- ;;(declare (values parameters lambda-list specializers required-parameters))
+(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.
+ ;; Now, since we try to conform to ANSI, non-standard
+ ;; lambda-list-keywords should be treated as errors.
+ (unless (memq arg specialized-lambda-list-keywords)
(error 'simple-program-error
- :format-control "unrecognized lambda-list keyword ~S ~
- in arglist.~%"
+ :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 'simple-program-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 'simple-program-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
;; 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 'simple-program-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)
()
projects / sbcl.git / blobdiff