;;; 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
(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)
(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
(flet ((ensure (arg ok)
(unless ok
(error
- "invalid argument ~S in the generic function lambda list ~S"
+ ;; (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)
;; 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)
+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)
,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 supresses 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)))))
,(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
: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)))
(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)))))))
(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
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)
projects / sbcl.git / blobdiff