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 ;;; In the target system's compiler, uncrossing is just identity.
  20 #-sb-xc-host
  21 (progn
  22   #!-sb-fluid (declaim (inline uncross))
  23   (defun uncross (x) x))
  24 ;;; In the cross-compiler, uncrossing is slightly less trivial.
  25
  26 ;;; This condition is only a STYLE-WARNING because generally it isn't important
  27 ;;; in practice to recurse through anything except CONSes anyway.
  28 #|
  29 #!+sb-show
  30 (define-condition uncross-rcr-failure (style-warning)
  31   ((form :initarg :form :reader uncross-rcr-failure-form))
  32   (:report (lambda (c s)
  33              (format s
  34                      "UNCROSS couldn't recurse through ~S~%~
  35                       (which is OK as long as there are no SB-XC symbols ~
  36                       down there)"
  37                      (uncross-rcr-failure-form c)))))
  38 |#
  39
  40 ;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed
  41 ;;; in the host Common Lisp, not the target. A certain amount of
  42 ;;; dancing around is required in order for this to work more or less
  43 ;;; correctly. (Fortunately, more or less correctly is good enough --
  44 ;;; it only needs to work on the EVAL-WHEN expressions found in the
  45 ;;; SBCL sources themselves, and we can exercise self-control to keep
  46 ;;; them from including anything which too strongly resembles a
  47 ;;; language lawyer's test case.)
  48 ;;;
  49 ;;; In order to make the dancing happen, we need to make a distinction
  50 ;;; between SB!XC and COMMON-LISP when we're executing a form at
  51 ;;; compile time (i.e. within EVAL-WHEN :COMPILE-TOPLEVEL) but we need
  52 ;;; to treat SB!XC as synonymous with COMMON-LISP otherwise. This
  53 ;;; can't be done by making SB!XC a nickname of COMMON-LISP, because
  54 ;;; the reader processes things before EVAL-WHEN, so by the time
  55 ;;; EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the distinction it needs
  56 ;;; would be lost. Instead, we read forms preserving this distinction
  57 ;;; (treating SB!XC as a separate package), and only when we're about
  58 ;;; to process them (for any situation other than EVAL-WHEN
  59 ;;; (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the
  60 ;;; distinction.
  61 #+sb-xc-host
  62 (let ((;; KLUDGE: We don't currently try to handle circular program
  63        ;; structure, but we do at least detect it and complain about
  64        ;; it..
  65        inside? (make-hash-table)))
  66   (defun uncross (form)
  67     (labels ((uncross-symbol (symbol)
  68                (let ((old-symbol-package (symbol-package symbol)))
  69                  (if (and old-symbol-package
  70                           (string= (package-name old-symbol-package) "SB-XC"))
  71                      (values (intern (symbol-name symbol) "COMMON-LISP"))
  72                      symbol)))
  73              (rcr (form) ; recursive part
  74                (cond ((symbolp form)
  75                       (uncross-symbol form))
  76                      ((or (numberp form)
  77                           (characterp form)
  78                           (stringp form))
  79                       form)
  80                      (t
  81                       ;; If we reach here, FORM is something with
  82                       ;; internal structure which could include
  83                       ;; symbols in the SB-XC package.
  84                       (when (gethash form inside?)
  85                         (let ((*print-circle* t))
  86                           ;; This code could probably be generalized
  87                           ;; to work on circular structure, but it
  88                           ;; seems easier just to avoid putting any
  89                           ;; circular structure into the bootstrap
  90                           ;; code.
  91                           (error "circular structure in ~S" form)))
  92                       (setf (gethash form inside?) t)
  93                       (unwind-protect
  94                           (typecase form
  95                             (cons (rcr-cons form))
  96                             (t
  97                              ;; KLUDGE: There are other types
  98                              ;; (especially (ARRAY T) and
  99                              ;; STRUCTURE-OBJECT, but also HASH-TABLE
 100                              ;; and perhaps others) which could hold
 101                              ;; symbols. In principle we should handle
 102                              ;; those types as well. Failing that, we
 103                              ;; could give warnings for them. However,
 104                              ;; the current system works for
 105                              ;; bootstrapping in practice (because we
 106                              ;; don't use those constructs that way)
 107                              ;; and the warnings more annoying than
 108                              ;; useful, so I simply turned the
 109                              ;; warnings off. -- WHN 20001105
 110                              #+nil (warn 'uncross-rcr-failure :form form)
 111                              form))
 112                         (remhash form inside?)))))
 113              (rcr-cons (form)
 114                (declare (type cons form))
 115                (let* ((car (car form))
 116                       (rcr-car (rcr car))
 117                       (cdr (cdr form))
 118                       (rcr-cdr (rcr cdr)))
 119                  (if (and (eq rcr-car car) (eq rcr-cdr cdr))
 120                    form
 121                    (cons rcr-car rcr-cdr)))))
 122       (clrhash inside?)
 123       (rcr form))))
 124
 125 (defmacro !uncross-format-control (string)
 126   #+sb-xc-host string
 127   #-sb-xc-host
 128   (let ((p 0))
 129     (loop (setq p (search "~/sb!" string :start2 p))
 130           (unless p
 131             (return string))
 132           (setf (char string (incf p 4)) #\-))))