(let ((car-option (car option)))
(case car-option
(declare
- (push (cdr option) (initarg :declarations)))
- ((:argument-precedence-order :method-combination)
- (if (initarg car-option)
- (duplicate-option car-option)
- (setf (initarg car-option)
- `',(cdr option))))
+ (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)))
+ (:method-combination
+ (when (initarg car-option)
+ (duplicate-option car-option))
+ (unless (symbolp (cadr option))
+ (error 'simple-program-error
+ :format-control "METHOD-COMBINATION name not a ~
+ symbol: ~S"
+ :format-arguments (list (cadr option))))
+ (setf (initarg car-option)
+ `',(cdr option)))
+ (:argument-precedence-order
+ (let* ((required (parse-lambda-list lambda-list))
+ (supplied (cdr option)))
+ (unless (= (length required) (length supplied))
+ (error 'simple-program-error
+ :format-control "argument count discrepancy in ~
+ :ARGUMENT-PRECEDENCE-ORDER clause."
+ :format-arguments nil))
+ (when (set-difference required supplied)
+ (error 'simple-program-error
+ :format-control "unequal sets for ~
+ :ARGUMENT-PRECEDENCE-ORDER clause: ~
+ ~S and ~S"
+ :format-arguments (list required supplied)))
+ (setf (initarg car-option)
+ `',(cdr option))))
((:documentation :generic-function-class :method-class)
(unless (proper-list-of-length-p option 2)
(error "bad list length for ~S" 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)))
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
;; 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)))
;; weirdness when bootstrapping.. -- WHN 20000610
'(ignorable))
(t
- ;; Otherwise, we can make Python very happy.
- `(type ,specializer ,parameter))))
+ ;; Otherwise, we can usually make Python very happy.
+ (let ((type (info :type :kind specializer)))
+ (ecase type
+ ((:primitive :defined :instance :forthcoming-defclass-type)
+ `(type ,specializer ,parameter))
+ ((nil)
+ (let ((class (find-class specializer nil)))
+ (if class
+ `(type ,(class-name class) ,parameter)
+ (progn
+ ;; we can get here, and still not have a failure
+ ;; case, by doing MOP programming like (PROGN
+ ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+ ;; ...)). Best to let the user know we haven't
+ ;; been able to extract enough information:
+ (style-warn
+ "~@<can't find type for presumed class ~S in ~S.~@:>"
+ specializer
+ 'parameter-specializer-declaration-in-defmethod)
+ '(ignorable))))))))))
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
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)))
: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
(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))
- (call-next-method-body (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")))
+ `(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
+ (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
+ (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)
`(((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
\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 (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))))
- (error "no next method")))
- (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)
+ ((&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))
- ((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)))))
- ,@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.)
(aux `(,var))))))
(let ((bindings (mapcan #'process-var lambda-list)))
`(let* ((,args-tail ,args)
- ,@bindings)
- (declare (ignorable ,args-tail))
+ ,@bindings
+ (.dummy0.
+ ,@(when (eq state 'optional)
+ `((unless (null ,args-tail)
+ (error 'simple-program-error
+ :format-control "surplus arguments: ~S"
+ :format-arguments (list ,args-tail)))))))
+ (declare (ignorable ,args-tail .dummy0.))
,@body)))))
(defun get-key-arg-tail (keyword list)
((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)))
(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)
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)
;;; Keep pages clean by not setting if the value is already the same.
(defmacro esetf (pos val)
- (let ((valsym (gensym "value")))
+ (with-unique-names (valsym)
`(let ((,valsym ,val))
(unless (equal ,pos ,valsym)
(setf ,pos ,valsym)))))
(method-lambda-list method)))
(flet ((lose (string &rest args)
(error 'simple-program-error
- :format-control "attempt to add the method ~S ~
- to the generic function ~S.~%~
- But ~A"
- :format-arguments (list method gf
- (apply #'format nil string args))))
+ :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))
(comparison-description nopt gf-nopt)))
(unless (eq (or keysp restp) gf-key/rest-p)
(lose
- "the method and generic function differ in whether they accept~%~
+ "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)))))))
(generic-function-name gf)
(!early-gf-name gf))))
(esetf (gf-precompute-dfun-and-emf-p arg-info)
- (let* ((sym (if (atom name) name (cadr name)))
- (pkg-list (cons *pcl-package*
- (package-use-list *pcl-package*))))
- (and sym (symbolp sym)
- (not (null (memq (symbol-package sym) pkg-list)))
- (not (find #\space (symbol-name sym))))))))
+ (cond
+ ((and (consp name)
+ (member (car name)
+ *internal-pcl-generalized-fun-name-symbols*))
+ nil)
+ (t (let* ((symbol (fun-name-block-name name))
+ (package (symbol-package symbol)))
+ (and (or (eq package *pcl-package*)
+ (memq package (package-use-list *pcl-package*)))
+ ;; FIXME: this test will eventually be
+ ;; superseded by the *internal-pcl...* test,
+ ;; above. While we are in a process of
+ ;; transition, however, it should probably
+ ;; remain.
+ (not (find #\Space (symbol-name symbol))))))))))
(esetf (gf-info-fast-mf-p arg-info)
(or (not (eq *boot-state* 'complete))
(let* ((method-class (generic-function-method-class gf))
(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)
(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