X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=1152cec9fd8a63e92ce9f8fdf105fbf3a7e891ea;hb=4cf50b1896b25f5337e7c258b0b560da00d47993;hp=866f813cf6117ee414671de0eccb4f2ff6d389d7;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 866f813..1152cec 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -105,8 +105,6 @@ 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. -(eval-when (:load-toplevel :execute) - (dolist (fns *!early-functions*) (let ((name (car fns)) (early-name (cadr fns))) @@ -115,7 +113,6 @@ bootstrapping. (lambda (&rest args) (apply (fdefinition early-name) args)) name)))) -) ; EVAL-WHEN ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS ;;; to convert the few functions in the bootstrap which are supposed @@ -166,7 +163,7 @@ bootstrapping. (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 @@ -192,7 +189,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) @@ -202,7 +199,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)))))) @@ -219,9 +216,9 @@ bootstrapping. (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) @@ -351,7 +348,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) @@ -385,29 +382,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 (:load-toplevel :execute) - (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)))) + `(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 @@ -596,7 +593,7 @@ 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)) @@ -710,7 +707,7 @@ bootstrapping. `(not (null .next-method.)))) ,@body)) -(defstruct method-call +(defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -731,7 +728,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 @@ -748,7 +745,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)) @@ -809,7 +806,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)) @@ -966,8 +978,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 @@ -1021,14 +1033,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) @@ -1039,7 +1051,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) @@ -1129,7 +1141,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)) @@ -1193,7 +1205,6 @@ bootstrapping. (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))) @@ -1287,12 +1298,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) @@ -1317,7 +1328,7 @@ bootstrapping. (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 @@ -1327,7 +1338,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) @@ -1335,7 +1346,7 @@ bootstrapping. keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) - (let* ((old (sb-int:info :function :type name)) ;FIXME:FDOCUMENTATION instead? + (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead? (old-ftype (if (sb-kernel:function-type-p old) old nil)) (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype))) (old-keys (and old-ftype @@ -1385,9 +1396,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,16 +1438,17 @@ bootstrapping. (!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 @@ -1505,7 +1516,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))))) @@ -1526,20 +1537,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~%~ @@ -1548,7 +1559,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))))))) @@ -1632,7 +1643,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)) @@ -1962,12 +1974,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))) @@ -1990,13 +2000,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 @@ -2012,11 +2022,11 @@ bootstrapping. (set-methods gf methods))) (dolist (fn *!early-functions*) - (sb-int:/show 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) @@ -2045,13 +2055,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 ())) @@ -2062,6 +2072,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) @@ -2190,8 +2201,7 @@ bootstrapping. (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