(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
- (style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
+ (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name
+ :old fun :new-location source-location)
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
do (remove-method fun method))
(defun prototypes-for-make-method-lambda (name)
- (if (not (eq *boot-state* 'complete))
+ (if (not (eq **boot-state** 'complete))
(values nil nil)
(let ((gf? (and (fboundp name)
(gdefinition name))))
(defun method-prototype-for-gf (name)
(let ((gf? (and (fboundp name)
(gdefinition name))))
- (cond ((neq *boot-state* 'complete) nil)
+ (cond ((neq **boot-state** 'complete) nil)
((or (null gf?)
(not (generic-function-p gf?))) ; Someone else MIGHT
; error at load time.
(setf (gdefinition 'make-method-lambda)
(symbol-function 'real-make-method-lambda)))
+(defun declared-specials (declarations)
+ (loop for (declare . specifiers) in declarations
+ append (loop for specifier in specifiers
+ when (eq 'special (car specifier))
+ append (cdr specifier))))
+
(defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
(declare (ignore proto-gf proto-method))
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
;; KLUDGE: when I tried moving these to
;; ADD-METHOD-DECLARATIONS, things broke. No idea
;; why. -- CSR, 2004-06-16
- ,@(mapcar #'parameter-specializer-declaration-in-defmethod
- parameters
- specializers)))
+ ,@(let ((specials (declared-specials declarations)))
+ (mapcar (lambda (par spec)
+ (parameter-specializer-declaration-in-defmethod
+ par spec specials env))
+ parameters
+ specializers))))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
(declare (ignore env proto-gf proto-method))
(flet ((parse (name)
(cond
- ((and (eq *boot-state* 'complete)
+ ((and (eq **boot-state** 'complete)
(specializerp name))
name)
((symbolp name) `(find-class ',name))
((consp name) (ecase (car name)
((eql) `(intern-eql-specializer ,(cadr name)))
- ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
- ((prototype) `(fixme))))
- (t (bug "Foo")))))
+ ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))))
+ (t
+ ;; FIXME: Document CLASS-EQ specializers.
+ (error 'simple-reference-error
+ :format-control
+ "~@<~S is not a valid parameter specializer name.~@:>"
+ :format-arguments (list name)
+ :references (list '(:ansi-cl :macro defmethod)
+ '(:ansi-cl :glossary "parameter specializer name")))))))
`(list ,@(mapcar #'parse specializer-names))))
(unless (fboundp 'make-method-specializers-form)
(symbol-function 'real-unparse-specializer-using-class)))
;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
+;;; in DEFMETHOD forms.
+;;;
+;;; We're too lazy to cons up a new environment for this, so we just pass in
+;;; the list of locally declared specials in addition to the old environment.
+(defun parameter-specializer-declaration-in-defmethod
+ (parameter specializer specials env)
(cond ((and (consp specializer)
(eq (car specializer) 'eql))
;; KLUDGE: ANSI, in its wisdom, says that
;; cases by blacklisting them here. -- WHN 2001-01-19
(list 'slot-object #+nil (find-class 'slot-object)))
'(ignorable))
- ((not (eq *boot-state* 'complete))
+ ((not (eq **boot-state** 'complete))
;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
;; types which don't match their specializers. (Specifically,
;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
'(ignorable))
((typep specializer 'eql-specializer)
`(type (eql ,(eql-specializer-object specializer)) ,parameter))
- ((var-globally-special-p parameter)
- ;; KLUDGE: Don't declare types for global special variables
- ;; -- our rebinding magic for SETQ cases don't work right
- ;; there.
- ;;
- ;; FIXME: It would be better to detect the SETQ earlier and
- ;; skip declarations for specials only when needed, not
- ;; always.
- ;;
- ;; --NS 2004-10-14
+ ((or (var-special-p parameter env) (member parameter specials))
+ ;; Don't declare types for special variables -- our rebinding magic
+ ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
+ ;; etc. make things undecidable.
'(ignorable))
(t
;; Otherwise, we can usually make Python very happy.
(defun call-no-next-method (method-cell &rest args)
(let ((method (car method-cell)))
(aver method)
+ ;; Can't easily provide a RETRY restart here, as the return value here is
+ ;; for the method, not the generic function.
(apply #'no-next-method (method-generic-function method)
method args)))
+(defun call-no-applicable-method (gf args)
+ (restart-case
+ (apply #'no-applicable-method gf args)
+ (retry ()
+ :report "Retry calling the generic function."
+ (apply gf args))))
+
+(defun call-no-primary-method (gf args)
+ (restart-case
+ (apply #'no-primary-method gf args)
+ (retry ()
+ :report "Retry calling the generic function."
+ (apply gf args))))
+
(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
;; another binding it won't have a %CLASS
;; declaration anymore, and this won't get
;; executed.
- (pushnew var parameters-setqd))))
+ (pushnew var parameters-setqd :test #'eq))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
(fboundp name)
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
initargs source-location)
- (when (and (eq *boot-state* 'complete)
+ (when (and (eq **boot-state** 'complete)
(fboundp gf-spec))
(let* ((gf (fdefinition gf-spec))
(method (and (generic-function-p gf)
(generic-function-methods gf)
(find-method gf qualifiers specializers nil))))
(when method
- (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn 'sb-kernel:redefinition-with-defmethod
+ :generic-function gf-spec :old-method method
+ :qualifiers qualifiers :specializers specializers
+ :new-location source-location))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source source-location
(when (or allow-other-keys-p old-allowp)
'(&allow-other-keys)))))
*))))
-
-(defun defgeneric-declaration (spec lambda-list)
- `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
(cond ((and existing
- (eq *boot-state* 'complete)
+ (eq **boot-state** 'complete)
(null (generic-function-p existing)))
(generic-clobbers-function fun-name)
(fmakunbound fun-name)
+slot-unbound+))))
(early-collect-inheritance 'standard-generic-function)))
-(defvar *sgf-method-class-index*
+(defconstant +sgf-method-class-index+
(!bootstrap-slot-index 'standard-generic-function 'method-class))
(defun early-gf-p (x)
(and (fsc-instance-p x)
- (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+ (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+)
+slot-unbound+)))
-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+
(!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
- `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+ `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+))
(defun safe-generic-function-methods (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
- (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+ (clos-slots-ref (get-slots generic-function) +sgf-methods-index+)
(generic-function-methods generic-function)))
-(defvar *sgf-arg-info-index*
+(defconstant +sgf-arg-info-index+
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
(defmacro early-gf-arg-info (gf)
- `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
+ `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+))
-(defvar *sgf-dfun-state-index*
+(defconstant +sgf-dfun-state-index+
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
argument-precedence-order)
- (let* ((arg-info (if (eq *boot-state* 'complete)
+ (let* ((arg-info (if (eq **boot-state** 'complete)
(gf-arg-info gf)
(early-gf-arg-info gf)))
- (methods (if (eq *boot-state* 'complete)
+ (methods (if (eq **boot-state** 'complete)
(generic-function-methods gf)
(early-gf-methods gf)))
(was-valid-p (integerp (arg-info-number-optional arg-info)))
~S."
gf-keywords)))))))
-(defvar *sm-specializers-index*
+(defconstant +sm-specializers-index+
(!bootstrap-slot-index 'standard-method 'specializers))
-(defvar *sm-%function-index*
+(defconstant +sm-%function-index+
(!bootstrap-slot-index 'standard-method '%function))
-(defvar *sm-qualifiers-index*
+(defconstant +sm-qualifiers-index+
(!bootstrap-slot-index 'standard-method 'qualifiers))
-(defvar *sm-plist-index*
- (!bootstrap-slot-index 'standard-method 'plist))
;;; FIXME: we don't actually need this; we could test for the exact
;;; class and deal with it as appropriate. In fact we probably don't
;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
;;; the standard reader method for METHOD-SPECIALIZERS. Probably.
-(dolist (s '(specializers %function plist))
- (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+(dolist (s '(specializers %function))
+ (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s)))
(!bootstrap-slot-index 'standard-reader-method s)
(!bootstrap-slot-index 'standard-writer-method s)
- (!bootstrap-slot-index 'standard-boundp-method s))))
+ (!bootstrap-slot-index 'standard-boundp-method s)
+ (!bootstrap-slot-index 'global-reader-method s)
+ (!bootstrap-slot-index 'global-writer-method s)
+ (!bootstrap-slot-index 'global-boundp-method s))))
+
+(defvar *standard-method-class-names*
+ '(standard-method standard-reader-method
+ standard-writer-method standard-boundp-method
+ global-reader-method global-writer-method
+ global-boundp-method))
+
+(declaim (list **standard-method-classes**))
+(defglobal **standard-method-classes** nil)
(defun safe-method-specializers (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
- (class (class-of method)))
- (if (member class standard-method-classes)
- (clos-slots-ref (get-slots method) *sm-specializers-index*)
- (method-specializers method))))
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-specializers-index+)
+ (method-specializers method)))
(defun safe-method-fast-function (method)
(let ((mf (safe-method-function method)))
(and (typep mf '%method-function)
(%method-function-fast-function mf))))
(defun safe-method-function (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
- (class (class-of method)))
- (if (member class standard-method-classes)
- (clos-slots-ref (get-slots method) *sm-%function-index*)
- (method-function method))))
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-%function-index+)
+ (method-function method)))
(defun safe-method-qualifiers (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
- (class (class-of method)))
- (if (member class standard-method-classes)
- (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
- (method-qualifiers method))))
+ (if (member (class-of method) **standard-method-classes** :test #'eq)
+ (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+)
+ (method-qualifiers method)))
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(let* ((existing-p (and methods (cdr methods) new-method))
nil)))
(when (arg-info-valid-p arg-info)
(dolist (method (if new-method (list new-method) methods))
- (let* ((specializers (if (or (eq *boot-state* 'complete)
+ (let* ((specializers (if (or (eq **boot-state** 'complete)
(not (consp method)))
(safe-method-specializers method)
(early-method-specializers method t)))
- (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+ (class (if (or (eq **boot-state** 'complete) (not (consp method)))
(class-of method)
(early-method-class method)))
(new-type
(when (and class
- (or (not (eq *boot-state* 'complete))
+ (or (not (eq **boot-state** 'complete))
(eq (generic-function-method-combination gf)
*standard-method-combination*)))
(cond ((or (eq class *the-class-standard-reader-method*)
(unless (gf-info-c-a-m-emf-std-p arg-info)
(setf (gf-info-simple-accessor-type arg-info) t))))
(unless was-valid-p
- (let ((name (if (eq *boot-state* 'complete)
+ (let ((name (if (eq **boot-state** 'complete)
(generic-function-name gf)
(!early-gf-name gf))))
(setf (gf-precompute-dfun-and-emf-p arg-info)
(package (symbol-package symbol)))
(and (or (eq package *pcl-package*)
(memq package (package-use-list *pcl-package*)))
+ (not (eq package #.(find-package "CL")))
;; FIXME: this test will eventually be
;; superseded by the *internal-pcl...* test,
;; above. While we are in a process of
;; remain.
(not (find #\Space (symbol-name symbol))))))))))
(setf (gf-info-fast-mf-p arg-info)
- (or (not (eq *boot-state* 'complete))
+ (or (not (eq **boot-state** 'complete))
(let* ((method-class (generic-function-method-class gf))
(methods (compute-applicable-methods
#'make-method-lambda
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(when lambda-list-p
- (proclaim (defgeneric-declaration spec lambda-list))
+ (setf (info :function :type spec)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list spec))
+ (info :function :where-from spec) :defined-method)
(if argument-precedence-order
(set-arg-info fin
:lambda-list lambda-list
(defun safe-gf-dfun-state (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
- (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+ (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+)
(gf-dfun-state generic-function)))
(defun (setf safe-gf-dfun-state) (new-value generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
- (setf (clos-slots-ref (get-slots generic-function)
- *sgf-dfun-state-index*)
+ (setf (clos-slots-ref (fsc-instance-slots generic-function)
+ +sgf-dfun-state-index+)
new-value)
(setf (gf-dfun-state generic-function) new-value)))
(list* dfun cache info)
dfun)))
(cond
- ((eq *boot-state* 'complete)
+ ((eq **boot-state** 'complete)
;; Check that we are under the lock.
#+sb-thread
(aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
(setf (safe-gf-dfun-state gf) new-state))
(t
- (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
+ (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)
new-state))))
dfun)
(defun gf-dfun-cache (gf)
- (let ((state (if (eq *boot-state* 'complete)
+ (let ((state (if (eq **boot-state** 'complete)
(safe-gf-dfun-state gf)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
(typecase state
(function nil)
(cons (cadr state)))))
(defun gf-dfun-info (gf)
- (let ((state (if (eq *boot-state* 'complete)
+ (let ((state (if (eq **boot-state** 'complete)
(safe-gf-dfun-state gf)
- (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+))))
(typecase state
(function nil)
(cons (cddr state)))))
-(defvar *sgf-name-index*
+(defconstant +sgf-name-index+
(!bootstrap-slot-index 'standard-generic-function 'name))
(defun !early-gf-name (gf)
- (clos-slots-ref (get-slots gf) *sgf-name-index*))
+ (clos-slots-ref (get-slots gf) +sgf-name-index+))
(defun gf-lambda-list (gf)
- (let ((arg-info (if (eq *boot-state* 'complete)
+ (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))
- (let ((methods (if (eq *boot-state* 'complete)
+ (let ((methods (if (eq **boot-state** 'complete)
(generic-function-methods gf)
(early-gf-methods gf))))
(if (null methods)
method-class)
(t (find-class method-class t ,env))))))))
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+ (unless lambda-list-p
+ ;; Use the existing lambda-list, if any. It is reasonable to do eg.
+ ;;
+ ;; (if (fboundp name)
+ ;; (ensure-generic-function name)
+ ;; (ensure-generic-function name :lambda-list '(foo)))
+ ;;
+ ;; in which case we end up here with no lambda-list in the first leg.
+ (setf (values lambda-list lambda-list-p)
+ (handler-case
+ (values (generic-function-lambda-list (fdefinition fun-name))
+ t)
+ ((or warning error) ()
+ (values nil nil)))))
+ (let ((gf-type
+ (specifier-type
+ (if lambda-list-p
+ (ftype-declaration-from-lambda-list lambda-list fun-name)
+ 'function)))
+ (old-type nil))
+ ;; FIXME: Ideally we would like to not clobber it, but because generic
+ ;; functions assert their FTYPEs callers believing the FTYPE are left with
+ ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type
+ ;; is a subtype of the old one, though -- even though the type is not
+ ;; trusted anymore, the warning is still not quite as interesting.
+ (when (and (eq :declared (info :function :where-from fun-name))
+ (not (csubtypep gf-type (setf old-type (info :function :type fun-name)))))
+ (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~S ~
+ for the same name with ~S.~:@>"
+ fun-name 'ftype
+ (type-specifier old-type)
+ (type-specifier gf-type)))
+ (setf (info :function :type fun-name) gf-type
+ (info :function :where-from fun-name) :defined-method)
+ fun-name))
+
(defun real-ensure-gf-using-class--generic-function
(existing
fun-name
(change-class existing generic-function-class))
(prog1
(apply #'reinitialize-instance existing all-keys)
- (when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
(defun real-ensure-gf-using-class--null
(existing
(setf (gdefinition fun-name)
(apply #'make-instance generic-function-class
:name fun-name all-keys))
- (when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
\f
(defun safe-gf-arg-info (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
(clos-slots-ref (fsc-instance-slots generic-function)
- *sgf-arg-info-index*)
+ +sgf-arg-info-index+)
(gf-arg-info generic-function)))
;;; FIXME: this function took on a slightly greater role than it
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &key slot-name object-class method-class-function)
+ &key slot-name object-class method-class-function
+ definition-source)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
initargs doc)
(when slot-name
(list :slot-name slot-name :object-class object-class
- :method-class-function method-class-function))))))
+ :method-class-function method-class-function))
+ (list :definition-source definition-source)))))
(initialize-method-function initargs result)
result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &rest args &key slot-name object-class method-class-function)
+ &rest args &key slot-name object-class method-class-function
+ definition-source)
(if method-class-function
(let* ((object-class (if (classp object-class) object-class
(find-class object-class)))
(apply #'make-instance
(apply method-class-function object-class slot-definition
initargs)
+ :definition-source definition-source
initargs)))
(apply #'make-instance class :qualifiers qualifiers
:lambda-list lambda-list :specializers specializers
(setf (fifth (fifth early-method)) new-value))
(defun early-add-named-method (generic-function-name qualifiers
- specializers arglist &rest initargs)
+ specializers arglist &rest initargs
+ &key documentation definition-source
+ &allow-other-keys)
(let* (;; we don't need to deal with the :generic-function-class
;; argument here because the default,
;; STANDARD-GENERIC-FUNCTION, is right for all early generic
(setf (getf (getf initargs 'plist) :name)
(make-method-spec gf qualifiers specializers))
(let ((new (make-a-method 'standard-method qualifiers arglist
- specializers initargs (getf initargs :documentation))))
+ specializers initargs documentation
+ :definition-source definition-source)))
(when existing (remove-method gf existing))
(add-method gf new))))
(t
(multiple-value-bind (parameters lambda-list specializers required)
(parse-specialized-lambda-list (cdr arglist))
+ ;; Check for valid arguments.
+ (unless (or (and (symbolp arg) (not (null arg)))
+ (and (consp arg)
+ (consp (cdr arg))
+ (null (cddr arg))))
+ (error 'specialized-lambda-list-error
+ :format-control "arg is not a non-NIL symbol or a list of two elements: ~A"
+ :format-arguments (list arg)))
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons (if (listp arg) (car arg) arg) lambda-list)
(cons (if (listp arg) (cadr arg) t) specializers)
(cons (if (listp arg) (car arg) arg) required)))))))
\f
-(setq *boot-state* 'early)
+(setq **boot-state** 'early)
\f
;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
;;; which used %WALKER stuff. That suggests to me that maybe the code
(defun extract-the (form)
(cond ((and (consp form) (eq (car form) 'the))
- (aver (proper-list-of-length-p 3))
+ (aver (proper-list-of-length-p form 3))
(third form))
(t
form)))
projects / sbcl.git / blobdiff