X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=61bb5f99daad12e10de30ecbbb5d370cfd750d42;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=2ddea34d75c21dacc54f84d592659c1868733c19;hpb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 2ddea34..61bb5f9 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -78,19 +78,9 @@ bootstrapping. ;;; 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)) @@ -101,30 +91,18 @@ bootstrapping. 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 @@ -143,12 +121,12 @@ bootstrapping. (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) @@ -168,16 +146,17 @@ bootstrapping. (generic-function standard-method-combination t) standard-compute-effective-method)))) -(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 @@ -185,25 +164,39 @@ bootstrapping. (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) @@ -213,7 +206,7 @@ bootstrapping. (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)))))) @@ -222,39 +215,78 @@ bootstrapping. `',(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.) + "~@" + 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))))) (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) @@ -303,11 +335,6 @@ bootstrapping. (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) -(defvar *optimize-asv-funcall-p* nil) -(defvar *asv-readers*) -(defvar *asv-writers*) -(defvar *asv-boundps*) - (defun expand-defmethod (name proto-gf proto-method @@ -315,55 +342,43 @@ bootstrapping. 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)) - (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) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic - ;; function here, since ANSI specifies that we create it - ;; if it does not exist. However, I chose not to, because - ;; I think it's more useful to support a style of - ;; programming where every generic function has an - ;; explicit DEFGENERIC and any typos in DEFMETHODs are - ;; warned about. Otherwise - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall - ;; through to VECTOR) but still doesn't do what was - ;; 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*))) - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs ':plist) - ':pv-table-symbol)))))))) + (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) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form proto-gf + proto-method + method-function-lambda + initargs + env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs :plist) + :pv-table-symbol))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -373,18 +388,18 @@ bootstrapping. 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*) @@ -398,7 +413,7 @@ bootstrapping. `(,(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) @@ -407,32 +422,30 @@ bootstrapping. ;; 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 @@ -468,12 +481,36 @@ bootstrapping. (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)))) @@ -481,7 +518,8 @@ bootstrapping. (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)) @@ -495,15 +533,72 @@ bootstrapping. (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)))) @@ -517,67 +612,27 @@ bootstrapping. (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 @@ -604,22 +659,18 @@ bootstrapping. (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)) @@ -632,12 +683,13 @@ bootstrapping. 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) @@ -666,6 +718,14 @@ bootstrapping. :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 @@ -697,10 +757,10 @@ bootstrapping. 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) @@ -709,19 +769,33 @@ bootstrapping. (,',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) @@ -742,7 +816,7 @@ bootstrapping. `(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 @@ -759,17 +833,14 @@ bootstrapping. (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)) ;;;; effective method functions @@ -819,16 +890,30 @@ bootstrapping. &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) @@ -837,19 +922,13 @@ bootstrapping. `(((typep ,emf 'fixnum) (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+))))))) - ||# + ,(cadr required-args+rest-arg)))) + (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 @@ -898,99 +977,114 @@ bootstrapping. (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))) (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))))) @@ -1030,17 +1124,19 @@ bootstrapping. ,(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 @@ -1048,11 +1144,12 @@ bootstrapping. (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)))))) @@ -1062,15 +1159,14 @@ bootstrapping. (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 @@ -1080,7 +1176,7 @@ bootstrapping. (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 @@ -1088,39 +1184,32 @@ bootstrapping. ;; 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) @@ -1130,13 +1219,6 @@ bootstrapping. ((generic-function-name-p (car form)) (optimize-generic-function-call form required-parameters env slots calls)) - ((and (eq (car form) 'asv-funcall) - *optimize-asv-funcall-p*) - (case (fourth form) - (reader (push (third form) *asv-readers*)) - (writer (push (third form) *asv-writers*)) - (boundp (push (third form) *asv-boundps*))) - `(,(second form) ,@(cddddr form))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) @@ -1146,7 +1228,7 @@ bootstrapping. 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)) @@ -1173,8 +1255,7 @@ bootstrapping. *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*) @@ -1189,8 +1270,7 @@ bootstrapping. (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)) @@ -1208,32 +1288,26 @@ bootstrapping. (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" @@ -1243,7 +1317,7 @@ bootstrapping. :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))) @@ -1262,12 +1336,12 @@ bootstrapping. `(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)) @@ -1275,7 +1349,7 @@ bootstrapping. (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) @@ -1291,7 +1365,7 @@ bootstrapping. (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 @@ -1311,16 +1385,17 @@ bootstrapping. (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 ()) @@ -1329,20 +1404,25 @@ bootstrapping. (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))))) @@ -1350,7 +1430,7 @@ bootstrapping. (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) @@ -1358,25 +1438,27 @@ bootstrapping. 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))))) @@ -1384,45 +1466,44 @@ bootstrapping. (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)) ;;;; 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* @@ -1430,35 +1511,36 @@ bootstrapping. (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)) (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)) (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)) (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 @@ -1480,7 +1562,7 @@ bootstrapping. (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) @@ -1503,7 +1585,7 @@ bootstrapping. (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)) @@ -1526,7 +1608,7 @@ bootstrapping. (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))))) @@ -1541,35 +1623,34 @@ bootstrapping. (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 "~@" + :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))))))) @@ -1619,11 +1700,26 @@ bootstrapping. (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* (package-use-list *pcl-package*)))) + ;; FIXME: given the presence of generalized function + ;; names, this test is broken. A little + ;; reverse-engineering suggests that this was intended + ;; to prevent precompilation of things on some + ;; PCL-internal automatically-constructed functions + ;; like the old "~A~A standard class ~A reader" + ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR + ;; generalized functions was *, this test returned T, + ;; not NIL, and an error was signalled in + ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X + ;; 'ASLDKJ)). Whether the right thing to do is to fix + ;; MAKE-ACCESSOR-TABLE so that it can work in the + ;; presence of slot names that have no classes, or to + ;; restore this test to something more obvious, I don't + ;; know. -- CSR, 2003-02-14 (and sym (symbolp sym) (not (null (memq (symbol-package sym) pkg-list))) (not (find #\space (symbol-name sym)))))))) @@ -1653,14 +1749,17 @@ bootstrapping. ;;; 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." @@ -1668,11 +1767,13 @@ bootstrapping. '*!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) @@ -1688,13 +1789,17 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-truename*) - (set-function-name fin spec) + *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) @@ -1705,13 +1810,14 @@ bootstrapping. 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))))) @@ -1719,7 +1825,7 @@ bootstrapping. (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))))) @@ -1727,14 +1833,14 @@ bootstrapping. (defvar *sgf-name-index* (!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)))) @@ -1768,11 +1874,15 @@ bootstrapping. (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) @@ -1784,11 +1894,11 @@ bootstrapping. (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) @@ -1796,13 +1906,13 @@ bootstrapping. (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))))) -(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) @@ -1813,7 +1923,7 @@ bootstrapping. 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 @@ -1829,17 +1939,17 @@ bootstrapping. ;; 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 @@ -1883,22 +1993,24 @@ bootstrapping. (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)))))) @@ -1933,8 +2045,8 @@ bootstrapping. (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.")) @@ -1942,7 +2054,8 @@ bootstrapping. (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))) @@ -1956,7 +2069,8 @@ bootstrapping. (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))) @@ -1968,7 +2082,7 @@ bootstrapping. (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))) @@ -1978,12 +2092,10 @@ bootstrapping. (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))) @@ -2006,21 +2118,21 @@ bootstrapping. 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) @@ -2028,46 +2140,46 @@ bootstrapping. (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")) -;;; 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 ())) @@ -2078,6 +2190,7 @@ bootstrapping. (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) @@ -2107,14 +2220,13 @@ bootstrapping. (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 @@ -2132,9 +2244,9 @@ bootstrapping. (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))) (defun extract-parameters (specialized-lambda-list) @@ -2169,24 +2281,26 @@ bootstrapping. (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) () @@ -2204,16 +2318,15 @@ bootstrapping. (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))))))) -(eval-when (:load-toplevel :execute) - (setq *boot-state* 'early)) +(setq *boot-state* 'early) -;;; 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))) @@ -2223,19 +2336,19 @@ bootstrapping. (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)))) @@ -2247,12 +2360,11 @@ bootstrapping. (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))))