X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funcross.lisp;h=cabbc0683e8aaa2ae83d62cfa118c11d5da49c1f;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=8043676a984437a2cb55b9f009af5cbb03dac07c;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/uncross.lisp b/src/code/uncross.lisp index 8043676..cabbc06 100644 --- a/src/code/uncross.lisp +++ b/src/code/uncross.lisp @@ -30,135 +30,94 @@ (define-condition uncross-rcr-failure (style-warning) ((form :initarg :form :reader uncross-rcr-failure-form)) (:report (lambda (c s) - (format s - "UNCROSS couldn't recurse through ~S~%~ - (which is OK as long as there are no SB-XC symbols ~ - down there)" - (uncross-rcr-failure-form c))))) + (format s + "UNCROSS couldn't recurse through ~S~%~ + (which is OK as long as there are no SB-XC symbols ~ + down there)" + (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.. - inside? (make-hash-table))) +(let ((;; KLUDGE: We don't currently try to handle circular program + ;; structure, but we do at least detect it and complain about + ;; it.. + inside? (make-hash-table))) + (defun uncross (form) (labels ((uncross-symbol (symbol) (let ((old-symbol-package (symbol-package symbol))) - (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?) (rcr form))))