(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)
#',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)
(apply #'ensure-generic-function
fun-name
:lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-truename*)
+ :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
initargs))
;;; As per section 3.4.2 of the ANSI spec, generic function lambda
(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)))
;; 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)))
: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
(,',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)
`(((typep ,emf 'fixnum)
(let ((.new-value. ,(car required-args+rest-arg))
(.slots. (get-slots-or-nil
- ,(car required-args+rest-arg))))
+ ,(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
,emf))
(call-next-method-bind (&body body)
`(let () ,@body))
- (call-next-method-body (cnm-args)
+ (call-next-method-body (method-name-declaration cnm-args)
`(if ,',next-method-call
,(locally
;; This declaration suppresses a "deleting
,cnm-args)
,call)
,call))))
- (error "no next method")))
+ ,(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))
(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)))))
((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)))
(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)))
(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)
(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)