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)
8 ;;;; This software is part of the SBCL system. See the README file for
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.
21 ;;; In the target system's compiler, uncrossing is just identity.
24 #!-sb-fluid (declaim (inline uncross))
25 (defun uncross (x) x))
26 ;;; In the cross-compiler, uncrossing is slightly less trivial.
28 ;;; This condition is only a STYLE-WARNING because generally it isn't important
29 ;;; in practice to recurse through anything except CONSes anyway.
32 (define-condition uncross-rcr-failure (style-warning)
33 ((form :initarg :form :reader uncross-rcr-failure-form))
34 (:report (lambda (c s)
36 "UNCROSS couldn't recurse through ~S~%~
37 (which is OK as long as there are no SB-XC symbols ~
39 (uncross-rcr-failure-form c)))))
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.)
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
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"))
74 (uncross-symbol form))
80 ;; If we reach here, FORM is something with internal
81 ;; structure which could include symbols in the SB-XC
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
89 (error "circular structure in ~S" form)))
90 (setf (gethash form inside?) t)
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
106 (rcr-structure!object form))
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)
120 (remhash form inside?)))))
122 (declare (type cons form))
123 (let* ((car (car form))
127 (if (and (eq rcr-car car) (eq rcr-cdr cdr))
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))))
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.
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.
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))))))