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*)
(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
(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: These nonstandard (DECLARE (SB-PCL::CLASS FOO BAR))
- ;; declarations should go away but as of 0.6.9.10, it's not
- ;; as simple as just deleting them.
+ ;; 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)
(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*
(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))
(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.
+;;; 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 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)))
(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)))
(dolist (fn *!early-functions*)
(sb-int:/show fn)
- (setf (gdefinition (car fn)) (symbol-function (caddr fn))))
+ (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
(sb-int:/show fixup)
(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
(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