(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)))
`(,(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))))
(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))
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body body)
`(macrolet ((call-next-method-bind (&body body)
- `(let () ,@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
+ ,',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")))
(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)
(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))
(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))
(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