X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=6c9c9d4d808b9d26f99246f172d5f5b1b320fd44;hb=db55ad022ec7cc7a2f251918579fdeba7f17dbe0;hp=c698023d0e8b9da3579c5e9ed2a054213662ec61;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c698023..6c9c9d4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -105,17 +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. -(eval-when (:load-toplevel :execute) - (dolist (fns *!early-functions*) (let ((name (car fns)) (early-name (cadr fns))) (setf (gdefinition name) (set-function-name - #'(lambda (&rest args) - (apply (the function (name-get-fdefinition early-name)) args)) + (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 @@ -160,13 +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) (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 @@ -174,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) @@ -192,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) @@ -202,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)))))) @@ -219,9 +208,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 +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) @@ -385,29 +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 (: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 @@ -556,7 +545,7 @@ 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)) @@ -596,7 +585,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)) @@ -626,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) @@ -710,7 +699,7 @@ bootstrapping. `(not (null .next-method.)))) ,@body)) -(defstruct method-call +(defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -731,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 @@ -748,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)) @@ -809,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)) @@ -817,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) @@ -828,14 +832,14 @@ bootstrapping. (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (when .slots. - (setf (instance-ref .slots. ,emf) .new-value.)))))) + (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+))))))) ||# @@ -888,20 +892,20 @@ bootstrapping. (cond ((null args) (error "1 or 2 args were expected.")) ((null (cdr args)) (let* ((slots (get-slots (car args))) - (value (instance-ref slots emf))) + (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.") (let ((slots (get-slots (car args)))) - (not (eq (instance-ref slots - (fast-instance-boundp-index emf)) + (not (eq (clos-slots-ref slots + (fast-instance-boundp-index emf)) +slot-unbound+))))) (function (apply emf args)))) @@ -966,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 @@ -1021,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) @@ -1039,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) @@ -1079,18 +1083,18 @@ 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)))) @@ -1129,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)) @@ -1193,7 +1197,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))) @@ -1205,7 +1208,7 @@ bootstrapping. pv-table-symbol)) (when (and (eq *boot-state* 'complete) (fboundp gf-spec)) - (let* ((gf (name-get-fdefinition gf-spec)) + (let* ((gf (fdefinition gf-spec)) (method (and (generic-function-p gf) (find-method gf qualifiers @@ -1287,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) @@ -1305,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 @@ -1326,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) @@ -1334,19 +1338,21 @@ 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 (mapcar #'sb-kernel:key-info-name - (sb-kernel:function-type-keywords old-ftype)))) + (sb-kernel:function-type-keywords + old-ftype)))) (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype))) - (old-allowp (and old-ftype (sb-kernel:function-type-allowp old-ftype))) + (old-allowp (and old-ftype + (sb-kernel:function-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) @@ -1382,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* @@ -1406,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 @@ -1456,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) @@ -1502,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))))) @@ -1523,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~%~ @@ -1545,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))))))) @@ -1629,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)) @@ -1681,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))))) @@ -1695,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))))) @@ -1704,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) @@ -1744,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 @@ -1789,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 @@ -1808,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 ())) @@ -1876,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)))))) @@ -1948,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))) @@ -1958,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))) @@ -1986,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 @@ -2008,11 +2018,11 @@ bootstrapping. (set-methods gf methods))) (dolist (fn *!early-functions*) - (sb-int:/show fn) - (setf (gdefinition (car fn)) (name-get-fdefinition (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) @@ -2020,7 +2030,7 @@ bootstrapping. (specializers (second method)) (method-fn-name (third method)) (fn-name (or method-fn-name fspec)) - (fn (name-get-fdefinition fn-name)) + (fn (fdefinition fn-name)) (initargs (list :function (set-function-name @@ -2041,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 ())) @@ -2058,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) @@ -2183,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