(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.
,call-next-method-p
:next-method-p-p ,next-method-p-p
:setq-p ,setq-p
+ :parameters-setqd ,parameters-setqd
:method-cell ,method-cell
:closurep ,closurep
:applyp ,applyp)
(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)
;; 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
;; the user defines a type and calls (SETF
;; FIND-CLASS) in a consistent way.
(when (and class (typep class 'built-in-class))
- `(type ,specializer-nameoid ,parameter))))
+ `(type ,(class-name class) ,parameter))))
((:instance nil)
(let ((class (specializer-nameoid-class)))
(cond
(defmacro bind-simple-lexical-method-functions
((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
- closurep applyp method-cell))
+ parameters-setqd closurep applyp method-cell))
&body body
&environment env)
(if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
(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)
((args rest-arg next-method-call (&key
call-next-method-p
setq-p
+ parameters-setqd
method-cell
next-method-p-p
closurep
(setq next-method-p-p t)
form)
((memq (car form) '(setq multiple-value-setq))
- ;; FIXME: this is possibly a little strong as
- ;; conditions go. Ideally we would want to detect
- ;; which, if any, of the method parameters are
- ;; being set, and communicate that information to
- ;; e.g. SPLIT-DECLARATIONS. However, the brute
- ;; force method doesn't really cost much; a little
- ;; loss of discrimination over IGNORED variables
- ;; should be all. -- CSR, 2004-07-01
- ;;
- ;; As of 2006-09-18 modified parameter bindings
- ;; are now tracked with more granularity than just
- ;; one SETQ-P flag, in order to disable SLOT-VALUE
- ;; optimizations for parameters that are SETQd.
- ;; The old binary SETQ-P flag is still used for
- ;; all other purposes, since as noted above, the
- ;; extra cost is minimal. -- JES, 2006-09-18
- ;;
;; The walker will split (SETQ A 1 B 2) to
;; separate (SETQ A 1) and (SETQ B 2) forms, so we
;; only need to handle the simple case of SETQ
(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)
(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 '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*))
+(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 *standard-method-classes*)
- (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 *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))))
+ (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 *standard-method-classes*)
- (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)
;; 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
(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)
(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
(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
projects / sbcl.git / blobdiff