src/code/uncross.lisp

   1 ;;;; converting symbols from SB-XC::FOO to COMMON-LISP::FOO when
   2 ;;;; cross-compiling (so that we can maintain distinct SB!XC versions
   3 ;;;; of fundamental COMMON-LISP things like PROCLAIM and CLASS and
   4 ;;;; ARRAY-RANK-LIMIT, so that we don't trash the cross-compilation
   5 ;;;; host when defining the cross-compiler, but the distinctions go
   6 ;;;; away in the target system)
   7
   8 ;;;; This software is part of the SBCL system. See the README file for
   9 ;;;; more information.
  10 ;;;;
  11 ;;;; This software is derived from the CMU CL system, which was
  12 ;;;; written at Carnegie Mellon University and released into the
  13 ;;;; public domain. The software is in the public domain and is
  14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  15 ;;;; files for more information.
  16
  17 (in-package "SB!INT")
  18
  19 ;;;; $Header$
  20
  21 ;;; In the target system's compiler, uncrossing is just identity.
  22 #-sb-xc-host
  23 (progn
  24   #!-sb-fluid (declaim (inline uncross))
  25   (defun uncross (x) x))
  26 ;;; In the cross-compiler, uncrossing is slightly less trivial.
  27
  28 ;;; This condition is only a STYLE-WARNING because generally it isn't important
  29 ;;; in practice to recurse through anything except CONSes anyway.
  30 #|
  31 #!+sb-show
  32 (define-condition uncross-rcr-failure (style-warning)
  33   ((form :initarg :form :reader uncross-rcr-failure-form))
  34   (:report (lambda (c s)
  35              (format s
  36                      "UNCROSS couldn't recurse through ~S~%~
  37                       (which is OK as long as there are no SB-XC symbols ~
  38                       down there)"
  39                      (uncross-rcr-failure-form c)))))
  40 |#
  41
  42 ;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed in the
  43 ;;; host Common Lisp, not the target. A certain amount of dancing around is
  44 ;;; required in order for this to work more or less correctly. (Fortunately,
  45 ;;; more or less correctly is good enough -- it only needs to work on the
  46 ;;; EVAL-WHEN expressions found in the SBCL sources themselves, and we can
  47 ;;; exercise self-control to keep them from including anything which too
  48 ;;; strongly resembles a language lawyer's test case.)
  49 ;;;
  50 ;;; In order to make the dancing happen, we need to make a distinction between
  51 ;;; SB!XC and COMMON-LISP when we're executing a form at compile time (i.e.
  52 ;;; within EVAL-WHEN :COMPILE-TOPLEVEL) but we need to treat SB!XC as
  53 ;;; synonymous with COMMON-LISP otherwise. This can't be done by making SB!XC a
  54 ;;; nickname of COMMON-LISP, because the reader processes things before
  55 ;;; EVAL-WHEN, so by the time EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the
  56 ;;; distinction it needs would be lost. Instead, we read forms preserving this
  57 ;;; distinction (treating SB!XC as a separate package), and only when we're
  58 ;;; about to process them (for any situation other than
  59 ;;; EVAL-WHEN (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the
  60 ;;; distinction.
  61 #+sb-xc-host
  62 (defun uncross (form)
  63   (let ((;; KLUDGE: We don't currently try to handle circular program
  64          ;; structure, but we do at least detect it and complain about it..
  65          inside? (make-hash-table)))
  66     (labels ((uncross-symbol (symbol)
  67                (let ((old-symbol-package (symbol-package symbol)))
  68                  (if (and old-symbol-package
  69                           (string= (package-name old-symbol-package) "SB-XC"))
  70                      (values (intern (symbol-name symbol) "COMMON-LISP"))
  71                      symbol)))
  72              (rcr (form)
  73                (cond ((symbolp form)
  74                       (uncross-symbol form))
  75                      ((or (numberp form)
  76                           (characterp form)
  77                           (stringp form))
  78                       form)
  79                      (t
  80                       ;; If we reach here, FORM is something with internal
  81                       ;; structure which could include symbols in the SB-XC
  82                       ;; package.
  83                       (when (gethash form inside?)
  84                         (let ((*print-circle* t))
  85                           ;; This code could probably be generalized to work on
  86                           ;; circular structure, but it seems easier just to
  87                           ;; avoid putting any circular structure into the
  88                           ;; bootstrap code.
  89                           (error "circular structure in ~S" form)))
  90                       (setf (gethash form inside?) t)
  91                       (unwind-protect
  92                           (typecase form
  93                             (cons (rcr-cons form))
  94                             ;; Note: This function was originally intended to
  95                             ;; search through structures other than CONS, but
  96                             ;; it got into trouble with LAYOUT-CLASS and
  97                             ;; CLASS-LAYOUT circular structure. After some
  98                             ;; messing around, it turned out that recursing
  99                             ;; through CONS is all that's needed in practice.)
 100                             ;; FIXME: This leaves a lot of stale code here
 101                             ;; (already commented/NILed out) for us to delete.
 102                             #+nil ; only searching through CONS
 103                             (simple-vector (rcr-simple-vector form))
 104                             #+nil ; only searching through CONS
 105                             (structure!object
 106                              (rcr-structure!object form))
 107                             (t
 108                              ;; KLUDGE: I know that UNCROSS is far from
 109                              ;; perfect, but it's good enough to cross-compile
 110                              ;; the current sources, and getting hundreds of
 111                              ;; warnings about individual cases it can't
 112                              ;; recurse through, so the warning here has been
 113                              ;; turned off. Eventually it would be nice either
 114                              ;; to set up a cleaner way of cross-compiling
 115                              ;; which didn't have this problem, or to make
 116                              ;; an industrial-strength version of UNCROSS
 117                              ;; which didn't fail this way. -- WHN 20000201
 118                              #+nil (warn 'uncross-rcr-failure :form form)
 119                              form))
 120                         (remhash form inside?)))))
 121              (rcr-cons (form)
 122                (declare (type cons form))
 123                (let* ((car (car form))
 124                       (rcr-car (rcr car))
 125                       (cdr (cdr form))
 126                       (rcr-cdr (rcr cdr)))
 127                  (if (and (eq rcr-car car) (eq rcr-cdr cdr))
 128                    form
 129                    (cons rcr-car rcr-cdr))))
 130              #+nil ; only searching through CONS in this version
 131              (rcr-simple-vector (form)
 132                (declare (type simple-vector form))
 133                (dotimes (i (length form))
 134                  (let* ((aref (aref form i))
 135                         (rcr-aref (rcr aref)))
 136                    (unless (eq rcr-aref aref)
 137                      (return (map 'vector #'rcr form))))
 138                  form))
 139              #+nil ; only searching through CONS in this version
 140              (rcr-structure!object (form)
 141                (declare (type structure!object form))
 142                ;; Note: We skip the zeroth slot because it's used for LAYOUT,
 143                ;; which shouldn't require any translation and which is
 144                ;; complicated to think about anyway.
 145                (do ((i 1 (1+ i)))
 146                    ((>= i (%instance-length form)) form)
 147                  (let* ((instance-ref (%instance-ref form i))
 148                         (rcr-instance-ref (rcr instance-ref)))
 149                    (unless (eq rcr-instance-ref instance-ref)
 150                      (return (rcr!-structure!object
 151                               (copy-structure form)))))))
 152              #+nil ; only searching through CONS in this version
 153              (rcr!-structure!object (form)
 154                (declare (type structure!object form))
 155                ;; As in RCR-STRUCTURE!OBJECT, we skip the zeroth slot.
 156                (do ((i 1 (1+ i)))
 157                    ((>= i (%instance-length form)))
 158                  (let* ((instance-ref (%instance-ref form i))
 159                         (rcr-instance-ref (rcr instance-ref)))
 160                    ;; (By only calling SETF when strictly necessary,
 161                    ;; we avoid bombing out unnecessarily when the
 162                    ;; I-th slot happens to be read-only.)
 163                    (unless (eq rcr-instance-ref instance-ref)
 164                      (setf (%instance-ref form i)
 165                            rcr-instance-ref))))))
 166       (rcr form))))