(declaim (notinline make-a-method
add-named-method
ensure-generic-function-using-class
-
add-method
remove-method))
(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)
:lambda-list lambda-list
:definition-source `((defgeneric ,fun-name) ,*load-truename*)
initargs))
+
+;;; As per section 3.4.2 of the ANSI spec, generic function lambda
+;;; lists have a number of limitations, which we check here.
+(defun check-gf-lambda-list (lambda-list)
+ (macrolet ((ensure (condition)
+ `(unless ,condition
+ (error "Invalid argument ~S in the generic function lambda list ~S."
+ it lambda-list))))
+ (process-lambda-list lambda-list
+ (&required (ensure (symbolp it)))
+ (&optional (ensure (or (symbolp it)
+ (and (consp it) (symbolp (car it)) (null (cdr it))))))
+ (&rest (ensure (symbolp it)))
+ (&key (ensure (or (symbolp it)
+ (and (consp it)
+ (or (symbolp (car it))
+ (and (consp (car it))
+ (symbolp (caar it))
+ (symbolp (cadar it))
+ (null (cddar it))))
+ (null (cdr it))))))
+ ((&aux (error "&AUX is not allowed in the generic function lambda list ~S."
+ lambda-list))))))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
,,(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))
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
\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)
projects / sbcl.git / blobdiff