X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=221647a8d02ede23071d8c3bd91cf5bd0c3aec73;hb=419ce099442b9bffe41eff8516c6a2be085259de;hp=eaa6513a9e36252ecf8e54c0e30bc25c340c71a7;hpb=39ecf3129db04ecf861c08459b6f5353bfc266c9;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index eaa6513..221647a 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-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 +131,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 +156,11 @@ 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) (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,12 +168,7 @@ 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)))) + `(defmethod ,fun-name ,@qualifiers ,arglist ,@body)))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -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)))))) @@ -222,32 +200,26 @@ 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)) + (compile-or-load-defgeneric ',fun-name)) + (load-defgeneric ',fun-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) + `,(function ,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)) (apply #'ensure-generic-function - function-name + fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,function-name) - ,*load-truename*) + :definition-source `((defgeneric ,fun-name) ,*load-truename*) initargs)) (defmacro defmethod (&rest args &environment env) @@ -311,8 +283,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 +339,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 (fun-name-block-name name)) (every #'interned-symbol-p qualifiers) (every #'(lambda (s) (if (consp s) @@ -403,32 +373,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 @@ -573,11 +540,11 @@ bootstrapping. ;; These declarations seem to be used by PCL to pass ;; information to itself; when I tried to delete 'em ;; ca. 0.6.10 it didn't work. I'm not sure how - ;; they work, but note the (VARIABLE-DECLARATION '%CLASS ..) + ;; 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) + (neq s t) `(%class ,a ,s))) parameters specializers)) @@ -617,22 +584,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)) @@ -650,7 +613,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) @@ -734,7 +697,7 @@ bootstrapping. `(not (null .next-method.)))) ,@body)) -(defstruct method-call +(defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -755,7 +718,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 @@ -772,7 +735,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)) @@ -833,7 +796,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)) @@ -841,7 +819,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) @@ -851,15 +829,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+))))))) ||# @@ -911,20 +889,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)))) @@ -988,8 +968,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 @@ -1043,14 +1023,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) @@ -1061,7 +1041,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) @@ -1101,39 +1081,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) @@ -1159,7 +1132,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)) @@ -1186,8 +1159,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*) @@ -1202,8 +1174,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)) @@ -1221,32 +1192,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" @@ -1288,7 +1253,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) @@ -1304,7 +1269,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 @@ -1324,12 +1289,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) @@ -1342,18 +1307,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 @@ -1363,7 +1329,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) @@ -1371,19 +1337,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) @@ -1397,32 +1365,31 @@ 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) @@ -1443,35 +1410,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 @@ -1493,7 +1461,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) @@ -1539,7 +1507,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))))) @@ -1560,20 +1528,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~%~ @@ -1582,7 +1550,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))))))) @@ -1666,7 +1634,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)) @@ -1685,7 +1654,7 @@ bootstrapping. (defun make-early-gf (spec &optional lambda-list lambda-list-p function) (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) @@ -1702,7 +1671,7 @@ bootstrapping. fin 'source *load-truename*) - (set-function-name fin spec) + (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p @@ -1718,13 +1687,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))))) @@ -1732,7 +1702,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))))) @@ -1741,7 +1711,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) @@ -1781,11 +1751,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) @@ -1797,11 +1771,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) @@ -1809,11 +1783,11 @@ 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) ;; values nreq applyp metatypes nkeys arg-info @@ -1826,7 +1800,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 @@ -1845,7 +1819,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 ())) @@ -1913,7 +1887,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)))))) @@ -1985,7 +1959,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))) @@ -1995,12 +1969,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))) @@ -2023,13 +1995,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 @@ -2045,11 +2017,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) @@ -2057,10 +2029,10 @@ 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 + (set-fun-name #'(lambda (args next-methods) (declare (ignore next-methods)) @@ -2078,13 +2050,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 ())) @@ -2095,6 +2067,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) @@ -2130,7 +2103,7 @@ bootstrapping. 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 @@ -2148,9 +2121,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) @@ -2194,8 +2167,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 @@ -2221,11 +2193,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 @@ -2243,7 +2214,7 @@ bootstrapping. `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((variable-name + (let ((var-name (if (symbolp slot-entry) slot-entry (car slot-entry))) @@ -2251,7 +2222,7 @@ bootstrapping. (if (symbolp slot-entry) slot-entry (cadr slot-entry)))) - `(,variable-name + `(,var-name (slot-value ,in ',slot-name)))) slots) ,@body)))) @@ -2267,9 +2238,8 @@ bootstrapping. `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((variable-name (car slot-entry)) + (let ((var-name (car slot-entry)) (accessor-name (cadr slot-entry))) - `(,variable-name - (,accessor-name ,in)))) + `(,var-name (,accessor-name ,in)))) slots) ,@body))))