`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',fun-name))
- (load-defgeneric ',fun-name ',lambda-list ,@initargs)
+ (load-defgeneric ',fun-name ',lambda-list
+ (sb-c:source-location) ,@initargs)
,@(mapcar #'expand-method-definition methods)
(fdefinition ',fun-name)))))
(setf (info :function :type fun-name)
(specifier-type 'function))))
-(defun load-defgeneric (fun-name lambda-list &rest initargs)
+(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)))
(apply #'ensure-generic-function
fun-name
:lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
+ :definition-source source-location
initargs))
(define-condition generic-function-lambda-list-error
(defun prototypes-for-make-method-lambda (name)
(if (not (eq *boot-state* 'complete))
(values nil nil)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
(if (or (null gf?)
(not (generic-function-p gf?)))
;;;
;;; Note: During bootstrapping, this function is allowed to return NIL.
(defun method-prototype-for-gf (name)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
(cond ((neq *boot-state* 'complete) nil)
((or (null gf?)
;; addition to in the list. FIXME: We should no longer need to do
;; this, since the CLOS code is now SBCL-specific, and doesn't
;; need to be ported to every buggy compiler in existence.
- ',pv-table-symbol))
+ ',pv-table-symbol
+ (sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
(make-method-function-internal method-lambda env))
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
- (gboundp name)
+ (fboundp name)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
`(method-function-get ,method-function 'closure-generator))
(defun load-defmethod
- (class name quals specls ll initargs &optional pv-table-symbol)
+ (class name quals specls ll initargs pv-table-symbol source-location)
(setq initargs (copy-tree initargs))
(let ((method-spec (or (getf initargs :method-spec)
(make-method-spec name quals specls))))
(setf (getf initargs :method-spec) method-spec)
(load-defmethod-internal class name quals specls
- ll initargs pv-table-symbol)))
+ ll initargs pv-table-symbol
+ source-location)))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
- initargs pv-table-symbol)
+ initargs pv-table-symbol source-location)
(when pv-table-symbol
(setf (getf (getf initargs :plist) :pv-table-symbol)
pv-table-symbol))
gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
- :definition-source `((defmethod ,gf-spec
- ,@qualifiers
- ,specializers)
- ,*load-pathname*)
+ :definition-source source-location
initargs)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
(defun ensure-generic-function (fun-name
&rest all-keys
- &key environment
+ &key environment source-location
&allow-other-keys)
(declare (ignore environment))
- (let ((existing (and (gboundp fun-name)
+ (let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
(if (and existing
(eq *boot-state* 'complete)
(defmacro early-gf-methods (gf)
`(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*)
+ (generic-function-methods generic-function)))
+
(defvar *sgf-arg-info-index*
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
~S."
gf-keywords)))))))
+(defvar *sm-specializers-index*
+ (!bootstrap-slot-index 'standard-method 'specializers))
+(defvar *sm-fast-function-index*
+ (!bootstrap-slot-index 'standard-method 'fast-function))
+(defvar *sm-%function-index*
+ (!bootstrap-slot-index 'standard-method '%function))
+(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 fast-function %function plist))
+ (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))))
+
+(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))))
+(defun safe-method-fast-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-fast-function-index*)
+ (method-fast-function method))))
+(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))))
+(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)
+ (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*)))
+ (getf plist 'qualifiers))
+ (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))
(nreq (length (arg-info-metatypes arg-info)))
(dolist (method (if new-method (list new-method) methods))
(let* ((specializers (if (or (eq *boot-state* 'complete)
(not (consp method)))
- (method-specializers method)
+ (safe-method-specializers method)
(early-method-specializers method t)))
(class (if (or (eq *boot-state* 'complete) (not (consp method)))
(class-of method)
&key (lambda-list nil
lambda-list-p)
argument-precedence-order
+ source-location
&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)
+ argument-precedence-order source-location)
(error "The function ~S is not already defined." spec)))
(existing
(error "~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))))
+ argument-precedence-order source-location))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order)
+ function argument-precedence-order source-location)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
fin
(!bootstrap-set-slot 'standard-generic-function
fin
'source
- *load-pathname*)
+ source-location)
(set-fun-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(set-arg-info fin :lambda-list lambda-list))))
fin))
+(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*)
+ (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*)
+ new-value)
+ (setf (gf-dfun-state generic-function) new-value)))
+
(defun set-dfun (gf &optional dfun cache info)
(when cache
(setf (cache-owner cache) gf))
(list* dfun cache info)
dfun)))
(if (eq *boot-state* 'complete)
- (setf (gf-dfun-state gf) new-state)
+ (setf (safe-gf-dfun-state gf) new-state)
(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)
- (gf-dfun-state gf)
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(defun gf-dfun-info (gf)
(let ((state (if (eq *boot-state* 'complete)
- (gf-dfun-state gf)
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name 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*)
+ (gf-arg-info generic-function)))
+
+;;; FIXME: this function took on a slightly greater role than it
+;;; previously had around 2005-11-02, when CSR fixed the bug whereby
+;;; having more than one subclass of standard-generic-function caused
+;;; the whole system to die horribly through a metacircle in
+;;; GF-ARG-INFO. The fix is to be slightly more disciplined about
+;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
+;;; computing discriminating functions, so we need to be careful about
+;;; having a base case for the recursion, and we provide that with the
+;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet)
+;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
+;;; that stage, where all potentially dangerous cases are enumerated
+;;; and stopped. -- CSR, 2005-11-02.
(defun get-generic-fun-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(early-gf-arg-info gf)
- (gf-arg-info gf)))
+ (safe-gf-arg-info gf)))
(metatypes (arg-info-metatypes arg-info)))
(values (arg-info-applyp arg-info)
metatypes
(make-symbol (format nil "~S" method))))
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod spec)
- (and (setq gf (and (or errorp (gboundp gf-spec))
+ (and (setq gf (and (or errorp (fboundp gf-spec))
(gdefinition gf-spec)))
(let ((nreq (compute-discriminating-function-arglist-info gf)))
(setq specls (append (parse-specializers specls)
projects / sbcl.git / blobdiff