0.6.8.9:
[sbcl.git] / src / code / uncross.lisp
index 8043676..68d6e00 100644 (file)
                     (uncross-rcr-failure-form c)))))
 |#
 
-;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed in the
-;;; host Common Lisp, not the target. A certain amount of dancing around is
-;;; required in order for this to work more or less correctly. (Fortunately,
-;;; more or less correctly is good enough -- it only needs to work on the
-;;; EVAL-WHEN expressions found in the SBCL sources themselves, and we can
-;;; exercise self-control to keep them from including anything which too
-;;; strongly resembles a language lawyer's test case.)
+;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed
+;;; in the host Common Lisp, not the target. A certain amount of
+;;; dancing around is required in order for this to work more or less
+;;; correctly. (Fortunately, more or less correctly is good enough --
+;;; it only needs to work on the EVAL-WHEN expressions found in the
+;;; SBCL sources themselves, and we can exercise self-control to keep
+;;; them from including anything which too strongly resembles a
+;;; language lawyer's test case.)
 ;;;
-;;; In order to make the dancing happen, we need to make a distinction between
-;;; SB!XC and COMMON-LISP when we're executing a form at compile time (i.e.
-;;; within EVAL-WHEN :COMPILE-TOPLEVEL) but we need to treat SB!XC as
-;;; synonymous with COMMON-LISP otherwise. This can't be done by making SB!XC a
-;;; nickname of COMMON-LISP, because the reader processes things before
-;;; EVAL-WHEN, so by the time EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the
-;;; distinction it needs would be lost. Instead, we read forms preserving this
-;;; distinction (treating SB!XC as a separate package), and only when we're
-;;; about to process them (for any situation other than
-;;; EVAL-WHEN (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the
+;;; In order to make the dancing happen, we need to make a distinction
+;;; between SB!XC and COMMON-LISP when we're executing a form at
+;;; compile time (i.e. within EVAL-WHEN :COMPILE-TOPLEVEL) but we need
+;;; to treat SB!XC as synonymous with COMMON-LISP otherwise. This
+;;; can't be done by making SB!XC a nickname of COMMON-LISP, because
+;;; the reader processes things before EVAL-WHEN, so by the time
+;;; EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the distinction it needs
+;;; would be lost. Instead, we read forms preserving this distinction
+;;; (treating SB!XC as a separate package), and only when we're about
+;;; to process them (for any situation other than EVAL-WHEN
+;;; (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the
 ;;; distinction.
 #+sb-xc-host
 (defun uncross (form)
   (let ((;; KLUDGE: We don't currently try to handle circular program
-        ;; structure, but we do at least detect it and complain about it..
+        ;; structure, but we do at least detect it and complain about
+        ;; it..
         inside? (make-hash-table)))
     (labels ((uncross-symbol (symbol)
                (let ((old-symbol-package (symbol-package symbol)))
@@ -67,7 +70,7 @@
                          (string= (package-name old-symbol-package) "SB-XC"))
                     (values (intern (symbol-name symbol) "COMMON-LISP"))
                     symbol)))
-            (rcr (form)
+            (rcr (form) ; recursive part
               (cond ((symbolp form)
                      (uncross-symbol form))
                     ((or (numberp form)
                          (stringp form))
                      form)
                     (t
-                     ;; If we reach here, FORM is something with internal
-                     ;; structure which could include symbols in the SB-XC
-                     ;; package.
+                     ;; If we reach here, FORM is something with
+                     ;; internal structure which could include
+                     ;; symbols in the SB-XC package.
                      (when (gethash form inside?)
                        (let ((*print-circle* t))
-                         ;; This code could probably be generalized to work on
-                         ;; circular structure, but it seems easier just to
-                         ;; avoid putting any circular structure into the
-                         ;; bootstrap code.
+                         ;; This code could probably be generalized
+                         ;; to work on circular structure, but it
+                         ;; seems easier just to avoid putting any
+                         ;; circular structure into the bootstrap
+                         ;; code.
                          (error "circular structure in ~S" form)))
                      (setf (gethash form inside?) t)
                      (unwind-protect
                          (typecase form
                            (cons (rcr-cons form))
-                           ;; Note: This function was originally intended to
-                           ;; search through structures other than CONS, but
-                           ;; it got into trouble with LAYOUT-CLASS and
-                           ;; CLASS-LAYOUT circular structure. After some
-                           ;; messing around, it turned out that recursing
-                           ;; through CONS is all that's needed in practice.)
-                           ;; FIXME: This leaves a lot of stale code here
-                           ;; (already commented/NILed out) for us to delete.
-                           #+nil ; only searching through CONS
-                           (simple-vector (rcr-simple-vector form))
-                           #+nil ; only searching through CONS
-                           (structure!object
-                            (rcr-structure!object form))
                            (t
-                            ;; KLUDGE: I know that UNCROSS is far from
-                            ;; perfect, but it's good enough to cross-compile
-                            ;; the current sources, and getting hundreds of
-                            ;; warnings about individual cases it can't
-                            ;; recurse through, so the warning here has been
-                            ;; turned off. Eventually it would be nice either
-                            ;; to set up a cleaner way of cross-compiling
-                            ;; which didn't have this problem, or to make
-                            ;; an industrial-strength version of UNCROSS
-                            ;; which didn't fail this way. -- WHN 20000201
+                            ;; KLUDGE: There are other types
+                            ;; (especially (ARRAY T) and
+                            ;; STRUCTURE-OBJECT, but also HASH-TABLE
+                            ;; and perhaps others) which could hold
+                            ;; symbols. In principle we should handle
+                            ;; those types as well. Failing that, we
+                            ;; could give warnings for them. However,
+                            ;; the current system works for
+                            ;; bootstrapping in practice (because we
+                            ;; don't use those constructs that way)
+                            ;; and the warnings more annoying than
+                            ;; useful, so I simply turned the
+                            ;; warnings off. -- WHN 20001105
                             #+nil (warn 'uncross-rcr-failure :form form)
                             form))
                        (remhash form inside?)))))
                      (rcr-cdr (rcr cdr)))
                 (if (and (eq rcr-car car) (eq rcr-cdr cdr))
                   form
-                  (cons rcr-car rcr-cdr))))
-            #+nil ; only searching through CONS in this version
-            (rcr-simple-vector (form)
-              (declare (type simple-vector form))
-              (dotimes (i (length form))
-                (let* ((aref (aref form i))
-                       (rcr-aref (rcr aref)))
-                  (unless (eq rcr-aref aref)
-                    (return (map 'vector #'rcr form))))
-                form))
-            #+nil ; only searching through CONS in this version
-            (rcr-structure!object (form)
-              (declare (type structure!object form))
-              ;; Note: We skip the zeroth slot because it's used for LAYOUT,
-              ;; which shouldn't require any translation and which is
-              ;; complicated to think about anyway.
-              (do ((i 1 (1+ i)))
-                  ((>= i (%instance-length form)) form)
-                (let* ((instance-ref (%instance-ref form i))
-                       (rcr-instance-ref (rcr instance-ref)))
-                  (unless (eq rcr-instance-ref instance-ref)
-                    (return (rcr!-structure!object
-                             (copy-structure form)))))))
-            #+nil ; only searching through CONS in this version
-            (rcr!-structure!object (form)
-              (declare (type structure!object form))
-              ;; As in RCR-STRUCTURE!OBJECT, we skip the zeroth slot.
-              (do ((i 1 (1+ i)))
-                  ((>= i (%instance-length form)))
-                (let* ((instance-ref (%instance-ref form i))
-                       (rcr-instance-ref (rcr instance-ref)))
-                  ;; (By only calling SETF when strictly necessary,
-                  ;; we avoid bombing out unnecessarily when the
-                  ;; I-th slot happens to be read-only.)
-                  (unless (eq rcr-instance-ref instance-ref)
-                    (setf (%instance-ref form i)
-                          rcr-instance-ref))))))
+                  (cons rcr-car rcr-cdr)))))
       (rcr form))))