(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))
(setf (gdefinition 'make-method-initargs-form)
(symbol-function 'real-make-method-initargs-form)))
+;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
+;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of
+;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the
+;;; REAL-MAKE-METHOD lambda is used as the body of the default method.
+;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function
+;;; so that changing it in a live image is easy, and changes actually
+;;; take effect.
(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
+ (make-method-lambda-internal proto-gf proto-method method-lambda env))
+
+(unless (fboundp 'make-method-lambda)
+ (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))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
parameters
specializers))
(slots (mapcar #'list required-parameters))
- (calls (list nil))
(class-declarations
`(declare
;; These declarations seem to be used by PCL to pass
;; 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
(walk-method-lambda method-lambda
required-parameters
env
- slots
- calls)
+ slots)
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
(when (some #'cdr slots)
- (multiple-value-bind (slot-name-lists call-list)
- (slot-name-lists-from-slots slots calls)
+ (let ((slot-name-lists (slot-name-lists-from-slots slots)))
(setq plist
`(,@(when slot-name-lists
`(:slot-name-lists ,slot-name-lists))
- ,@(when call-list
- `(:call-list ,call-list))
,@plist))
(setq walked-lambda-body
`((pv-binding (,required-parameters
,slot-name-lists
(load-time-value
(intern-pv-table
- :slot-name-lists ',slot-name-lists
- :call-list ',call-list)))
+ :slot-name-lists ',slot-name-lists)))
,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
,@(when plist `(plist ,plist))
,@(when documentation `(:documentation ,documentation)))))))))))
-(unless (fboundp 'make-method-lambda)
- (setf (gdefinition 'make-method-lambda)
- (symbol-function 'real-make-method-lambda)))
-
(defun real-make-method-specializers-form
(proto-gf proto-method specializer-names env)
(declare (ignore env proto-gf proto-method))
(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
'(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.
(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
- pv-cell
+ pv
next-method-call
arg-info)
(defstruct (constant-fast-method-call
(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
`(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
&rest required-args)
(macrolet ((generate-call (n)
``(funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args
,@(loop for x below ,n
(0 ,(generate-call 0))
(1 ,(generate-call 1))
(t (multiple-value-call (fast-method-call-function ,method-call)
- (values (fast-method-call-pv-cell ,method-call))
+ (values (fast-method-call-pv ,method-call))
(values (fast-method-call-next-method-call ,method-call))
,@required-args
(sb-c::%more-arg-values ,more-context 0 ,more-count))))))
(nreq (car arg-info)))
(if restp
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args)
(cond ((null args)
:format-arguments nil)))
(t
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args))))))
(method-call
when (eq key keyword)
return tail))
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(defun walk-method-lambda (method-lambda required-parameters env slots)
(let (;; flag indicating that CALL-NEXT-METHOD should be in the
;; method definition
(call-next-method-p nil)
;; 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)
(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
(set-fun-name mff fast-name))))
(when plist
(let ((plist plist))
- (let ((snl (getf plist :slot-name-lists))
- (cl (getf plist :call-list)))
- (when (or snl cl)
+ (let ((snl (getf plist :slot-name-lists)))
+ (when snl
(setf (method-plist-value method :pv-table)
- (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+ (intern-pv-table :slot-name-lists snl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
(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
(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))))
+
+(define-symbol-macro *standard-method-classes*
+ (list *the-class-standard-method* *the-class-standard-reader-method*
+ *the-class-standard-writer-method* *the-class-standard-boundp-method*
+ *the-class-global-reader-method* *the-class-global-writer-method*
+ *the-class-global-boundp-method*))
(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*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-slots method) *sm-specializers-index*)
(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*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-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*))
+ (let ((standard-method-classes *standard-method-classes*)
(class (class-of method)))
(if (member class standard-method-classes)
(clos-slots-ref (get-slots method) *sm-qualifiers-index*)
(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
lambda-list-p)
argument-precedence-order
source-location
+ documentation
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing
- argument-precedence-order source-location)
+ argument-precedence-order source-location
+ documentation)
(bug "The function ~S is not already defined." spec)))
(existing
(bug "~S should be on the list ~S."
(t
(pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p nil
- argument-precedence-order source-location))))
+ argument-precedence-order source-location
+ documentation))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order source-location)
+ function argument-precedence-order source-location
+ documentation)
(let ((fin (allocate-standard-funcallable-instance
*sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
has not been set." fin)))))
(setf (gdefinition spec) fin)
(!bootstrap-set-slot 'standard-generic-function fin 'name spec)
- (!bootstrap-set-slot 'standard-generic-function
- fin
- 'source
- source-location)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ 'source source-location)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ '%documentation documentation)
(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))
+ (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
(prog1
(apply #'reinitialize-instance existing all-keys)
(when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (setf (info :function :type fun-name)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list fun-name))
+ (info :function :where-from fun-name) :defined-method))))
(defun real-ensure-gf-using-class--null
(existing
(apply #'make-instance generic-function-class
:name fun-name all-keys))
(when lambda-list-p
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (setf (info :function :type fun-name)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list fun-name))
+ (info :function :where-from fun-name) :defined-method))))
\f
(defun safe-gf-arg-info (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
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 ())))
+ specializers initargs documentation
+ :definition-source definition-source)))
(when existing (remove-method gf existing))
(add-method gf new))))
projects / sbcl.git / blobdiff