X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=d85ca7d978c8ab6cb86bc8f6bcd43455009b7902;hb=be9eb6c67b5f43a095c3de17bea945c309d662e4;hp=a8b28eeef50b5eb1e44b6b915d2179d24bf74ebf;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index a8b28ee..d85ca7d 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -105,26 +105,14 @@ bootstrapping. ;;; 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))) - (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-function-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 @@ -169,15 +157,10 @@ bootstrapping. 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))) (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,11 +168,6 @@ 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)))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) @@ -203,7 +181,7 @@ bootstrapping. (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 +191,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)))))) @@ -223,24 +201,19 @@ bootstrapping. `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',function-name)) - ,(make-top-level-form - `(defgeneric ,function-name) - *defgeneric-times* - `(load-defgeneric ',function-name ',lambda-list ,@initargs)) + (load-defgeneric ',function-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) `,(function ,function-name))))) (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) + (unless (eq (info :function :where-from function-name) :declared) + (setf (info :function :where-from function-name) :defined) + (setf (info :function :type function-name) (sb-kernel:specifier-type 'function)))) (defun load-defgeneric (function-name lambda-list &rest initargs) - (when (listp function-name) - (do-standard-defsetf-1 (cadr function-name))) (when (fboundp function-name) (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name)) (apply #'ensure-generic-function @@ -311,8 +284,6 @@ 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)) @@ -369,7 +340,7 @@ 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 (function-name-block-name name)) (every #'interned-symbol-p qualifiers) (every #'(lambda (s) (if (consp s) @@ -403,32 +374,29 @@ 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 @@ -491,6 +459,63 @@ 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, ~ @@ -520,62 +545,20 @@ bootstrapping. ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 ,@(remove nil (mapcar (lambda (a s) (and (symbolp s) - (neq s 't) + (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 @@ -602,22 +585,19 @@ bootstrapping. (declare (ignorable ,@required-parameters)) ,class-declarations ,@declarations - (block ,(sb-int:function-name-block-name + (block ,(function-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)) @@ -635,7 +615,7 @@ bootstrapping. (extract-declarations (cddr walked-lambda)) (declare (ignore ignore)) (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) @@ -719,7 +699,7 @@ bootstrapping. `(not (null .next-method.)))) ,@body)) -(defstruct method-call +(defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -740,7 +720,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 @@ -757,7 +737,7 @@ 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)) @@ -818,7 +798,22 @@ bootstrapping. (unless (constantp restp) (error "The RESTP argument is not constant.")) (setq restp (eval restp)) - `(progn + `(locally + + ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings + ;; about type mismatches in unreachable code when we + ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and + ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline + ;; function instead of a macro, which seems sufficient to solve + ;; the problem all by itself (probably because of some quirk in + ;; the relative order of expansion and type inference) but we + ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it + ;; looks as though (1) inlining isn't that much of a win anyway, + ;; and (2a) once you miss the FAST-METHOD-CALL clause you're + ;; going to be slow anyway, but (2b) code bloat still hurts even + ;; when it's off the critical path. + (declare (notinline get-slots-or-nil)) + (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)) @@ -826,7 +821,7 @@ bootstrapping. `(((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) @@ -836,15 +831,15 @@ bootstrapping. (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) - (when .slots. ; just to avoid compiler warnings - (setf (%instance-ref .slots. ,emf) .new-value.)))))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) #|| ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fast-instance-boundp) (let ((.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (and .slots. - (not (eq (%instance-ref + (not (eq (clos-slots-ref .slots. (fast-instance-boundp-index ,emf)) +slot-unbound+))))))) ||# @@ -896,20 +891,22 @@ 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)))) @@ -973,8 +970,8 @@ bootstrapping. (null closurep) (null applyp)) `(let () ,@body)) - ((and (null closurep) - (null applyp)) + ((and (null closurep) + (null applyp)) ;; OK to use MACROLET, and all args are mandatory ;; (else APPLYP would be true). `(call-next-method-bind @@ -1028,14 +1025,14 @@ bootstrapping. ,(cadr var))))))) (rest `((,var ,args-tail))) (key (cond ((not (consp var)) - `((,var (get-key-arg ,(sb-int:keywordicate var) + `((,var (get-key-arg ,(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) @@ -1046,7 +1043,7 @@ 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)) (,(caddr var) ,key) @@ -1086,39 +1083,31 @@ 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) @@ -1144,7 +1133,7 @@ bootstrapping. next-method-p-p))))) (defun generic-function-name-p (name) - (and (sb-int:legal-function-name-p name) + (and (legal-function-name-p name) (gboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) @@ -1171,8 +1160,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*) @@ -1187,8 +1175,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)) @@ -1206,32 +1193,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) (make-method-spec name quals specls)))) (setf (getf initargs ':method-spec) method-spec) - (record-definition 'method 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) 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" @@ -1309,12 +1290,12 @@ 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-argument (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) @@ -1327,18 +1308,19 @@ 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-argument x) keywords) (push x keyword-parameters)) (rest ())))) (values nrequired noptional keysp restp allow-other-keys-p @@ -1348,7 +1330,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) @@ -1356,19 +1338,21 @@ 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) @@ -1404,9 +1388,8 @@ bootstrapping. existing function-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." + (error 'simple-program-error + :format-control "~S already names an ordinary function or a macro." :format-arguments (list function-name))) (defvar *sgf-wrapper* @@ -1428,35 +1411,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 @@ -1478,7 +1462,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) @@ -1524,7 +1508,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))))) @@ -1545,20 +1529,20 @@ bootstrapping. method gf (apply #'format nil string args))) - (compare (x y) + (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~%~ @@ -1567,7 +1551,7 @@ bootstrapping. (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~%~ + (lose "the method does not accept each of the &KEY arguments~%~ ~S." gf-keywords))))))) @@ -1651,7 +1635,8 @@ 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) &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1703,13 +1688,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))))) @@ -1717,7 +1703,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))))) @@ -1726,7 +1712,7 @@ bootstrapping. (!bootstrap-slot-index 'standard-generic-function 'name)) (defun !early-gf-name (gf) - (instance-ref (get-slots gf) *sgf-name-index*)) + (clos-slots-ref (get-slots gf) *sgf-name-index*)) (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) @@ -1766,7 +1752,11 @@ 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 @@ -1811,7 +1801,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 @@ -1830,7 +1820,7 @@ bootstrapping. (if (every #'(lambda (s) (not (symbolp s))) specializers) (setq parsed specializers unparsed (mapcar #'(lambda (s) - (if (eq s 't) 't (class-name s))) + (if (eq s t) t (class-name s))) specializers)) (setq unparsed specializers parsed ())) @@ -1898,7 +1888,7 @@ bootstrapping. (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)))))) @@ -1970,7 +1960,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))) @@ -1980,12 +1970,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))) @@ -2008,13 +1996,13 @@ 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 @@ -2030,11 +2018,11 @@ 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) @@ -2042,7 +2030,7 @@ bootstrapping. (specializers (second method)) (method-fn-name (third method)) (fn-name (or method-fn-name fspec)) - (fn (symbol-function fn-name)) + (fn (fdefinition fn-name)) (initargs (list :function (set-function-name @@ -2063,13 +2051,13 @@ bootstrapping. (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. (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 ())) @@ -2080,6 +2068,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) @@ -2179,8 +2168,7 @@ bootstrapping. ;; "internal error: unrecognized lambda-list keyword ~S"? (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ Assuming that the symbols following it are parameters,~%~ - and not allowing any parameter specializers to follow~%~ - to follow it." + and not allowing any parameter specializers to follow it." arg)) ;; When we are at a lambda-list keyword, the parameters ;; don't include the lambda-list keyword; the lambda-list @@ -2206,11 +2194,10 @@ 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