;;; 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
-;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
-;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
-;;; overwrite it.
-(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
- #'check-wrapper-validity)
-
(declaim (notinline make-a-method
add-named-method
ensure-generic-function-using-class
-
add-method
remove-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.
-(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)))
-
+;;; 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.
(dolist (fns *!early-functions*)
(let ((name (car fns))
(early-name (cadr fns)))
- (redirect-early-function-internal name early-name)))
-
-) ; EVAL-WHEN
+ (setf (gdefinition name)
+ (set-fun-name
+ (lambda (&rest args)
+ (apply (fdefinition early-name) args))
+ name))))
;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
;;; to convert the few functions in the bootstrap which are supposed
(standard-generic-function t t)
real-get-method))
(ensure-generic-function-using-class
- ((generic-function function-name
+ ((generic-function fun-name
&key generic-function-class environment
&allow-other-keys)
(generic-function t)
real-ensure-gf-using-class--generic-function)
- ((generic-function function-name
+ ((generic-function fun-name
&key generic-function-class environment
&allow-other-keys)
(null t)
(generic-function standard-method-combination t)
standard-compute-effective-method))))
\f
-(defmacro defgeneric (function-name lambda-list &body options)
- (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)))
+(defmacro defgeneric (fun-name lambda-list &body options)
+ (declare (type list lambda-list))
+ (unless (legal-fun-name-p fun-name)
+ (error 'simple-program-error
+ :format-control "illegal generic function name ~S"
+ :format-arguments (list fun-name)))
+ (check-gf-lambda-list lambda-list)
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "The option ~S appears more than once."
:format-arguments (list name)))
(expand-method-definition (qab) ; QAB = qualifiers, arglist, body
(arglist (elt qab arglist-pos))
(qualifiers (subseq qab 0 arglist-pos))
(body (nthcdr (1+ arglist-pos) qab)))
- (when (not (equal (cadr (getf initargs :method-combination))
- qualifiers))
- (error "bad method specification in DEFGENERIC ~A~%~
- -- qualifier mismatch for lambda list ~A"
- function-name arglist))
- `(defmethod ,function-name ,@qualifiers ,arglist ,@body))))
+ `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
+ (generic-function-initial-methods #',fun-name)))))
(macrolet ((initarg (key) `(getf initargs ,key)))
(dolist (option options)
(let ((car-option (car option)))
(case car-option
(declare
- (push (cdr option) (initarg :declarations)))
+ (when (and
+ (consp (cadr option))
+ (member (first (cadr option))
+ ;; FIXME: this list is slightly weird.
+ ;; ANSI (on the DEFGENERIC page) in one
+ ;; place allows only OPTIMIZE; in
+ ;; another place gives this list of
+ ;; disallowed declaration specifiers.
+ ;; This seems to be the only place where
+ ;; the FUNCTION declaration is
+ ;; mentioned; TYPE seems to be missing.
+ ;; Very strange. -- CSR, 2002-10-21
+ '(declaration ftype function
+ inline notinline special)))
+ (error 'simple-program-error
+ :format-control "The declaration specifier ~S ~
+ is not allowed inside DEFGENERIC."
+ :format-arguments (list (cadr option))))
+ (push (cadr option) (initarg :declarations)))
((:argument-precedence-order :method-combination)
(if (initarg car-option)
(duplicate-option car-option)
(setf (initarg car-option)
`',(cdr option))))
((:documentation :generic-function-class :method-class)
- (unless (sb-int:proper-list-of-length-p option 2)
+ (unless (proper-list-of-length-p option 2)
(error "bad list length for ~S" option))
(if (initarg car-option)
(duplicate-option car-option)
(t
;; ANSI requires that unsupported things must get a
;; PROGRAM-ERROR.
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "unsupported option ~S"
:format-arguments (list option))))))
`',(initarg :declarations))))
`(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))
- ,@(mapcar #'expand-method-definition methods)
- `,(function ,function-name)))))
-
-(defun compile-or-load-defgeneric (function-name)
- (sb-kernel:proclaim-as-function-name function-name)
- (sb-kernel:note-name-defined function-name :function)
- (unless (eq (sb-int:info :function :where-from function-name) :declared)
- (setf (sb-int:info :function :where-from function-name) :defined)
- (setf (sb-int:info :function :type function-name)
+ (compile-or-load-defgeneric ',fun-name))
+ (load-defgeneric ',fun-name ',lambda-list ,@initargs)
+ ,@(mapcar #'expand-method-definition methods)
+ #',fun-name))))
+
+(defun compile-or-load-defgeneric (fun-name)
+ (sb-kernel:proclaim-as-fun-name fun-name)
+ (sb-kernel:note-name-defined fun-name :function)
+ (unless (eq (info :function :where-from fun-name) :declared)
+ (setf (info :function :where-from fun-name) :defined)
+ (setf (info :function :type fun-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))
+(defun load-defgeneric (fun-name lambda-list &rest initargs)
+ (when (fboundp fun-name)
+ (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (let ((fun (fdefinition fun-name)))
+ (when (generic-function-p fun)
+ (loop for method in (generic-function-initial-methods fun)
+ do (remove-method fun method))
+ (setf (generic-function-initial-methods fun) '()))))
(apply #'ensure-generic-function
- function-name
- :lambda-list lambda-list
- :definition-source `((defgeneric ,function-name)
- ,*load-truename*)
- initargs))
+ fun-name
+ :lambda-list lambda-list
+ :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
+ initargs))
+
+;;; As per section 3.4.2 of the ANSI spec, generic function lambda
+;;; lists have some special limitations, which we check here.
+(defun check-gf-lambda-list (lambda-list)
+ (flet ((ensure (arg ok)
+ (unless ok
+ (error
+ ;; (s/invalid/non-ANSI-conforming/ because the old PCL
+ ;; implementation allowed this, so people got used to
+ ;; it, and maybe this phrasing will help them to guess
+ ;; why their program which worked under PCL no longer works.)
+ "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
+ arg lambda-list))))
+ (multiple-value-bind (required optional restp rest keyp keys allowp
+ auxp aux morep more-context more-count)
+ (parse-lambda-list lambda-list)
+ (declare (ignore required)) ; since they're no different in a gf ll
+ (declare (ignore restp rest)) ; since they're no different in a gf ll
+ (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
+ (declare (ignore aux)) ; since we require AUXP=NIL
+ (declare (ignore more-context more-count)) ; safely ignored unless MOREP
+ ;; no defaults allowed for &OPTIONAL arguments
+ (dolist (i optional)
+ (ensure i (or (symbolp i)
+ (and (consp i) (symbolp (car i)) (null (cdr i))))))
+ ;; no defaults allowed for &KEY arguments
+ (when keyp
+ (dolist (i keys)
+ (ensure i (or (symbolp i)
+ (and (consp i)
+ (or (symbolp (car i))
+ (and (consp (car i))
+ (symbolp (caar i))
+ (symbolp (cadar i))
+ (null (cddar i))))
+ (null (cdr i)))))))
+ ;; no &AUX allowed
+ (when auxp
+ (error "&AUX is not allowed in a generic function lambda list: ~S"
+ lambda-list))
+ ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
+ ;; the ANSI spec, but the CMU CL &MORE extension does not
+ ;; belong here!
+ (aver (not morep)))))
\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)
+ (let ((*optimize-asv-funcall-p* t)
(*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
- (declare (special *make-instance-function-keys*))
(multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
(add-method-declarations name qualifiers lambda-list body env)
(multiple-value-bind (method-function-lambda initargs)
;; intended. I hate that kind of bug (code which silently
;; gives the wrong answer), so we don't do a DECLAIM
;; here. -- WHN 20000229
- ,@(when *make-instance-function-keys*
- `((get-make-instance-functions
- ',*make-instance-function-keys*)))
,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
`((initialize-internal-slot-gfs*
',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
(class-name (class-of proto-method))
'standard-method)
initargs-form
- (getf (getf initargs ':plist)
- ':pv-table-symbol))))))))
+ (getf (getf initargs :plist)
+ :pv-table-symbol))))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
initargs-form &optional pv-table-symbol)
(let (fn
fn-lambda)
- (if (and (interned-symbol-p (sb-int:function-name-block-name name))
+ (if (and (interned-symbol-p (fun-name-block-name name))
(every #'interned-symbol-p qualifiers)
- (every #'(lambda (s)
- (if (consp s)
- (and (eq (car s) 'eql)
- (constantp (cadr s))
- (let ((sv (eval (cadr s))))
- (or (interned-symbol-p sv)
- (integerp sv)
- (and (characterp sv)
- (standard-char-p sv)))))
- (interned-symbol-p s)))
+ (every (lambda (s)
+ (if (consp s)
+ (and (eq (car s) 'eql)
+ (constantp (cadr s))
+ (let ((sv (eval (cadr s))))
+ (or (interned-symbol-p sv)
+ (integerp sv)
+ (and (characterp sv)
+ (standard-char-p sv)))))
+ (interned-symbol-p s)))
specializers)
(consp initargs-form)
(eq (car initargs-form) 'list*)
`(,(car specl) ,(eval (cadr specl)))
specl))
specializers))
- (mname `(,(if (eq (cadr initargs-form) ':function)
+ (mname `(,(if (eq (cadr initargs-form) :function)
'method 'fast-method)
,name ,@qualifiers ,specls))
(mname-sym (intern (let ((*print-pretty* nil)
;; force symbols to be printed
;; with explicit package
;; prefixes.)
- (*package* sb-int:*keyword-package*))
+ (*package* *keyword-package*))
(format nil "~S" mname)))))
- `(eval-when ,*defmethod-times*
- (defun ,mname-sym ,(cadr fn-lambda)
- ,@(cddr fn-lambda))
- ,(make-defmethod-form-internal
- name qualifiers `',specls
- unspecialized-lambda-list method-class-name
- `(list* ,(cadr initargs-form)
- #',mname-sym
- ,@(cdddr initargs-form))
- pv-table-symbol)))
- (make-top-level-form
- `(defmethod ,name ,@qualifiers ,specializers)
- *defmethod-times*
- (make-defmethod-form-internal
- name qualifiers
- `(list ,@(mapcar #'(lambda (specializer)
- (if (consp specializer)
- ``(,',(car specializer)
- ,,(cadr specializer))
- `',specializer))
- specializers))
- unspecialized-lambda-list method-class-name
- initargs-form
- pv-table-symbol)))))
+ `(progn
+ (defun ,mname-sym ,(cadr fn-lambda)
+ ,@(cddr fn-lambda))
+ ,(make-defmethod-form-internal
+ name qualifiers `',specls
+ unspecialized-lambda-list method-class-name
+ `(list* ,(cadr initargs-form)
+ #',mname-sym
+ ,@(cdddr initargs-form))
+ pv-table-symbol)))
+ (make-defmethod-form-internal
+ name qualifiers
+ `(list ,@(mapcar (lambda (specializer)
+ (if (consp specializer)
+ ``(,',(car specializer)
+ ,,(cadr specializer))
+ `',specializer))
+ specializers))
+ unspecialized-lambda-list
+ method-class-name
+ initargs-form
+ pv-table-symbol))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
(declare (ignore parameters))
- (multiple-value-bind (documentation declarations real-body)
- (extract-declarations body env)
+ (multiple-value-bind (real-body declarations documentation)
+ (parse-body body env)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
- (declare (method-name ,(list name qualifiers specializers)))
- (declare (method-lambda-list ,@lambda-list))
+ ;; (Old PCL code used a somewhat different style of
+ ;; list for %METHOD-NAME values. Our names use
+ ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
+ ;; method names look more like what you see in a
+ ;; DEFMETHOD form.)
+ ;;
+ ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
+ ;; least the code to set up named BLOCKs around the
+ ;; bodies of methods, depends on the function's base
+ ;; name being the first element of the %METHOD-NAME
+ ;; list. It would be good to remove this dependency,
+ ;; perhaps by building the BLOCK here, or by using
+ ;; another declaration (e.g. %BLOCK-NAME), so that
+ ;; our method debug names are free to have any format,
+ ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
+ ;;
+ ;; Further, as of sbcl-0.7.9.10, the code to
+ ;; implement NO-NEXT-METHOD is coupled to the form of
+ ;; this declaration; see the definition of
+ ;; CALL-NO-NEXT-METHOD (and the passing of
+ ;; METHOD-NAME-DECLARATION arguments around the
+ ;; various CALL-NEXT-METHOD logic).
+ (declare (%method-name (,name
+ ,@qualifiers
+ ,specializers)))
+ (declare (%method-lambda-list ,@lambda-list))
,@declarations
,@real-body)
unspecialized-lambda-list specializers))))
(defun real-make-method-initargs-form (proto-gf proto-method
method-lambda initargs env)
(declare (ignore proto-gf proto-method))
- (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+ (unless (and (consp method-lambda)
+ (eq (car method-lambda) 'lambda))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
is not a lambda form."
method-lambda))
(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, ~
is not a lambda form."
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))
+ (multiple-value-bind (real-body declarations documentation)
+ (parse-body (cddr method-lambda) env)
+ (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 (VAR-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)))
+ (neq s t)
+ `(%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
(declare (ignorable ,@required-parameters))
,class-declarations
,@declarations
- (block ,(sb-int:function-name-block-name
- generic-function-name)
+ (block ,(fun-name-block-name generic-function-name)
,@real-body)))
(constant-value-p (and (null (cdr real-body))
(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))
env
slots
calls)
- (multiple-value-bind
- (ignore walked-declarations walked-lambda-body)
- (extract-declarations (cddr walked-lambda))
- (declare (ignore ignore))
+ (multiple-value-bind (walked-lambda-body
+ walked-declarations
+ walked-documentation)
+ (parse-body (cddr walked-lambda) env)
+ (declare (ignore walked-documentation))
(when (or next-method-p-p call-next-method-p)
- (setq plist (list* :needs-next-methods-p 't plist)))
+ (setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
(multiple-value-bind (slot-name-lists call-list)
(slot-name-lists-from-slots slots calls)
:call-next-method-p
,call-next-method-p
:next-method-p-p ,next-method-p-p
+ ;; we need to pass this along
+ ;; so that NO-NEXT-METHOD can
+ ;; be given a suitable METHOD
+ ;; argument; we need the
+ ;; QUALIFIERS and SPECIALIZERS
+ ;; inside the declaration to
+ ;; give to FIND-METHOD.
+ :method-name-declaration ,name-decl
:closurep ,closurep
:applyp ,applyp)
,@walked-declarations
rest-arg
&rest lmf-options)
&body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
- (bind-lexical-method-functions (,@lmf-options)
- (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
- ,@body))))
+ `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
+ (bind-lexical-method-functions (,@lmf-options)
+ (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+ ,@body))))
(defmacro bind-simple-lexical-method-macros ((method-args next-methods)
&body body)
(,',next-methods (cdr ,',next-methods)))
.next-method. ,',next-methods
,@body))
- (call-next-method-body (cnm-args)
+ (call-next-method-body (method-name-declaration cnm-args)
`(if .next-method.
(funcall (if (std-instance-p .next-method.)
(method-function .next-method.)
.next-method.) ; for early methods
(or ,cnm-args ,',method-args)
,',next-methods)
- (error "no next method")))
+ (apply #'call-no-next-method ',method-name-declaration
+ (or ,cnm-args ,',method-args))))
(next-method-p-body ()
`(not (null .next-method.))))
,@body))
-(defstruct method-call
+(defun call-no-next-method (method-name-declaration &rest args)
+ (destructuring-bind (name) method-name-declaration
+ (destructuring-bind (name &rest qualifiers-and-specializers) name
+ ;; KLUDGE: inefficient traversal, but hey. This should only
+ ;; happen on the slow error path anyway.
+ (let* ((qualifiers (butlast qualifiers-and-specializers))
+ (specializers (car (last qualifiers-and-specializers)))
+ (method (find-method (gdefinition name) qualifiers specializers)))
+ (apply #'no-next-method
+ (method-generic-function method)
+ method
+ args)))))
+
+(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
`(list ,@required-args+rest-arg))
(method-call-call-method-args ,method-call)))
-(defstruct fast-method-call
+(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
pv-cell
next-method-call
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
-(defstruct fast-instance-boundp
+(defstruct (fast-instance-boundp (:copier nil))
(index 0 :type fixnum))
#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defvar *allow-emf-call-tracing-p* nil)
-(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
-
-) ; EVAL-WHEN
+ (defvar *allow-emf-call-tracing-p* nil)
+ (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t))
\f
;;;; effective method functions
&rest required-args+rest-arg)
(unless (constantp restp)
(error "The RESTP argument is not constant."))
+ ;; FIXME: The RESTP handling here is confusing and maybe slightly
+ ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
+ ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
+ ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
(setq restp (eval restp))
`(progn
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(cond ((typep ,emf 'fast-method-call)
- (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+ (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+ ;; "What," you may wonder, "do these next two clauses do?"
+ ;; In that case, you are not a PCL implementor, for they
+ ;; considered this to be self-documenting.:-| Or CSR, for
+ ;; that matter, since he can also figure it out by looking
+ ;; at it without breaking stride. For the rest of us,
+ ;; though: From what the code is doing with .SLOTS. and
+ ;; whatnot, evidently it's implementing SLOT-VALUEish and
+ ;; GET-SLOT-VALUEish things. Then we can reason backwards
+ ;; and conclude that setting EMF to a FIXNUM is an
+ ;; optimized way to represent these slot access operations.
,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
`(((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 (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
- .slots. (fast-instance-boundp-index ,emf))
- +slot-unbound+)))))))
- ||#
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
+ ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+ ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+ ;; there was no explanation and presumably the code is 10+
+ ;; years stale, I simply deleted it. -- WHN)
(t
(etypecase ,emf
(method-call
(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))))
-
-;; KLUDGE: A comment from the original PCL said "This can be improved alot."
-(defun gf-make-function-from-emf (gf emf)
- (etypecase emf
- (fast-method-call (let* ((arg-info (gf-arg-info gf))
- (nreq (arg-info-number-required arg-info))
- (restp (arg-info-applyp arg-info)))
- #'(lambda (&rest args)
- (trace-emf-call emf t args)
- (apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
- (fast-method-call-next-method-call emf)
- (if restp
- (let* ((rest-args (nthcdr nreq args))
- (req-args (ldiff args
- rest-args)))
- (nconc req-args rest-args))
- args)))))
- (method-call #'(lambda (&rest args)
- (trace-emf-call emf t args)
- (apply (method-call-function emf)
- args
- (method-call-call-method-args emf))))
- (function emf)))
\f
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body body)
- `(macrolet ((call-next-method-bind (&body body)
- `(let () ,@body))
- (call-next-method-body (cnm-args)
- `(if ,',next-method-call
- ,(if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(invoke-effective-method-function
- ,',next-method-call nil
- ,@(cdr cnm-args))
- (let ((call `(invoke-effective-method-function
- ,',next-method-call
- ,',(not (null rest-arg))
- ,@',args
- ,@',(when rest-arg `(,rest-arg)))))
- `(if ,cnm-args
- (bind-args ((,@',args
- ,@',(when rest-arg
- `(&rest ,rest-arg)))
- ,cnm-args)
- ,call)
- ,call)))
- (error "no next method")))
+ `(macrolet ((narrowed-emf (emf)
+ ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
+ ;; dispatch on the possibility that EMF might be of
+ ;; type FIXNUM (as an optimized representation of a
+ ;; slot accessor). But as far as I (WHN 2002-06-11)
+ ;; can tell, it's impossible for such a representation
+ ;; to end up as .NEXT-METHOD-CALL. By reassuring
+ ;; INVOKE-E-M-F that when called from this context
+ ;; it needn't worry about the FIXNUM case, we can
+ ;; keep those cases from being compiled, which is
+ ;; good both because it saves bytes and because it
+ ;; avoids annoying type mismatch compiler warnings.
+ ;;
+ ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
+ ;; system isn't smart enough about NOT and intersection
+ ;; types to benefit from a (NOT FIXNUM) declaration
+ ;; here. -- WHN 2002-06-12
+ ;;
+ ;; FIXME: Might the FUNCTION type be omittable here,
+ ;; leaving only METHOD-CALLs? Failing that, could this
+ ;; be documented somehow? (It'd be nice if the types
+ ;; involved could be understood without solving the
+ ;; halting problem.)
+ `(the (or function method-call fast-method-call)
+ ,emf))
+ (call-next-method-bind (&body body)
+ `(let () ,@body))
+ (call-next-method-body (method-name-declaration cnm-args)
+ `(if ,',next-method-call
+ ,(locally
+ ;; This declaration suppresses a "deleting
+ ;; unreachable code" note for the following IF when
+ ;; REST-ARG is NIL. It is not nice for debugging
+ ;; SBCL itself, but at least it keeps us from
+ ;; annoying users.
+ (declare (optimize (inhibit-warnings 3)))
+ (if (and (null ',rest-arg)
+ (consp cnm-args)
+ (eq (car cnm-args) 'list))
+ `(invoke-effective-method-function
+ (narrowed-emf ,',next-method-call)
+ nil
+ ,@(cdr cnm-args))
+ (let ((call `(invoke-effective-method-function
+ (narrowed-emf ,',next-method-call)
+ ,',(not (null rest-arg))
+ ,@',args
+ ,@',(when rest-arg `(,rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@',args
+ ,@',(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call))))
+ ,(locally
+ ;; As above, this declaration suppresses code
+ ;; deletion notes.
+ (declare (optimize (inhibit-warnings 3)))
+ (if (and (null ',rest-arg)
+ (consp cnm-args)
+ (eq (car cnm-args) 'list))
+ `(call-no-next-method ',method-name-declaration
+ ,@(cdr cnm-args))
+ `(call-no-next-method ',method-name-declaration
+ ,@',args
+ ,@',(when rest-arg
+ `(,rest-arg)))))))
(next-method-p-body ()
- `(not (null ,',next-method-call))))
- ,@body))
+ `(not (null ,',next-method-call))))
+ ,@body))
(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p closurep applyp)
+ ((&key call-next-method-p next-method-p-p
+ closurep applyp method-name-declaration)
&body body)
(cond ((and (null call-next-method-p) (null next-method-p-p)
(null closurep)
(null applyp))
`(let () ,@body))
- ((and (null closurep)
- (null applyp))
- ;; OK to use MACROLET, and all args are mandatory
- ;; (else APPLYP would be true).
- `(call-next-method-bind
- (macrolet ((call-next-method (&rest cnm-args)
- `(call-next-method-body ,(when cnm-args
- `(list ,@cnm-args))))
- (next-method-p ()
- `(next-method-p-body)))
- ,@body)))
(t
`(call-next-method-bind
(flet (,@(and call-next-method-p
- '((call-next-method (&rest cnm-args)
- (call-next-method-body cnm-args))))
+ `((call-next-method (&rest cnm-args)
+ (call-next-method-body
+ ,method-name-declaration
+ cnm-args))))
,@(and next-method-p-p
'((next-method-p ()
(next-method-p-body)))))
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(sb-int:keywordicate var)
- ,args-tail))))
+ `((,var (car
+ (get-key-arg-tail ,(keywordicate var)
+ ,args-tail)))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ',keyword ,args-tail))
- (,variable (if (consp ,key)
+ `((,key (get-key-arg-tail ',keyword
+ ,args-tail))
+ (,variable (if ,key
(car ,key)
,(cadr var))))))
(t
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ',keyword ,args-tail))
+ `((,key (get-key-arg-tail ',keyword
+ ,args-tail))
(,(caddr var) ,key)
- (,variable (if (consp ,key)
+ (,variable (if ,key
(car ,key)
,(cadr var))))))))
(aux `(,var))))))
(declare (ignorable ,args-tail))
,@body)))))
-(defun get-key-arg (keyword list)
- (loop (when (atom list) (return nil))
- (when (eq (car list) keyword) (return (cadr list)))
- (setq list (cddr list))))
-
-(defun get-key-arg1 (keyword list)
- (loop (when (atom list) (return nil))
- (when (eq (car list) keyword) (return (cdr list)))
- (setq list (cddr list))))
+(defun get-key-arg-tail (keyword list)
+ (loop for (key . tail) on list by #'cddr
+ when (null tail) do
+ ;; FIXME: Do we want to export this symbol? Or maybe use an
+ ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
+ (sb-c::%odd-key-args-error)
+ when (eq key keyword)
+ return tail))
(defun walk-method-lambda (method-lambda required-parameters env slots calls)
(let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD
(next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P
; should be in the method definition
(flet ((walk-function (form context env)
- (cond ((not (eq context ':eval)) form)
+ (cond ((not (eq context :eval)) form)
;; FIXME: Jumping to a conclusion from the way it's used
;; above, perhaps CONTEXT should be called SITUATION
;; (after the term used in the ANSI specification of
;; like :LOAD-TOPLEVEL.
((not (listp form)) form)
((eq (car form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
form)
((eq (car form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
(setq closurep t)
form)
((eq (cadr form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
(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)
next-method-p-p)))))
(defun generic-function-name-p (name)
- (and (sb-int:legal-function-name-p name)
+ (and (legal-fun-name-p name)
(gboundp name)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
*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)
+ (let ((method-spec (or (getf initargs :method-spec)
(make-method-spec name quals specls))))
- (setf (getf initargs ':method-spec) method-spec)
- (record-definition 'method method-spec)
+ (setf (getf initargs :method-spec) method-spec)
(load-defmethod-internal class name quals specls
ll initargs pv-table-symbol)))
(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)
+ (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 (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"
:definition-source `((defmethod ,gf-spec
,@qualifiers
,specializers)
- ,*load-truename*)
+ ,*load-pathname*)
initargs)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
`(method ,gf-spec ,@qualifiers ,unparsed-specializers))
(defun initialize-method-function (initargs &optional return-function-p method)
- (let* ((mf (getf initargs ':function))
- (method-spec (getf initargs ':method-spec))
- (plist (getf initargs ':plist))
- (pv-table-symbol (getf plist ':pv-table-symbol))
+ (let* ((mf (getf initargs :function))
+ (method-spec (getf initargs :method-spec))
+ (plist (getf initargs :plist))
+ (pv-table-symbol (getf plist :pv-table-symbol))
(pv-table nil)
- (mff (getf initargs ':fast-function)))
+ (mff (getf initargs :fast-function)))
(flet ((set-mf-property (p v)
(when mf
(setf (method-function-get mf p) v))
(setf (method-function-get mff p) v))))
(when method-spec
(when mf
- (setq mf (set-function-name mf method-spec)))
+ (setq mf (set-fun-name mf method-spec)))
(when mff
(let ((name `(,(or (get (car method-spec) 'fast-sym)
(setf (get (car method-spec) 'fast-sym)
(car method-spec))
*pcl-package*)))
,@(cdr method-spec))))
- (set-function-name mff name)
+ (set-fun-name mff name)
(unless mf
(set-mf-property :name name)))))
(when plist
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
- (parse-keyword-argument (arg)
+ (parse-key-arg (arg)
(if (listp arg)
(if (listp (car arg))
(caar arg)
- (sb-int:keywordicate (car arg)))
- (sb-int:keywordicate arg))))
+ (keywordicate (car arg)))
+ (keywordicate arg))))
(let ((nrequired 0)
(noptional 0)
(keysp nil)
(restp nil)
+ (nrest 0)
(allow-other-keys-p nil)
(keywords ())
(keyword-parameters ())
(if (memq x lambda-list-keywords)
(case x
(&optional (setq state 'optional))
- (&key (setq keysp 't
+ (&key (setq keysp t
state 'key))
- (&allow-other-keys (setq allow-other-keys-p 't))
- (&rest (setq restp 't
+ (&allow-other-keys (setq allow-other-keys-p t))
+ (&rest (setq restp t
state 'rest))
(&aux (return t))
(otherwise
- (error "encountered the non-standard lambda list keyword ~S" x)))
+ (error "encountered the non-standard lambda list keyword ~S"
+ x)))
(ecase state
(required (incf nrequired))
(optional (incf noptional))
- (key (push (parse-keyword-argument x) keywords)
+ (key (push (parse-key-arg x) keywords)
(push x keyword-parameters))
- (rest ()))))
+ (rest (incf nrest)))))
+ (when (and restp (zerop nrest))
+ (error "Error in lambda-list:~%~
+ After &REST, a DEFGENERIC lambda-list ~
+ must be followed by at least one variable."))
(values nrequired noptional keysp restp allow-other-keys-p
(reverse keywords)
(reverse keyword-parameters)))))
(defun keyword-spec-name (x)
(let ((key (if (atom x) x (car x))))
(if (atom key)
- (intern (symbol-name key) sb-int:*keyword-package*)
+ (keywordicate key)
(car key))))
(defun ftype-declaration-from-lambda-list (lambda-list name)
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 (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (old-ftype (if (sb-kernel:fun-type-p old) old nil))
+ (old-restp (and old-ftype (sb-kernel:fun-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:fun-type-keywords
+ old-ftype))))
+ (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+ (old-allowp (and old-ftype
+ (sb-kernel:fun-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
- `(function ,(append (make-list nrequired :initial-element 't)
+ `(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
(append '(&optional)
- (make-list noptional :initial-element 't)))
+ (make-list noptional :initial-element t)))
(when (or restp old-restp)
'(&rest t))
(when (or keysp old-keysp)
(append '(&key)
- (mapcar #'(lambda (key)
- `(,key t))
+ (mapcar (lambda (key)
+ `(,key t))
keywords)
(when (or allow-other-keys-p old-allowp)
'(&allow-other-keys)))))
(defun defgeneric-declaration (spec lambda-list)
(when (consp spec)
- (setq spec (get-setf-function-name (cadr spec))))
+ (setq spec (get-setf-fun-name (cadr spec))))
`(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(defvar *!early-generic-functions* ())
-(defun ensure-generic-function (function-name
+(defun ensure-generic-function (fun-name
&rest all-keys
&key environment
&allow-other-keys)
(declare (ignore environment))
- (let ((existing (and (gboundp function-name)
- (gdefinition function-name))))
+ (let ((existing (and (gboundp fun-name)
+ (gdefinition fun-name))))
(if (and existing
(eq *boot-state* 'complete)
(null (generic-function-p existing)))
- (generic-clobbers-function function-name)
+ (generic-clobbers-function fun-name)
(apply #'ensure-generic-function-using-class
- existing function-name all-keys))))
+ existing fun-name all-keys))))
-(defun generic-clobbers-function (function-name)
- (error 'sb-kernel:simple-program-error
- :format-control
- "~S already names an ordinary function or a macro."
- :format-arguments (list function-name)))
+(defun generic-clobbers-function (fun-name)
+ (error 'simple-program-error
+ :format-control "~S already names an ordinary function or a macro."
+ :format-arguments (list fun-name)))
(defvar *sgf-wrapper*
(boot-make-wrapper (early-class-size 'standard-generic-function)
'standard-generic-function))
(defvar *sgf-slots-init*
- (mapcar #'(lambda (canonical-slot)
- (if (memq (getf canonical-slot :name) '(arg-info source))
- +slot-unbound+
- (let ((initfunction (getf canonical-slot :initfunction)))
- (if initfunction
- (funcall initfunction)
- +slot-unbound+))))
+ (mapcar (lambda (canonical-slot)
+ (if (memq (getf canonical-slot :name) '(arg-info source))
+ +slot-unbound+
+ (let ((initfunction (getf canonical-slot :initfunction)))
+ (if initfunction
+ (funcall initfunction)
+ +slot-unbound+))))
(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)
- (:constructor make-arg-info ()))
+ (:conc-name nil)
+ (:constructor make-arg-info ())
+ (:copier nil))
(arg-info-lambda-list :no-lambda-list)
arg-info-precedence
arg-info-metatypes
arg-info-number-optional
arg-info-key/rest-p
- arg-info-keywords ;nil no keyword or rest allowed
- ;(k1 k2 ..) each method must accept these keyword arguments
- ;T must have &key or &rest
+ arg-info-keys ;nil no &KEY or &REST allowed
+ ;(k1 k2 ..) Each method must accept these &KEY arguments.
+ ;T must have &KEY or &REST
gf-info-simple-accessor-type ; nil, reader, writer, boundp
(gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
(length (arg-info-metatypes arg-info)))
(defun arg-info-nkeys (arg-info)
- (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+ (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
;;; Keep pages clean by not setting if the value is already the same.
(defmacro esetf (pos val)
(setq lambda-list (gf-lambda-list gf)))
(when (or lambda-list-p
(and first-p
- (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
+ (eq (arg-info-lambda-list arg-info) :no-lambda-list)))
(multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
(analyze-lambda-list lambda-list)
(when (and methods (not first-p))
(esetf (arg-info-metatypes arg-info) (make-list nreq))
(esetf (arg-info-number-optional arg-info) nopt)
(esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
- (esetf (arg-info-keywords arg-info)
+ (esetf (arg-info-keys arg-info)
(if lambda-list-p
(if allow-other-keys-p t keywords)
(arg-info-key/rest-p arg-info)))))
(early-method-lambda-list method)
(method-lambda-list method)))
(flet ((lose (string &rest args)
- (error
- "attempt to add the method ~S to the generic function ~S.~%~
- But ~A"
- method
- gf
- (apply #'format nil string args)))
- (compare (x y)
+ (error 'simple-program-error
+ :format-control "~@<attempt to add the method~2I~_~S~I~_~
+ to the generic function~2I~_~S;~I~_~
+ but ~?~:>"
+ :format-arguments (list method gf string args)))
+ (comparison-description (x y)
(if (> x y) "more" "fewer")))
(let ((gf-nreq (arg-info-number-required arg-info))
(gf-nopt (arg-info-number-optional arg-info))
(gf-key/rest-p (arg-info-key/rest-p arg-info))
- (gf-keywords (arg-info-keywords arg-info)))
+ (gf-keywords (arg-info-keys arg-info)))
(unless (= nreq gf-nreq)
(lose
"the method has ~A required arguments than the generic function."
- (compare nreq gf-nreq)))
+ (comparison-description nreq gf-nreq)))
(unless (= nopt gf-nopt)
(lose
- "the method has ~S optional arguments than the generic function."
- (compare nopt gf-nopt)))
+ "the method has ~A optional arguments than the generic function."
+ (comparison-description nopt gf-nopt)))
(unless (eq (or keysp restp) gf-key/rest-p)
- (error
- "The method and generic function differ in whether they accept~%~
+ (lose
+ "the method and generic function differ in whether they accept~_~
&REST or &KEY arguments."))
(when (consp gf-keywords)
(unless (or (and restp (not keysp))
allow-other-keys-p
- (every #'(lambda (k) (memq k keywords)) gf-keywords))
- (lose "the method does not accept each of the keyword arguments~%~
+ (every (lambda (k) (memq k keywords)) gf-keywords))
+ (lose "the method does not accept each of the &KEY arguments~2I~_~
~S."
gf-keywords)))))))
(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*
;;; 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
- &key (lambda-list nil lambda-list-p)
+ &key (lambda-list nil
+ lambda-list-p)
+ argument-precedence-order
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
existing)
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
- (make-early-gf spec lambda-list lambda-list-p existing)
+ (make-early-gf spec lambda-list lambda-list-p existing
+ argument-precedence-order)
(error "The function ~S is not already defined." spec)))
(existing
(error "~S should be on the list ~S."
'*!generic-function-fixups*))
(t
(pushnew spec *!early-generic-functions* :test #'equal)
- (make-early-gf spec lambda-list lambda-list-p))))
+ (make-early-gf spec lambda-list lambda-list-p nil
+ argument-precedence-order))))
-(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+(defun make-early-gf (spec &optional lambda-list lambda-list-p
+ function argument-precedence-order)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
- (set-funcallable-instance-function
+ (set-funcallable-instance-fun
fin
(or function
(if (eq spec 'print-object)
(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*)
- (set-function-name fin spec)
+ (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
+ (!bootstrap-set-slot 'standard-generic-function
+ fin
+ 'source
+ *load-pathname*)
+ (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))
- (set-arg-info fin :lambda-list lambda-list)))
+ (if argument-precedence-order
+ (set-arg-info fin
+ :lambda-list lambda-list
+ :argument-precedence-order argument-precedence-order)
+ (set-arg-info fin :lambda-list lambda-list))))
fin))
(defun set-dfun (gf &optional dfun cache 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)
(gf-arg-info gf)
(early-gf-arg-info gf))))
- (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
+ (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
(let ((methods (if (eq *boot-state* 'complete)
(generic-function-methods gf)
(early-gf-methods gf))))
(setf (getf ,all-keys :method-combination)
(find-method-combination (class-prototype ,gf-class)
(car combin)
- (cdr combin)))))))
+ (cdr combin)))))
+ (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
+ (unless (eq method-class '.shes-not-there.)
+ (setf (getf ,all-keys :method-class)
+ (find-class method-class t ,env))))))
(defun real-ensure-gf-using-class--generic-function
(existing
- function-name
+ fun-name
&rest all-keys
&key environment (lambda-list nil lambda-list-p)
(generic-function-class 'standard-generic-function gf-class-p)
(prog1
(apply #'reinitialize-instance existing all-keys)
(when lambda-list-p
- (proclaim (defgeneric-declaration function-name lambda-list)))))
+ (proclaim (defgeneric-declaration fun-name lambda-list)))))
(defun real-ensure-gf-using-class--null
(existing
- function-name
+ fun-name
&rest all-keys
&key environment (lambda-list nil lambda-list-p)
(generic-function-class 'standard-generic-function)
(declare (ignore existing))
(real-ensure-gf-internal generic-function-class all-keys environment)
(prog1
- (setf (gdefinition function-name)
+ (setf (gdefinition fun-name)
(apply #'make-instance generic-function-class
- :name function-name all-keys))
+ :name fun-name all-keys))
(when lambda-list-p
- (proclaim (defgeneric-declaration function-name lambda-list)))))
+ (proclaim (defgeneric-declaration fun-name lambda-list)))))
\f
-(defun get-generic-function-info (gf)
+(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)
metatypes
arg-info))
(values (length metatypes) applyp metatypes
- (count-if #'(lambda (x) (neq x 't)) metatypes)
+ (count-if (lambda (x) (neq x t)) metatypes)
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
;; Note that the use of not symbolp in this call to every should be
;; read as 'classp' we can't use classp itself because it doesn't
;; exist yet.
- (if (every #'(lambda (s) (not (symbolp s))) specializers)
+ (if (every (lambda (s) (not (symbolp s))) specializers)
(setq parsed specializers
- unparsed (mapcar #'(lambda (s)
- (if (eq s 't) 't (class-name s)))
+ unparsed (mapcar (lambda (s)
+ (if (eq s t) t (class-name s)))
specializers))
(setq unparsed specializers
parsed ()))
(list :early-method ;This is an early method dammit!
- (getf initargs ':function)
- (getf initargs ':fast-function)
+ (getf initargs :function)
+ (getf initargs :fast-function)
parsed ;The parsed specializers. This is used
;by early-method-specializers to cache
(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))
- (cond ((eq objectsp 't)
+ (cond ((eq objectsp t)
(or (fourth early-method)
(setf (fourth early-method)
(mapcar #'find-class (cadddr (fifth 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)))
(or (dolist (m (early-gf-methods generic-function))
(when (and (or (equal (early-method-specializers m nil)
specializers)
- (equal (early-method-specializers m 't)
+ (equal (early-method-specializers m t)
specializers))
(equal (early-method-qualifiers m) qualifiers))
(return m)))
(real-get-method generic-function qualifiers specializers errorp)))
(defun !fix-early-generic-functions ()
- (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
(let ((accessors nil))
;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
;; FIX-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)))
- (sb-int:/show spec)
+ (/show spec)
(setq *!early-generic-functions*
(cons spec
(delete spec *!early-generic-functions* :test #'equal))))
(dolist (early-gf-spec *!early-generic-functions*)
- (sb-int:/show early-gf-spec)
+ (/show early-gf-spec)
(let* ((gf (gdefinition early-gf-spec))
- (methods (mapcar #'(lambda (early-method)
- (let ((args (copy-list (fifth
- early-method))))
- (setf (fourth args)
- (early-method-specializers
- early-method t))
- (apply #'real-make-a-method args)))
+ (methods (mapcar (lambda (early-method)
+ (let ((args (copy-list (fifth
+ early-method))))
+ (setf (fourth args)
+ (early-method-specializers
+ early-method t))
+ (apply #'real-make-a-method args)))
(early-gf-methods gf))))
(setf (generic-function-method-class gf) *the-class-standard-method*)
(setf (generic-function-method-combination gf)
(set-methods gf methods)))
(dolist (fn *!early-functions*)
- (sb-int:/show fn)
- (setf (gdefinition (car fn)) (symbol-function (caddr fn))))
+ (/show fn)
+ (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
- (sb-int:/show fixup)
+ (/show fixup)
(let* ((fspec (car fixup))
(gf (gdefinition fspec))
- (methods (mapcar #'(lambda (method)
- (let* ((lambda-list (first method))
- (specializers (second method))
- (method-fn-name (third method))
- (fn-name (or method-fn-name fspec))
- (fn (symbol-function fn-name))
- (initargs
- (list :function
- (set-function-name
- #'(lambda (args next-methods)
- (declare (ignore
- next-methods))
- (apply fn args))
- `(call ,fn-name)))))
- (declare (type function fn))
- (make-a-method 'standard-method
- ()
- lambda-list
- specializers
- initargs
- nil)))
+ (methods (mapcar (lambda (method)
+ (let* ((lambda-list (first method))
+ (specializers (second method))
+ (method-fn-name (third method))
+ (fn-name (or method-fn-name fspec))
+ (fn (fdefinition fn-name))
+ (initargs
+ (list :function
+ (set-fun-name
+ (lambda (args next-methods)
+ (declare (ignore
+ next-methods))
+ (apply fn args))
+ `(call ,fn-name)))))
+ (declare (type function fn))
+ (make-a-method 'standard-method
+ ()
+ lambda-list
+ specializers
+ initargs
+ nil)))
(cdr fixup))))
(setf (generic-function-method-class gf) *the-class-standard-method*)
(setf (generic-function-method-combination gf)
*standard-method-combination*)
(set-methods gf methods))))
- (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
+ (/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))
+ (declare (list cdr-of-form))
(let ((name (pop cdr-of-form))
(qualifiers ())
(spec-ll ()))
(values name qualifiers spec-ll cdr-of-form)))
(defun parse-specializers (specializers)
+ (declare (list specializers))
(flet ((parse (spec)
(let ((result (specializer-from-type spec)))
(if (specializerp result)
(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
gf (method-generic-function method)
temp (and gf (generic-function-name gf))
name (if temp
- (intern-function-name
+ (intern-fun-name
(make-method-spec temp
(method-qualifiers method)
(unparse-specializers
(and
(setq method (get-method gf quals specls errorp))
(setq name
- (intern-function-name (make-method-spec gf-spec
- quals
- specls))))))))
+ (intern-fun-name (make-method-spec gf-spec
+ quals
+ specls))))))))
(values gf method name)))
\f
(defun extract-parameters (specialized-lambda-list)
(values nil arglist nil))
((memq arg lambda-list-keywords)
(unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
- ;; Warn about non-standard lambda-list-keywords, but then
- ;; go on to treat them like a standard lambda-list-keyword
- ;; what with the warning its probably ok.
- ;;
- ;; FIXME: This shouldn't happen now that this is maintained
- ;; as part of SBCL, should it? Perhaps this is now
- ;; "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."
- 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).
+ ;; Now, since we try to conform to ANSI, non-standard
+ ;; lambda-list-keywords should be treated as errors.
+ (error 'simple-program-error
+ :format-control "unrecognized lambda-list keyword ~S ~
+ in arglist.~%"
+ :format-arguments (list 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).
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
+ (when (eq arg '&rest)
+ ;; check, if &rest is followed by a var ...
+ (when (or (null lambda-list)
+ (memq (car lambda-list) lambda-list-keywords))
+ (error "Error in lambda-list:~%~
+ After &REST, a DEFMETHOD lambda-list ~
+ must be followed by at least one variable.")))
(values parameters
(cons arg lambda-list)
()
(parse-specialized-lambda-list (cdr arglist))
(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) (cadr arg) t) specializers)
(cons (if (listp arg) (car arg) arg) required)))))))
\f
-(eval-when (:load-toplevel :execute)
- (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 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
- (if (symbolp slot-entry)
- slot-entry
- (car slot-entry)))
- (slot-name
- (if (symbolp slot-entry)
- slot-entry
- (cadr slot-entry))))
- `(,variable-name
- (slot-value ,in ',slot-name))))
+ (symbol-macrolet ,(mapcar (lambda (slot-entry)
+ (let ((var-name
+ (if (symbolp slot-entry)
+ slot-entry
+ (car slot-entry)))
+ (slot-name
+ (if (symbolp slot-entry)
+ slot-entry
+ (cadr slot-entry))))
+ `(,var-name
+ (slot-value ,in ',slot-name))))
slots)
,@body))))
(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))
+ (symbol-macrolet ,(mapcar (lambda (slot-entry)
+ (let ((var-name (car slot-entry))
(accessor-name (cadr slot-entry)))
- `(,variable-name
- (,accessor-name ,in))))
- slots)
+ `(,var-name (,accessor-name ,in))))
+ slots)
,@body))))
projects / sbcl.git / blobdiff