1.0.32.29: Add build flag :sb-xref-for-internals.

[sbcl.git] / src / pcl / boot.lisp

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index cc1dc82..e9eb7a6 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -353,7 +353,7 @@ bootstrapping.
 
 
 (defun prototypes-for-make-method-lambda (name)
 
 
 (defun prototypes-for-make-method-lambda (name)

-  (if (not (eq *boot-state* 'complete))
+  (if (not (eq **boot-state** 'complete))

       (values nil nil)
       (let ((gf? (and (fboundp name)
                       (gdefinition name))))
       (values nil nil)
       (let ((gf? (and (fboundp name)
                       (gdefinition name))))

@@ -379,7 +379,7 @@ bootstrapping.
 (defun method-prototype-for-gf (name)
   (let ((gf? (and (fboundp name)
                   (gdefinition name))))
 (defun method-prototype-for-gf (name)
   (let ((gf? (and (fboundp name)
                   (gdefinition name))))

-    (cond ((neq *boot-state* 'complete) nil)
+    (cond ((neq **boot-state** 'complete) nil)

           ((or (null gf?)
                (not (generic-function-p gf?)))          ; Someone else MIGHT
                                                         ; error at load time.
           ((or (null gf?)
                (not (generic-function-p gf?)))          ; Someone else MIGHT
                                                         ; error at load time.

@@ -754,15 +754,21 @@ bootstrapping.
   (declare (ignore env proto-gf proto-method))
   (flet ((parse (name)
            (cond
   (declare (ignore env proto-gf proto-method))
   (flet ((parse (name)
            (cond

-             ((and (eq *boot-state* 'complete)
+             ((and (eq **boot-state** 'complete)

                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))
              ((consp name) (ecase (car name)
                              ((eql) `(intern-eql-specializer ,(cadr name)))
                    (specializerp name))
               name)
              ((symbolp name) `(find-class ',name))
              ((consp name) (ecase (car name)
                              ((eql) `(intern-eql-specializer ,(cadr name)))

-                             ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
-                             ((prototype) `(fixme))))
-             (t (bug "Foo")))))
+                             ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))))
+             (t
+              ;; FIXME: Document CLASS-EQ specializers.
+              (error 'simple-reference-error
+                     :format-control
+                     "~@<~S is not a valid parameter specializer name.~@:>"
+                     :format-arguments (list name)
+                     :references (list '(:ansi-cl :macro defmethod)
+                                       '(:ansi-cl :glossary "parameter specializer name")))))))

     `(list ,@(mapcar #'parse specializer-names))))
 
 (unless (fboundp 'make-method-specializers-form)
     `(list ,@(mapcar #'parse specializer-names))))
 
 (unless (fboundp 'make-method-specializers-form)

@@ -857,7 +863,7 @@ bootstrapping.
                  ;; cases by blacklisting them here. -- WHN 2001-01-19
                  (list 'slot-object #+nil (find-class 'slot-object)))
          '(ignorable))
                  ;; cases by blacklisting them here. -- WHN 2001-01-19
                  (list 'slot-object #+nil (find-class 'slot-object)))
          '(ignorable))

-        ((not (eq *boot-state* 'complete))
+        ((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
          ;; 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

@@ -1543,7 +1549,7 @@ bootstrapping.
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
        (fboundp name)
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
        (fboundp name)

-       (if (eq *boot-state* 'complete)
+       (if (eq **boot-state** 'complete)

            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f
            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f

@@ -1573,7 +1579,7 @@ bootstrapping.
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
                   initargs source-location)
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
                   initargs source-location)

-  (when (and (eq *boot-state* 'complete)
+  (when (and (eq **boot-state** 'complete)

              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)
              (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
            (method (and (generic-function-p gf)

@@ -1721,7 +1727,7 @@ bootstrapping.
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
     (cond ((and existing

-                (eq *boot-state* 'complete)
+                (eq **boot-state** 'complete)

                 (null (generic-function-p existing)))
            (generic-clobbers-function fun-name)
            (fmakunbound fun-name)
                 (null (generic-function-p existing)))
            (generic-clobbers-function fun-name)
            (fmakunbound fun-name)

@@ -1750,32 +1756,32 @@ bootstrapping.
                       +slot-unbound+))))
           (early-collect-inheritance 'standard-generic-function)))
 
                       +slot-unbound+))))
           (early-collect-inheritance 'standard-generic-function)))
 

-(defvar *sgf-method-class-index*
+(defconstant +sgf-method-class-index+

   (!bootstrap-slot-index 'standard-generic-function 'method-class))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)
   (!bootstrap-slot-index 'standard-generic-function 'method-class))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)

-       (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+       (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+)

            +slot-unbound+)))
 
            +slot-unbound+)))
 

-(defvar *sgf-methods-index*
+(defconstant +sgf-methods-index+

   (!bootstrap-slot-index 'standard-generic-function 'methods))
 
 (defmacro early-gf-methods (gf)
   (!bootstrap-slot-index 'standard-generic-function 'methods))
 
 (defmacro early-gf-methods (gf)

-  `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+))

 
 (defun safe-generic-function-methods (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
 
 (defun safe-generic-function-methods (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+      (clos-slots-ref (get-slots generic-function) +sgf-methods-index+)

       (generic-function-methods generic-function)))
 
       (generic-function-methods generic-function)))
 

-(defvar *sgf-arg-info-index*
+(defconstant +sgf-arg-info-index+

   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
 
 (defmacro early-gf-arg-info (gf)
   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
 
 (defmacro early-gf-arg-info (gf)

-  `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
+  `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+))

 
 

-(defvar *sgf-dfun-state-index*
+(defconstant +sgf-dfun-state-index+

   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
 
 (defstruct (arg-info
   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
 
 (defstruct (arg-info

@@ -1821,10 +1827,10 @@ bootstrapping.
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
                         argument-precedence-order)
 
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
                         argument-precedence-order)

-  (let* ((arg-info (if (eq *boot-state* 'complete)
+  (let* ((arg-info (if (eq **boot-state** 'complete)

                        (gf-arg-info gf)
                        (early-gf-arg-info gf)))
                        (gf-arg-info gf)
                        (early-gf-arg-info gf)))

-         (methods (if (eq *boot-state* 'complete)
+         (methods (if (eq **boot-state** 'complete)

                       (generic-function-methods gf)
                       (early-gf-methods gf)))
          (was-valid-p (integerp (arg-info-number-optional arg-info)))
                       (generic-function-methods gf)
                       (early-gf-methods gf)))
          (was-valid-p (integerp (arg-info-number-optional arg-info)))

@@ -1903,21 +1909,19 @@ bootstrapping.
                    ~S."
                   gf-keywords)))))))
 
                    ~S."
                   gf-keywords)))))))
 

-(defvar *sm-specializers-index*
+(defconstant +sm-specializers-index+

   (!bootstrap-slot-index 'standard-method 'specializers))
   (!bootstrap-slot-index 'standard-method 'specializers))

-(defvar *sm-%function-index*
+(defconstant +sm-%function-index+

   (!bootstrap-slot-index 'standard-method '%function))
   (!bootstrap-slot-index 'standard-method '%function))

-(defvar *sm-qualifiers-index*
+(defconstant +sm-qualifiers-index+

   (!bootstrap-slot-index 'standard-method 'qualifiers))
   (!bootstrap-slot-index 'standard-method 'qualifiers))

-(defvar *sm-plist-index*
-  (!bootstrap-slot-index 'standard-method 'plist))

 
 ;;; FIXME: we don't actually need this; we could test for the exact
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.
 
 ;;; FIXME: we don't actually need this; we could test for the exact
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.

-(dolist (s '(specializers %function plist))
-  (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+(dolist (s '(specializers %function))
+  (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s)))

            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
            (!bootstrap-slot-index 'standard-boundp-method s)
            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
            (!bootstrap-slot-index 'standard-boundp-method s)

@@ -1925,34 +1929,31 @@ bootstrapping.
            (!bootstrap-slot-index 'global-writer-method s)
            (!bootstrap-slot-index 'global-boundp-method s))))
 
            (!bootstrap-slot-index 'global-writer-method s)
            (!bootstrap-slot-index 'global-boundp-method s))))
 

-(define-symbol-macro *standard-method-classes*
-  (list *the-class-standard-method* *the-class-standard-reader-method*
-        *the-class-standard-writer-method* *the-class-standard-boundp-method*
-        *the-class-global-reader-method* *the-class-global-writer-method*
-        *the-class-global-boundp-method*))
+(defvar *standard-method-class-names*
+  '(standard-method standard-reader-method
+    standard-writer-method standard-boundp-method
+    global-reader-method global-writer-method
+    global-boundp-method))
+
+(declaim (list **standard-method-classes**))
+(defglobal **standard-method-classes** nil)

 
 (defun safe-method-specializers (method)
 
 (defun safe-method-specializers (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-specializers-index*)
-        (method-specializers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-specializers-index+)
+      (method-specializers method)))

 (defun safe-method-fast-function (method)
   (let ((mf (safe-method-function method)))
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)
 (defun safe-method-fast-function (method)
   (let ((mf (safe-method-function method)))
     (and (typep mf '%method-function)
          (%method-function-fast-function mf))))
 (defun safe-method-function (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-%function-index*)
-        (method-function method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-%function-index+)
+      (method-function method)))

 (defun safe-method-qualifiers (method)
 (defun safe-method-qualifiers (method)

-  (let ((standard-method-classes *standard-method-classes*)
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
-        (method-qualifiers method))))
+  (if (member (class-of method) **standard-method-classes** :test #'eq)
+      (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+)
+      (method-qualifiers method)))

 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
   (let* ((existing-p (and methods (cdr methods) new-method))
 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
   (let* ((existing-p (and methods (cdr methods) new-method))

@@ -1965,16 +1966,16 @@ bootstrapping.
                    nil)))
     (when (arg-info-valid-p arg-info)
       (dolist (method (if new-method (list new-method) methods))
                    nil)))
     (when (arg-info-valid-p arg-info)
       (dolist (method (if new-method (list new-method) methods))

-        (let* ((specializers (if (or (eq *boot-state* 'complete)
+        (let* ((specializers (if (or (eq **boot-state** 'complete)

                                      (not (consp method)))
                                  (safe-method-specializers method)
                                  (early-method-specializers method t)))
                                      (not (consp method)))
                                  (safe-method-specializers method)
                                  (early-method-specializers method t)))

-               (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+               (class (if (or (eq **boot-state** 'complete) (not (consp method)))

                           (class-of method)
                           (early-method-class method)))
                (new-type
                 (when (and class
                           (class-of method)
                           (early-method-class method)))
                (new-type
                 (when (and class

-                           (or (not (eq *boot-state* 'complete))
+                           (or (not (eq **boot-state** 'complete))

                                (eq (generic-function-method-combination gf)
                                    *standard-method-combination*)))
                   (cond ((or (eq class *the-class-standard-reader-method*)
                                (eq (generic-function-method-combination gf)
                                    *standard-method-combination*)))
                   (cond ((or (eq class *the-class-standard-reader-method*)

@@ -2002,7 +2003,7 @@ bootstrapping.
       (unless (gf-info-c-a-m-emf-std-p arg-info)
         (setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p
       (unless (gf-info-c-a-m-emf-std-p arg-info)
         (setf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p

-    (let ((name (if (eq *boot-state* 'complete)
+    (let ((name (if (eq **boot-state** 'complete)

                     (generic-function-name gf)
                     (!early-gf-name gf))))
       (setf (gf-precompute-dfun-and-emf-p arg-info)
                     (generic-function-name gf)
                     (!early-gf-name gf))))
       (setf (gf-precompute-dfun-and-emf-p arg-info)

@@ -2023,7 +2024,7 @@ bootstrapping.
                         ;; remain.
                         (not (find #\Space (symbol-name symbol))))))))))
   (setf (gf-info-fast-mf-p arg-info)
                         ;; remain.
                         (not (find #\Space (symbol-name symbol))))))))))
   (setf (gf-info-fast-mf-p arg-info)

-        (or (not (eq *boot-state* 'complete))
+        (or (not (eq **boot-state** 'complete))

             (let* ((method-class (generic-function-method-class gf))
                    (methods (compute-applicable-methods
                              #'make-method-lambda
             (let* ((method-class (generic-function-method-class gf))
                    (methods (compute-applicable-methods
                              #'make-method-lambda

@@ -2113,12 +2114,12 @@ bootstrapping.
 
 (defun safe-gf-dfun-state (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
 
 (defun safe-gf-dfun-state (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+      (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+)

       (gf-dfun-state generic-function)))
 (defun (setf safe-gf-dfun-state) (new-value generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (gf-dfun-state generic-function)))
 (defun (setf safe-gf-dfun-state) (new-value generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)

-      (setf (clos-slots-ref (get-slots generic-function)
-                            *sgf-dfun-state-index*)
+      (setf (clos-slots-ref (fsc-instance-slots generic-function)
+                            +sgf-dfun-state-index+)

             new-value)
       (setf (gf-dfun-state generic-function) new-value)))
 
             new-value)
       (setf (gf-dfun-state generic-function) new-value)))
 

@@ -2127,44 +2128,44 @@ bootstrapping.
                        (list* dfun cache info)
                        dfun)))
     (cond
                        (list* dfun cache info)
                        dfun)))
     (cond

-      ((eq *boot-state* 'complete)
+      ((eq **boot-state** 'complete)

        ;; Check that we are under the lock.
        #+sb-thread
        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
        (setf (safe-gf-dfun-state gf) new-state))
       (t
        ;; Check that we are under the lock.
        #+sb-thread
        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
        (setf (safe-gf-dfun-state gf) new-state))
       (t

-       (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
+       (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)

              new-state))))
   dfun)
 
 (defun gf-dfun-cache (gf)
              new-state))))
   dfun)
 
 (defun gf-dfun-cache (gf)

-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)

                    (safe-gf-dfun-state gf)
                    (safe-gf-dfun-state gf)

-                   (clos-slots-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)))))
 
 (defun gf-dfun-info (gf)
     (typecase state
       (function nil)
       (cons (cadr state)))))
 
 (defun gf-dfun-info (gf)

-  (let ((state (if (eq *boot-state* 'complete)
+  (let ((state (if (eq **boot-state** 'complete)

                    (safe-gf-dfun-state gf)
                    (safe-gf-dfun-state gf)

-                   (clos-slots-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)))))
 
     (typecase state
       (function nil)
       (cons (cddr state)))))
 

-(defvar *sgf-name-index*
+(defconstant +sgf-name-index+

   (!bootstrap-slot-index 'standard-generic-function 'name))
 
 (defun !early-gf-name (gf)
   (!bootstrap-slot-index 'standard-generic-function 'name))
 
 (defun !early-gf-name (gf)

-  (clos-slots-ref (get-slots gf) *sgf-name-index*))
+  (clos-slots-ref (get-slots gf) +sgf-name-index+))

 
 (defun gf-lambda-list (gf)
 
 (defun gf-lambda-list (gf)

-  (let ((arg-info (if (eq *boot-state* 'complete)
+  (let ((arg-info (if (eq **boot-state** 'complete)

                       (gf-arg-info gf)
                       (early-gf-arg-info gf))))
     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
                       (gf-arg-info gf)
                       (early-gf-arg-info gf))))
     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))

-        (let ((methods (if (eq *boot-state* 'complete)
+        (let ((methods (if (eq **boot-state** 'complete)

                            (generic-function-methods gf)
                            (early-gf-methods gf))))
           (if (null methods)
                            (generic-function-methods gf)
                            (early-gf-methods gf))))
           (if (null methods)

@@ -2209,19 +2210,41 @@ bootstrapping.
                     (t (find-class method-class t ,env))))))))
 
 (defun note-gf-signature (fun-name lambda-list-p lambda-list)
                     (t (find-class method-class t ,env))))))))
 
 (defun note-gf-signature (fun-name lambda-list-p lambda-list)

-  ;; FIXME: Ideally we would like to not clobber it, but because generic
-  ;; functions assert their FTYPEs callers believing the FTYPE are
-  ;; left with unsafe assumptions. Hence the clobbering.
-  (when (eq :declared (info :function :where-from fun-name))
-    (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~
-                 for the same name.~:@>"
-                fun-name 'ftype))
-  (setf (info :function :type fun-name)
-        (specifier-type
-         (if lambda-list-p
-             (ftype-declaration-from-lambda-list lambda-list fun-name)
-             'function)))
-  (setf (info :function :where-from fun-name) :defined-method))
+  (unless lambda-list-p
+    ;; Use the existing lambda-list, if any. It is reasonable to do eg.
+    ;;
+    ;;   (if (fboundp name)
+    ;;       (ensure-generic-function name)
+    ;;       (ensure-generic-function name :lambda-list '(foo)))
+    ;;
+    ;; in which case we end up here with no lambda-list in the first leg.
+    (setf (values lambda-list lambda-list-p)
+          (handler-case
+              (values (generic-function-lambda-list (fdefinition fun-name))
+                      t)
+            ((or warning error) ()
+              (values nil nil)))))
+  (let ((gf-type
+         (specifier-type
+          (if lambda-list-p
+              (ftype-declaration-from-lambda-list lambda-list fun-name)
+              'function)))
+        (old-type nil))
+    ;; FIXME: Ideally we would like to not clobber it, but because generic
+    ;; functions assert their FTYPEs callers believing the FTYPE are left with
+    ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type
+    ;; is a subtype of the old one, though -- even though the type is not
+    ;; trusted anymore, the warning is still not quite as interesting.
+    (when (and (eq :declared (info :function :where-from fun-name))
+               (not (csubtypep gf-type (setf old-type (info :function :type fun-name)))))
+      (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~S ~
+                   for the same name with ~S.~:@>"
+                  fun-name 'ftype
+                  (type-specifier old-type)
+                  (type-specifier gf-type)))
+    (setf (info :function :type fun-name) gf-type
+          (info :function :where-from fun-name) :defined-method)
+    fun-name))

 
 (defun real-ensure-gf-using-class--generic-function
        (existing
 
 (defun real-ensure-gf-using-class--generic-function
        (existing

@@ -2257,7 +2280,7 @@ bootstrapping.
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (clos-slots-ref (fsc-instance-slots generic-function)
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
       (clos-slots-ref (fsc-instance-slots generic-function)

-                      *sgf-arg-info-index*)
+                      +sgf-arg-info-index+)

       (gf-arg-info generic-function)))
 
 ;;; FIXME: this function took on a slightly greater role than it
       (gf-arg-info generic-function)))
 
 ;;; FIXME: this function took on a slightly greater role than it

@@ -2693,7 +2716,7 @@ bootstrapping.
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f
                      (cons (if (listp arg) (cadr arg) t) specializers)
                      (cons (if (listp arg) (car arg) arg) required)))))))
 \f

-(setq *boot-state* 'early)
+(setq **boot-state** 'early)

 \f
 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
 ;;; which used %WALKER stuff. That suggests to me that maybe the code
 \f
 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
 ;;; which used %WALKER stuff. That suggests to me that maybe the code

@@ -2702,7 +2725,7 @@ bootstrapping.
 
 (defun extract-the (form)
   (cond ((and (consp form) (eq (car form) 'the))
 
 (defun extract-the (form)
   (cond ((and (consp form) (eq (car form) 'the))

-         (aver (proper-list-of-length-p 3))
+         (aver (proper-list-of-length-p form 3))

          (third form))
         (t
          form)))
          (third form))
         (t
          form)))