are used to get enough of the system running that it is possible to
create real generic functions and methods and implement real method
lookup. At that point (done in the file FIXUP) the function
-fix-early-generic-functions is called to convert all the early generic
+!FIX-EARLY-GENERIC-FUNCTIONS is called to convert all the early generic
functions to real generic functions.
The cheap generic functions are built using the same
-funcallable-instance objects real generic-functions are made out of.
+FUNCALLABLE-INSTANCE objects that real generic functions are made out of.
This means that as PCL is being bootstrapped, the cheap generic
function objects which are being created are the same objects which
will later be real generic functions. This is good because:
during booting because those pointers will still point to
the right object after the generic functions are all fixed up.
-This file defines the defmethod macro and the mechanism used to expand
+This file defines the DEFMETHOD macro and the mechanism used to expand
it. This includes the mechanism for processing the body of a method.
DEFMETHOD basically expands into a call to LOAD-DEFMETHOD, which
-basically calls ADD-METHOD to add the method to the generic-function.
+basically calls ADD-METHOD to add the method to the generic function.
These expansions can be loaded either during bootstrapping or when PCL
is fully up and running.
An important effect of this arrangement is it means we can compile
-files with defmethod forms in them in a completely running PCL, but
+files with DEFMETHOD forms in them in a completely running PCL, but
then load those files back in during bootstrapping. This makes
development easier. It also means there is only one set of code for
-processing defmethod. Bootstrapping works by being sure to have
-load-method be careful to call only primitives which work during
+processing DEFMETHOD. Bootstrapping works by being sure to have
+LOAD-METHOD be careful to call only primitives which work during
bootstrapping.
|#
+;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type
+;;; of declaration internally. It would be good to figure out how to
+;;; get rid of it, or failing that, (1) document why it's needed and
+;;; (2) use a private symbol with a forbidding name which suggests
+;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS)
+;;; instead of the too-inviting CLASS. (I tried just deleting the
+;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but
+;;; 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
add-method
remove-method))
-(defvar *early-functions*
+(defvar *!early-functions*
'((make-a-method early-make-a-method
real-make-a-method)
(add-named-method early-add-named-method
real-add-named-method)
))
-;;; For each of the early functions, arrange to have it point to its early
-;;; definition. Do this in a way that makes sure that if we redefine one
-;;; of the early definitions the redefinition will take effect. This makes
-;;; development easier.
-;;;
-;;; The function which generates the redirection closure is pulled out into
-;;; a separate piece of code because of a bug in ExCL which causes this not
-;;; to work if it is inlined.
-;;; FIXME: We no longer need to worry about ExCL now, so we could unscrew this.
+;;; For each of the early functions, arrange to have it point to its
+;;; early definition. Do this in a way that makes sure that if we
+;;; redefine one of the early definitions the redefinition will take
+;;; effect. This makes development easier.
(eval-when (:load-toplevel :execute)
-
-(defun redirect-early-function-internal (real early)
- (setf (gdefinition real)
- (set-function-name
- #'(lambda (&rest args)
- (apply (the function (symbol-function early)) args))
- real)))
-
-(dolist (fns *early-functions*)
+
+(dolist (fns *!early-functions*)
(let ((name (car fns))
(early-name (cadr fns)))
- (redirect-early-function-internal name early-name)))
-
+ (setf (gdefinition name)
+ (set-function-name
+ #'(lambda (&rest args)
+ (apply (the function (name-get-fdefinition early-name)) args))
+ name))))
) ; EVAL-WHEN
-;;; *GENERIC-FUNCTION-FIXUPS* is used by fix-early-generic-functions to
-;;; convert the few functions in the bootstrap which are supposed to be
-;;; generic functions but can't be early on.
-(defvar *generic-function-fixups*
+;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
+;;; to convert the few functions in the bootstrap which are supposed
+;;; to be generic functions but can't be early on.
+(defvar *!generic-function-fixups*
'((add-method
((generic-function method) ;lambda-list
(standard-generic-function method) ;specializers
(expand-defgeneric function-name lambda-list options))
(defun expand-defgeneric (function-name lambda-list options)
- (when (listp function-name)
- (do-standard-defsetf-1 (sb-int:function-name-block-name function-name)))
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',function-name))
- ,(make-top-level-form
- `(defgeneric ,function-name)
- *defgeneric-times*
- `(load-defgeneric ',function-name ',lambda-list ,@initargs))
+ (load-defgeneric ',function-name ',lambda-list ,@initargs)
,@(mapcar #'expand-method-definition methods)
`,(function ,function-name)))))
(sb-kernel:specifier-type 'function))))
(defun load-defgeneric (function-name lambda-list &rest initargs)
- (when (listp function-name)
- (do-standard-defsetf-1 (cadr function-name)))
(when (fboundp function-name)
(sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name))
(apply #'ensure-generic-function
initargs))
\f
(defmacro defmethod (&rest args &environment env)
- (declare (arglist name
- {method-qualifier}*
- specialized-lambda-list
- &body body))
(multiple-value-bind (name qualifiers lambda-list body)
(parse-defmethod args)
(multiple-value-bind (proto-gf proto-method)
lambda-list
body
env)
- (when (listp name)
- (do-standard-defsetf-1 (cadr name)))
(let ((*make-instance-function-keys* nil)
(*optimize-asv-funcall-p* t)
(*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
;; prefixes.)
(*package* sb-int:*keyword-package*))
(format nil "~S" mname)))))
- `(eval-when ,*defmethod-times*
+ `(eval-when (:load-toplevel :execute)
(defun ,mname-sym ,(cadr fn-lambda)
,@(cddr fn-lambda))
,(make-defmethod-form-internal
#',mname-sym
,@(cdddr initargs-form))
pv-table-symbol)))
- (make-top-level-form
- `(defmethod ,name ,@qualifiers ,specializers)
- *defmethod-times*
- (make-defmethod-form-internal
- name qualifiers
+ (make-defmethod-form-internal
+ name qualifiers
`(list ,@(mapcar #'(lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
,,(cadr specializer))
`',specializer))
- specializers))
+ specializers))
unspecialized-lambda-list method-class-name
initargs-form
- pv-table-symbol)))))
+ pv-table-symbol))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
(extract-declarations body env)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
- (declare (method-name ,(list name qualifiers specializers)))
- (declare (method-lambda-list ,@lambda-list))
+ (declare (%method-name ,(list name qualifiers specializers)))
+ (declare (%method-lambda-list ,@lambda-list))
,@declarations
,@real-body)
unspecialized-lambda-list specializers))))
(declare (ignore proto-gf proto-method))
(make-method-lambda-internal method-lambda env))
+;;; a helper function for creating Python-friendly type declarations
+;;; in DEFMETHOD forms
+(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
+ (cond ((and (consp specializer)
+ (eq (car specializer) 'eql))
+ ;; KLUDGE: ANSI, in its wisdom, says that
+ ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
+ ;; DEFMETHOD expansion time. Thus, although one might think
+ ;; that in
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 12))
+ ;; ..))
+ ;; the PACKAGE and (EQL 12) forms are both parallel type
+ ;; names, they're not, as is made clear when you do
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 'BAR)))
+ ;; ..)
+ ;; where Y needs to be a symbol named "BAR", not some cons
+ ;; made by (CONS 'QUOTE 'BAR). I.e. when the
+ ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
+ ;; to be of type (EQL X). It'd be easy to transform one to
+ ;; the other, but it'd be somewhat messier to do so while
+ ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
+ ;; once. (The new code wouldn't be messy, but it'd require a
+ ;; big transformation of the old code.) So instead we punt.
+ ;; -- WHN 20000610
+ '(ignorable))
+ ((member specializer
+ ;; KLUDGE: For some low-level implementation
+ ;; classes, perhaps because of some problems related
+ ;; to the incomplete integration of PCL into SBCL's
+ ;; type system, some specializer classes can't be
+ ;; declared as argument types. E.g.
+ ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
+ ;; (DECLARE (TYPE SLOT-OBJECT X))
+ ;; ..)
+ ;; loses when
+ ;; (DEFSTRUCT BAR A B)
+ ;; (FOO (MAKE-BAR))
+ ;; perhaps because of the way that STRUCTURE-OBJECT
+ ;; inherits both from SLOT-OBJECT and from
+ ;; SB-KERNEL:INSTANCE. In an effort to sweep such
+ ;; problems under the rug, we exclude these problem
+ ;; cases by blacklisting them here. -- WHN 2001-01-19
+ '(slot-object))
+ '(ignorable))
+ ((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
+ ;; second argument.) Hopefully it only does this kind of
+ ;; weirdness when bootstrapping.. -- WHN 20000610
+ '(ignorable))
+ (t
+ ;; Otherwise, we can make Python very happy.
+ `(type ,specializer ,parameter))))
+
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
method-lambda))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations (cddr method-lambda) env)
- (let* ((name-decl (get-declaration 'method-name declarations))
- (sll-decl (get-declaration 'method-lambda-list declarations))
+ (let* ((name-decl (get-declaration '%method-name declarations))
+ (sll-decl (get-declaration '%method-lambda-list declarations))
(method-name (when (consp name-decl) (car name-decl)))
(generic-function-name (when method-name (car method-name)))
(specialized-lambda-list (or sll-decl (cadr method-lambda))))
(calls (list nil))
(class-declarations
`(declare
- ;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR))
- ;; declarations used for anything any more?
- ;; WHN 2000-12-21: I think not, commented 'em out to see..
+ ;; These declarations seem to be used by PCL to pass
+ ;; information to itself; when I tried to delete 'em
+ ;; ca. 0.6.10 it didn't work. I'm not sure how
+ ;; they work, but note the (VARIABLE-DECLARATION '%CLASS ..)
+ ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
,@(remove nil
(mapcar (lambda (a s) (and (symbolp s)
(neq s 't)
- `(class ,a ,s)))
+ `(%class ,a ,s)))
parameters
specializers))
;; These TYPE declarations weren't in the original
- ;; PCL code, but Python likes them a lot. (We're
- ;; telling the compiler about our knowledge of
- ;; specialized argument types so that it can avoid
- ;; run-time type overhead, which can be a big win
- ;; for Python.)
- ,@(mapcar (lambda (a s)
- (cond ((and (consp s)
- (eql (car s) 'eql))
- ;; KLUDGE: ANSI, in its wisdom, says
- ;; that EQL-SPECIALIZER-FORMs in EQL
- ;; specializers are evaluated at
- ;; DEFMETHOD expansion time. Thus,
- ;; although one might think that in
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 12))
- ;; ..))
- ;; the PACKAGE and (EQL 12) forms are
- ;; both parallel type names, they're
- ;; not, as is made clear when you do
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 'BAR)))
- ;; ..)
- ;; where Y needs to be a symbol
- ;; named "BAR", not some cons made by
- ;; (CONS 'QUOTE 'BAR). I.e. when
- ;; the EQL-SPECIALIZER-FORM is (EQL 'X),
- ;; it requires an argument to be of
- ;; type (EQL X). It'd be easy to transform
- ;; one to the other, but it'd be somewhat
- ;; messier to do so while ensuring that
- ;; the EQL-SPECIALIZER-FORM is only
- ;; EVAL'd once. (The new code wouldn't
- ;; be messy, but it'd require a big
- ;; transformation of the old code.)
- ;; So instead we punt. -- WHN 20000610
- '(ignorable))
- ((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 second argument.)
- ;; Hopefully it only does this kind
- ;; of weirdness when bootstrapping..
- ;; -- WHN 20000610
- '(ignorable))
- (t
- ;; Otherwise, we can make Python
- ;; very happy.
- `(type ,s ,a))))
+ ;; PCL code, but the Python compiler likes them a
+ ;; lot. (We're telling the compiler about our
+ ;; knowledge of specialized argument types so that
+ ;; it can avoid run-time type dispatch overhead,
+ ;; which can be a huge win for Python.)
+ ;;
+ ;; FIXME: Perhaps these belong in
+ ;; ADD-METHOD-DECLARATIONS instead of here?
+ ,@(mapcar #'parameter-specializer-declaration-in-defmethod
parameters
specializers)))
(method-lambda
(constantp (car real-body))))
(constant-value (and constant-value-p
(eval (car real-body))))
- ;; FIXME: This can become a bare AND (no IF), just like
- ;; the expression for CONSTANT-VALUE just above.
- (plist (if (and constant-value-p
- (or (typep constant-value
- '(or number character))
- (and (symbolp constant-value)
- (symbol-package constant-value))))
- (list :constant-value constant-value)
- ()))
+ (plist (and constant-value-p
+ (or (typep constant-value
+ '(or number character))
+ (and (symbolp constant-value)
+ (symbol-package constant-value)))
+ (list :constant-value constant-value)))
(applyp (dolist (p lambda-list nil)
(cond ((memq p '(&optional &rest &key))
(return t))
`(((typep ,emf 'fixnum)
(let* ((.slots. (get-slots-or-nil
,(car required-args+rest-arg)))
- (value (when .slots. (%instance-ref .slots. ,emf))))
+ (value (when .slots. (clos-slots-ref .slots. ,emf))))
(if (eq value +slot-unbound+)
(slot-unbound-internal ,(car required-args+rest-arg)
,emf)
(let ((.new-value. ,(car required-args+rest-arg))
(.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
- (when .slots. ; just to avoid compiler warnings
- (setf (%instance-ref .slots. ,emf) .new-value.))))))
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
#||
,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
`(((typep ,emf 'fast-instance-boundp)
(let ((.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
(and .slots.
- (not (eq (%instance-ref
+ (not (eq (clos-slots-ref
.slots. (fast-instance-boundp-index ,emf))
+slot-unbound+)))))))
||#
(fixnum
(cond ((null args) (error "1 or 2 args were expected."))
((null (cdr args))
- (let ((value (%instance-ref (get-slots (car args)) emf)))
+ (let* ((slots (get-slots (car args)))
+ (value (clos-slots-ref slots emf)))
(if (eq value +slot-unbound+)
(slot-unbound-internal (car args) emf)
value)))
((null (cddr args))
- (setf (%instance-ref (get-slots (cadr args)) emf)
- (car args)))
+ (setf (clos-slots-ref (get-slots (cadr args)) emf)
+ (car args)))
(t (error "1 or 2 args were expected."))))
(fast-instance-boundp
(if (or (null args) (cdr args))
(error "1 arg was expected.")
- (not (eq (%instance-ref (get-slots (car args))
- (fast-instance-boundp-index emf))
- +slot-unbound+))))
+ (let ((slots (get-slots (car args))))
+ (not (eq (clos-slots-ref slots
+ (fast-instance-boundp-index emf))
+ +slot-unbound+)))))
(function
(apply emf args))))
(setq closurep t)
form)
(t nil))))
- (;; FIXME: should be MEMQ or FIND :TEST #'EQ
- (and (or (eq (car form) 'slot-value)
- (eq (car form) 'set-slot-value)
- (eq (car form) 'slot-boundp))
+ ((and (memq (car form)
+ '(slot-value set-slot-value slot-boundp))
(constantp (caddr form)))
- (let ((parameter (can-optimize-access form
- required-parameters
- env)))
- ;; FIXME: could be
- ;; (LET ((FUN (ECASE (CAR FORM) ..)))
- ;; (FUNCALL FUN SLOTS PARAMETER FORM))
- (ecase (car form)
- (slot-value
- (optimize-slot-value slots parameter form))
- (set-slot-value
- (optimize-set-slot-value slots parameter form))
- (slot-boundp
- (optimize-slot-boundp slots parameter form)))))
+ (let ((parameter
+ (can-optimize-access form required-parameters env)))
+ (let ((fun (ecase (car form)
+ (slot-value #'optimize-slot-value)
+ (set-slot-value #'optimize-set-slot-value)
+ (slot-boundp #'optimize-slot-boundp))))
+ (funcall fun slots parameter form))))
((and (eq (car form) 'apply)
(consp (cadr form))
(eq (car (cadr form)) 'function)
*mf1p* (gethash method-function *method-function-plist*)))
*mf1p*)
-(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-PLIST
- #+setf (setf method-function-plist)
+(defun (setf method-function-plist)
(val method-function)
(unless (eq method-function *mf1*)
(rotatef *mf1* *mf2*)
(defun method-function-get (method-function key &optional default)
(getf (method-function-plist method-function) key default))
-(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-GET
- #+setf (setf method-function-get)
+(defun (setf method-function-get)
(val method-function key)
(setf (getf (method-function-plist method-function) key) val))
(defun load-defmethod
(class name quals specls ll initargs &optional pv-table-symbol)
- (when (listp name) (do-standard-defsetf-1 (cadr name)))
(setq initargs (copy-tree initargs))
(let ((method-spec (or (getf initargs ':method-spec)
(make-method-spec name quals specls))))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
initargs pv-table-symbol)
- (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
(when pv-table-symbol
(setf (getf (getf initargs ':plist) :pv-table-symbol)
pv-table-symbol))
- ;; FIXME: It seems as though I should be able to get this to work.
- ;; But it keeps on screwing up PCL bootstrapping.
- #+nil
(when (and (eq *boot-state* 'complete)
(fboundp gf-spec))
- (let* ((gf (symbol-function gf-spec))
+ (let* ((gf (name-get-fdefinition gf-spec))
(method (and (generic-function-p gf)
(find-method gf
qualifiers
- (mapcar #'find-class specializers)
+ (parse-specializers specializers)
nil))))
(when method
(sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
keywords keyword-parameters)
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
- (let* ((old (sb-c::info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-c::function-type-p old) old nil))
- (old-restp (and old-ftype (sb-c::function-type-rest old-ftype)))
+ (let* ((old (sb-int:info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (old-ftype (if (sb-kernel:function-type-p old) old nil))
+ (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-c::key-info-name
- (sb-c::function-type-keywords old-ftype))))
- (old-keysp (and old-ftype (sb-c::function-type-keyp old-ftype)))
- (old-allowp (and old-ftype (sb-c::function-type-allowp old-ftype)))
+ (mapcar #'sb-kernel:key-info-name
+ (sb-kernel:function-type-keywords old-ftype))))
+ (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
+ (old-allowp (and old-ftype (sb-kernel:function-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element 't)
(when (plusp noptional)
\f
;;;; early generic function support
-(defvar *early-generic-functions* ())
+(defvar *!early-generic-functions* ())
(defun ensure-generic-function (function-name
&rest all-keys
(early-collect-inheritance 'standard-generic-function)))
(defvar *sgf-method-class-index*
- (bootstrap-slot-index 'standard-generic-function 'method-class))
+ (!bootstrap-slot-index 'standard-generic-function 'method-class))
(defun early-gf-p (x)
(and (fsc-instance-p x)
- (eq (instance-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*
- (bootstrap-slot-index 'standard-generic-function 'methods))
+ (!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
- `(instance-ref (get-slots ,gf) *sgf-methods-index*))
+ `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
(defvar *sgf-arg-info-index*
- (bootstrap-slot-index 'standard-generic-function 'arg-info))
+ (!bootstrap-slot-index 'standard-generic-function 'arg-info))
(defmacro early-gf-arg-info (gf)
- `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
+ `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
(defvar *sgf-dfun-state-index*
- (bootstrap-slot-index 'standard-generic-function 'dfun-state))
+ (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
(:conc-name nil)
(unless was-valid-p
(let ((name (if (eq *boot-state* 'complete)
(generic-function-name gf)
- (early-gf-name gf))))
+ (!early-gf-name gf))))
(esetf (gf-precompute-dfun-and-emf-p arg-info)
(let* ((sym (if (atom name) name (cadr name)))
(pkg-list (cons *pcl-package*
(class-name (cadr specls)))))))))
arg-info)
-;;; This is the early definition of ensure-generic-function-using-class.
+;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
;;;
-;;; The static-slots field of the funcallable instances used as early generic
-;;; functions is used to store the early methods and early discriminator code
-;;; for the early generic function. The static slots field of the fins
-;;; contains a list whose:
+;;; The STATIC-SLOTS field of the funcallable instances used as early
+;;; generic functions is used to store the early methods and early
+;;; discriminator code for the early generic function. The static
+;;; slots field of the fins contains a list whose:
;;; CAR - a list of the early methods on this early gf
;;; CADR - the early discriminator code for this method
(defun ensure-generic-function-using-class (existing spec &rest keys
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
existing)
- ((assoc spec *generic-function-fixups* :test #'equal)
+ ((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing)
(error "The function ~S is not already defined." spec)))
(existing
(error "~S should be on the list ~S."
spec
- '*generic-function-fixups*))
+ '*!generic-function-fixups*))
(t
- (pushnew spec *early-generic-functions* :test #'equal)
+ (pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
(error "The function of the funcallable-instance ~S~
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 *load-truename*)
+ (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
+ (!bootstrap-set-slot 'standard-generic-function
+ fin
+ 'source
+ *load-truename*)
(set-function-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
dfun)))
(if (eq *boot-state* 'complete)
(setf (gf-dfun-state gf) new-state)
- (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) 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)
- (instance-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)
(gf-dfun-state gf)
- (instance-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*
- (bootstrap-slot-index 'standard-generic-function 'name))
+ (!bootstrap-slot-index 'standard-generic-function 'name))
-(defun early-gf-name (gf)
- (instance-ref (get-slots gf) *sgf-name-index*))
+(defun !early-gf-name (gf)
+ (clos-slots-ref (get-slots gf) *sgf-name-index*))
(defun gf-lambda-list (gf)
(let ((arg-info (if (eq *boot-state* 'complete)
(defun early-method-standard-accessor-slot-name (early-method)
(seventh (fifth early-method)))
-;;; Fetch the specializers of an early method. This is basically just a
-;;; simple accessor except that when the second argument is t, this converts
-;;; the specializers from symbols into class objects. The class objects
-;;; are cached in the early method, this makes bootstrapping faster because
-;;; the class objects only have to be computed once.
+;;; Fetch the specializers of an early method. This is basically just
+;;; a simple accessor except that when the second argument is t, this
+;;; converts the specializers from symbols into class objects. The
+;;; class objects are cached in the early method, this makes
+;;; bootstrapping faster because the class objects only have to be
+;;; computed once.
+;;;
;;; NOTE:
-;;; the second argument should only be passed as T by early-lookup-method.
-;;; this is to implement the rule that only when there is more than one
-;;; early method on a generic function is the conversion from class names
-;;; to class objects done.
-;;; the corresponds to the fact that we are only allowed to have one method
-;;; on any generic function up until the time classes exist.
+;;; The second argument should only be passed as T by
+;;; early-lookup-method. This is to implement the rule that only when
+;;; there is more than one early method on a generic function is the
+;;; conversion from class names to class objects done. This
+;;; corresponds to the fact that we are only allowed to have one
+;;; method on any generic function up until the time classes exist.
(defun early-method-specializers (early-method &optional objectsp)
(if (and (listp early-method)
(eq (car early-method) :early-method))
(when existing (remove-method gf existing))
(add-method gf new)))
-;;; This is the early version of add-method. Later this will become a
-;;; generic function. See fix-early-generic-functions which has special
-;;; knowledge about add-method.
+;;; This is the early version of ADD-METHOD. Later this will become a
+;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has
+;;; special knowledge about ADD-METHOD.
(defun add-method (generic-function method)
(when (not (fsc-instance-p generic-function))
- (error "Early add-method didn't get a funcallable instance."))
+ (error "Early ADD-METHOD didn't get a funcallable instance."))
(when (not (and (listp method) (eq (car method) :early-method)))
- (error "Early add-method didn't get an early method."))
+ (error "Early ADD-METHOD didn't get an early method."))
(push method (early-gf-methods generic-function))
(set-arg-info generic-function :new-method method)
- (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+ (unless (assoc (!early-gf-name generic-function)
+ *!generic-function-fixups*
:test #'equal)
(update-dfun generic-function)))
-;;; This is the early version of REMOVE-METHOD..
+;;; This is the early version of REMOVE-METHOD. See comments on
+;;; the early version of ADD-METHOD.
(defun remove-method (generic-function method)
(when (not (fsc-instance-p generic-function))
(error "An early remove-method didn't get a funcallable instance."))
(setf (early-gf-methods generic-function)
(remove method (early-gf-methods generic-function)))
(set-arg-info generic-function)
- (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+ (unless (assoc (!early-gf-name generic-function)
+ *!generic-function-fixups*
:test #'equal)
(update-dfun generic-function)))
-;;; ..and the early version of GET-METHOD.
+;;; This is the early version of GET-METHOD. See comments on the early
+;;; version of ADD-METHOD.
(defun get-method (generic-function qualifiers specializers
&optional (errorp t))
(if (early-gf-p generic-function)
nil))
(real-get-method generic-function qualifiers specializers errorp)))
-(defvar *fegf-debug-p* nil)
-
-(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
+(defun !fix-early-generic-functions ()
+ (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
(let ((accessors nil))
- ;; Rearrange *EARLY-GENERIC-FUNCTIONS* to speed up
+ ;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
;; FIX-EARLY-GENERIC-FUNCTIONS.
- (dolist (early-gf-spec *early-generic-functions*)
+ (dolist (early-gf-spec *!early-generic-functions*)
+ (sb-int:/show early-gf-spec)
(when (every #'early-method-standard-accessor-p
(early-gf-methods (gdefinition early-gf-spec)))
(push early-gf-spec accessors)))
standard-class-p
funcallable-standard-class-p
specializerp)))
- (setq *early-generic-functions*
- (cons spec (delete spec *early-generic-functions* :test #'equal))))
+ (sb-int:/show spec)
+ (setq *!early-generic-functions*
+ (cons spec
+ (delete spec *!early-generic-functions* :test #'equal))))
- (dolist (early-gf-spec *early-generic-functions*)
- (when noisyp (format t "~&~S..." early-gf-spec))
+ (dolist (early-gf-spec *!early-generic-functions*)
+ (sb-int:/show early-gf-spec)
(let* ((gf (gdefinition early-gf-spec))
(methods (mapcar #'(lambda (early-method)
(let ((args (copy-list (fifth
*standard-method-combination*)
(set-methods gf methods)))
- (dolist (fns *early-functions*)
- (setf (gdefinition (car fns)) (symbol-function (caddr fns))))
+ (dolist (fn *!early-functions*)
+ (sb-int:/show fn)
+ (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
- (dolist (fixup *generic-function-fixups*)
+ (dolist (fixup *!generic-function-fixups*)
+ (sb-int:/show fixup)
(let* ((fspec (car fixup))
(gf (gdefinition fspec))
(methods (mapcar #'(lambda (method)
(specializers (second method))
(method-fn-name (third method))
(fn-name (or method-fn-name fspec))
- (fn (symbol-function fn-name))
+ (fn (name-get-fdefinition fn-name))
(initargs
(list :function
(set-function-name
(setf (generic-function-method-class gf) *the-class-standard-method*)
(setf (generic-function-method-combination gf)
*standard-method-combination*)
- (set-methods gf methods)))))
+ (set-methods gf methods))))
+ (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
\f
-;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument into
-;;; the 'real' arguments. This is where the syntax of DEFMETHOD is really
-;;; implemented.
+;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
+;;; into the 'real' arguments. This is where the syntax of DEFMETHOD
+;;; is really implemented.
(defun parse-defmethod (cdr-of-form)
;;(declare (values name qualifiers specialized-lambda-list body))
(let ((name (pop cdr-of-form))
(unparse-specializers (method-specializers specializers-or-method))))
(defun parse-method-or-spec (spec &optional (errorp t))
- ;;(declare (values generic-function method method-name))
(let (gf method name temp)
(if (method-p spec)
(setq method spec
;; "internal error: unrecognized lambda-list keyword ~S"?
(warn "Unrecognized lambda-list keyword ~S in arglist.~%~
Assuming that the symbols following it are parameters,~%~
- and not allowing any parameter specializers to follow~%~
- to follow it."
+ and not allowing any parameter specializers to follow it."
arg))
- ;; When we are at a lambda-list keyword, the parameters don't
- ;; include the lambda-list keyword; the lambda-list does include
- ;; the lambda-list keyword; and no specializers are allowed to
- ;; follow the lambda-list keywords (at least for now).
+ ;; When we are at a lambda-list keyword, the parameters
+ ;; don't include the lambda-list keyword; the lambda-list
+ ;; does include the lambda-list keyword; and no
+ ;; specializers are allowed to follow the lambda-list
+ ;; keywords (at least for now).
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
(values parameters
(eval-when (:load-toplevel :execute)
(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 walker stuff was
-;;; only used for implementing stuff like that; maybe it's not needed any more?
-;;; Hunt down what it was used for and see.
+;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
+;;; which used %WALKER stuff. That suggests to me that maybe the code
+;;; walker stuff was only used for implementing stuff like that; maybe
+;;; it's not needed any more? Hunt down what it was used for and see.
(defmacro with-slots (slots instance &body body)
(let ((in (gensym)))
(third instance)
instance)))
(and (symbolp instance)
- `((declare (variable-rebinding ,in ,instance)))))
+ `((declare (%variable-rebinding ,in ,instance)))))
,in
(symbol-macrolet ,(mapcar #'(lambda (slot-entry)
(let ((variable-name
(third instance)
instance)))
(and (symbolp instance)
- `((declare (variable-rebinding ,in ,instance)))))
+ `((declare (%variable-rebinding ,in ,instance)))))
,in
(symbol-macrolet ,(mapcar #'(lambda (slot-entry)
(let ((variable-name (car slot-entry))
projects / sbcl.git / blobdiff