;;; 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))
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)))
+ (check-gf-lambda-list lambda-list)
(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)))
(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)
(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)
- (sb-kernel:note-name-defined fun-name :function)
+ (proclaim-as-fun-name fun-name)
+ (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))))
+ (specifier-type 'function))))
(defun load-defgeneric (fun-name lambda-list &rest initargs)
(when (fboundp fun-name)
- (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name))
+ (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.)
+ "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
+ 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)))))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
\f
-(defvar *optimize-asv-funcall-p* nil)
-(defvar *asv-readers*)
-(defvar *asv-writers*)
-(defvar *asv-boundps*)
-
(defun expand-defmethod (name
proto-gf
proto-method
lambda-list
body
env)
- (let ((*make-instance-function-keys* nil)
- (*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)
- (make-method-lambda proto-gf proto-method method-lambda env)
- (let ((initargs-form (make-method-initargs-form proto-gf
- proto-method
- method-function-lambda
- initargs
- env)))
- `(progn
- ;; Note: We could DECLAIM the ftype of the generic
- ;; function here, since ANSI specifies that we create it
- ;; if it does not exist. However, I chose not to, because
- ;; I think it's more useful to support a style of
- ;; programming where every generic function has an
- ;; explicit DEFGENERIC and any typos in DEFMETHODs are
- ;; warned about. Otherwise
- ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
- ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
- ;; compiles without raising an error and runs without
- ;; raising an error (since SIMPLE-VECTOR cases fall
- ;; through to VECTOR) but still doesn't do what was
- ;; 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*)))
- ,(make-defmethod-form name qualifiers specializers
- unspecialized-lambda-list
- (if proto-method
- (class-name (class-of proto-method))
- 'standard-method)
- initargs-form
- (getf (getf initargs ':plist)
- ':pv-table-symbol))))))))
+ (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)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form proto-gf
+ proto-method
+ method-function-lambda
+ initargs
+ env)))
+ `(progn
+ ;; Note: We could DECLAIM the ftype of the generic function
+ ;; here, since ANSI specifies that we create it if it does
+ ;; not exist. However, I chose not to, because I think it's
+ ;; more useful to support a style of programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form
+ (getf (getf initargs :plist)
+ :pv-table-symbol)))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
`(,(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)
,,(cadr specializer))
`',specializer))
specializers))
- unspecialized-lambda-list method-class-name
+ unspecialized-lambda-list
+ method-class-name
initargs-form
pv-table-symbol))))
(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)
(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))
(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)))
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)
: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
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)
(,',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)
#-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
`(((typep ,emf 'fixnum)
(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+)))))))
- ||#
+ ,(cadr required-args+rest-arg))))
+ (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
+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)))
\f
(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)))))
,(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))
(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
(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))))))
(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
(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
((generic-function-name-p (car form))
(optimize-generic-function-call
form required-parameters env slots calls))
- ((and (eq (car form) 'asv-funcall)
- *optimize-asv-funcall-p*)
- (case (fourth form)
- (reader (push (third form) *asv-readers*))
- (writer (push (third form) *asv-writers*))
- (boundp (push (third form) *asv-boundps*)))
- `(,(second form) ,@(cddddr form)))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
(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))
(parse-specializers specializers)
nil))))
(when method
- (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
: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)))
`(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)
(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 (incf nrest)))))
(when (and restp (zerop nrest))
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
(let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-kernel:fun-type-p old) old nil))
- (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
+ (old-ftype (if (fun-type-p old) old nil))
+ (old-restp (and old-ftype (fun-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-kernel:key-info-name
- (sb-kernel:fun-type-keywords
+ (mapcar #'key-info-name
+ (fun-type-keywords
old-ftype))))
- (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+ (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
(old-allowp (and old-ftype
- (sb-kernel:fun-type-allowp old-ftype)))
+ (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)
(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))
(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 "~@<attempt to add the method~2I~_~S~I~_~
+ to the generic function~2I~_~S;~I~_~
+ but ~?~:>"
+ :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))
"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~%~
+ (lose "the method does not accept each of the &KEY arguments~2I~_~
~S."
gf-keywords)))))))
(let* ((sym (if (atom name) name (cadr name)))
(pkg-list (cons *pcl-package*
(package-use-list *pcl-package*))))
+ ;; FIXME: given the presence of generalized function
+ ;; names, this test is broken. A little
+ ;; reverse-engineering suggests that this was intended
+ ;; to prevent precompilation of things on some
+ ;; PCL-internal automatically-constructed functions
+ ;; like the old "~A~A standard class ~A reader"
+ ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR
+ ;; generalized functions was *, this test returned T,
+ ;; not NIL, and an error was signalled in
+ ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X
+ ;; 'ASLDKJ)). Whether the right thing to do is to fix
+ ;; MAKE-ACCESSOR-TABLE so that it can work in the
+ ;; presence of slot names that have no classes, or to
+ ;; restore this test to something more obvious, I don't
+ ;; know. -- CSR, 2003-02-14
(and sym (symbolp sym)
(not (null (memq (symbol-package sym) pkg-list)))
(not (find #\space (symbol-name sym))))))))
(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."
'*!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
+ (set-funcallable-instance-function
fin
(or function
(if (eq spec 'print-object)
- #'(sb-kernel:instance-lambda (instance stream)
+ #'(instance-lambda (instance stream)
(print-unreadable-object (instance stream :identity t)
(format stream "std-instance")))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
(!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)
(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))))
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
projects / sbcl.git / blobdiff