- (if (and old-symbol-package
- (string= (package-name old-symbol-package) "SB-XC"))
- (values (intern (symbol-name symbol) "COMMON-LISP"))
- symbol)))
- (rcr (form)
- (cond ((symbolp form)
- (uncross-symbol form))
- ((or (numberp form)
- (characterp form)
- (stringp form))
- form)
- (t
- ;; 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.
- (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
- #+nil (warn 'uncross-rcr-failure :form form)
- form))
- (remhash form inside?)))))
- (rcr-cons (form)
- (declare (type cons form))
- (let* ((car (car form))
- (rcr-car (rcr car))
- (cdr (cdr form))
- (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))))))
+ (if (and old-symbol-package
+ (string= (package-name old-symbol-package) "SB-XC"))
+ (values (intern (symbol-name symbol) "COMMON-LISP"))
+ symbol)))
+ (rcr (form) ; recursive part
+ (cond ((symbolp form)
+ (uncross-symbol form))
+ ((or (numberp form)
+ (characterp form)
+ (stringp form))
+ form)
+ (t
+ ;; 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.
+ (error "circular structure in ~S" form)))
+ (setf (gethash form inside?) t)
+ (unwind-protect
+ (typecase form
+ (cons (rcr-cons form))
+ (t
+ ;; 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-cons (form)
+ (declare (type cons form))
+ (let* ((car (car form))
+ (rcr-car (rcr car))
+ (cdr (cdr form))
+ (rcr-cdr (rcr cdr)))
+ (if (and (eq rcr-car car) (eq rcr-cdr cdr))
+ form
+ (cons rcr-car rcr-cdr)))))
+ (clrhash inside?)