src/cold/ansify.lisp

   1 ;;;; patches to work around implementation idiosyncrasies in our
   2 ;;;; cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12 \f
  13 ;;;; CLISP issues
  14
  15 ;;; as explained on #lisp ca. October 2003:
  16 ;;;   <Krystof> chandler: nope, I'm blaming another clisp bug
  17 ;;;   <Krystof> [8]> least-positive-short-float
  18 ;;;   <Krystof> 2.93874s-39
  19 ;;;   <Krystof> [9]> (coerce * 'single-float)
  20 ;;;   <Krystof> 0.0
  21 ;;;   <chandler> aah
  22 ;;;   <mwh> "oops"
  23 ;;;   <Krystof> yep
  24 ;;;   <mwh> tried that on clisp from fink:
  25 ;;;   <mwh> [1]> least-positive-short-float
  26 ;;;   <mwh> 2.93874s-39
  27 ;;;   <mwh> [2]> (coerce * 'single-float)
  28 ;;;   <mwh> *** - floating point underflow
  29 ;;;   <Krystof> yeah
  30 ;;;   <mwh> shall i not try to build sbcl with that?
  31 ;;;   <Krystof> if you turn off underflow traps, then you get 0.0
  32 ;;;   <mwh> well, that makes sense, i guess
  33 ;;;   <Krystof> #+clisp
  34 ;;;   <Krystof> (ext:without-package-lock ("SYSTEM")
  35 ;;;   <Krystof>   (setf system::*inhibit-floating-point-underflow* t))
  36 ;;;   <Krystof> (in src/cold/ansify.lisp)
  37 #+clisp
  38 (ext:without-package-lock ("SYSTEM")
  39   (setf system::*inhibit-floating-point-underflow* t))
  40 \f
  41 ;;;; CMU CL issues
  42
  43 ;;; CMU CL, at least as of 18b, doesn't support PRINT-OBJECT. In
  44 ;;; particular, it refuses to compile :PRINT-OBJECT options to
  45 ;;; DEFSTRUCT, so we need to conditionalize such options on the
  46 ;;; :NO-ANSI-PRINT-OBJECT feature in order to get the code to compile.
  47 ;;; (It also fails to do anything useful with DEFMETHOD PRINT-OBJECT,
  48 ;;; but that doesn't matter much, since it doesn't stop the
  49 ;;; cross-compiler from working.)
  50 #+cmu
  51 (progn
  52   (warn "CMU CL doesn't support the :PRINT-OBJECT option to DEFSTRUCT.~%")
  53   (pushnew :no-ansi-print-object *features*))
  54
  55 ;;; KLUDGE: In CMU CL, at least as of 18b, READ-SEQUENCE is somewhat
  56 ;;; dain-bramaged. Running
  57 ;;;   (defvar *buffer* (make-array (expt 10 6) :element-type 'character))
  58 ;;;   (with-open-file (s "/tmp/long-file.tmp")
  59 ;;;     (/show (read-sequence *buffer* s :start 0 :end 3000))
  60 ;;;     (/show (read-sequence *buffer* s :start 0 :end 15000))
  61 ;;;     (/show (read-sequence *buffer* s :start 0 :end 15000)))
  62 ;;; on a large test file gives
  63 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 3000)=3000
  64 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=1096
  65 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=0
  66 #+cmu
  67 (progn
  68   (warn "CMU CL has a broken implementation of READ-SEQUENCE.")
  69   (pushnew :no-ansi-read-sequence *features*))
  70
  71 ;;; This is apparently quite old, according to
  72 ;;; <http://tunes.org/~nef/logs/lisp/03.10.22>:
  73 ;;;   <dan`b> (error "CMUCL on Alpha can't read floats in the format \"1.0l0\".
  74 ;;;   <dan`b> the warning relates to a random vinary produced from cvs of
  75 ;;;           around feb 2000, the corresponding sources to which I never found
  76 ;;; (But it seems harmless to leave it here forever just in case.)
  77 #+(and cmu alpha)
  78 (unless (ignore-errors (read-from-string "1.0l0"))
  79   (error "CMUCL on Alpha can't read floats in the format \"1.0l0\".  Patch your core file~%~%"))
  80
  81 #+(and cmu sparc)
  82 (ext:set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
  83 \f
  84 ;;;; OpenMCL issues
  85
  86 ;;; This issue in OpenMCL led to some SBCL bug reports ca. late 2003.
  87 #+openmcl
  88 (unless (ignore-errors (funcall (constantly t) 1 2 3))
  89   (error "please find a binary that understands CONSTANTLY to build from"))
  90 \f
  91 ;;;; Self-hosted issues
  92
  93 #+sbcl
  94 (progn
  95   (load "src/cold/muffler.lisp")
  96   ;; Let's just say we never care to see these.
  97   (declaim (sb-ext:muffle-conditions
  98             (satisfies unable-to-optimize-note-p)
  99             (satisfies optional+key-style-warning-p)
 100             sb-ext:code-deletion-note)))
 101 \f
 102 ;;;; general non-ANSI-ness
 103
 104 (in-package :sb-cold)
 105
 106 (defmacro munging-cl-package (&body body)
 107   #-clisp `(progn ,@body)
 108   #+clisp `(ext:without-package-lock ("CL")
 109              ,@body))
 110
 111 ;;; Do the exports of COMMON-LISP conform to the standard? If not, try
 112 ;;; to make them conform. (Of course, ANSI says that bashing symbols
 113 ;;; in the COMMON-LISP package like this is undefined, but then if the
 114 ;;; host Common Lisp were ANSI, we wouldn't be doing this, now would
 115 ;;; we? "One dirty unportable hack deserves another.":-)
 116 (let ((standard-ht (make-hash-table :test 'equal))
 117       (host-ht     (make-hash-table :test 'equal))
 118       (cl         (find-package "COMMON-LISP")))
 119   (do-external-symbols (i cl)
 120     (setf (gethash (symbol-name i) host-ht) t))
 121   (dolist (i (read-from-file "common-lisp-exports.lisp-expr"))
 122     (setf (gethash i standard-ht) t))
 123   (maphash (lambda (key value)
 124              (declare (ignore value))
 125              (unless (gethash key standard-ht)
 126                (warn "removing non-ANSI export from package CL: ~S" key)
 127                (munging-cl-package
 128                 (unexport (intern key cl) cl))))
 129            host-ht)
 130   (maphash (lambda (key value)
 131              (declare (ignore value))
 132              (unless (gethash key host-ht)
 133                (warn "adding required-by-ANSI export to package CL: ~S" key)
 134                (munging-cl-package
 135                 (export (intern key cl) cl)))
 136
 137              ;; FIXME: My righteous indignation below was misplaced. ANSI sez
 138              ;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for
 139              ;; COMMON-LISP things to have their home packages elsewhere.
 140              ;; For now, the hack below works, but it's not good to rely
 141              ;; on this nonstandardness. Ergo, I should fix things so that even
 142              ;; when the cross-compilation host COMMON-LISP package has
 143              ;; symbols with home packages elsewhere, genesis dumps out
 144              ;; the correct stuff. (For each symbol dumped, check whether it's
 145              ;; exported from COMMON-LISP, and if so, dump it as though its
 146              ;; home package is COMMON-LISP regardless of whether it actually
 147              ;; is. I think..)
 148              ;;
 149              ;; X CMU CL, at least the Debian versions ca. 2.4.9 that I'm
 150              ;; X using as I write this, plays a sneaky trick on us by
 151              ;; X putting DEBUG and FLOATING-POINT-INEXACT in the
 152              ;; X EXTENSIONS package, then IMPORTing them into
 153              ;; X COMMON-LISP, then reEXPORTing them from COMMON-LISP.
 154              ;; X This leaves their home packages bogusly set to
 155              ;; X EXTENSIONS, which confuses genesis into thinking that
 156              ;; X the CMU CL EXTENSIONS package has to be dumped into the
 157              ;; X target SBCL. (perhaps a last-ditch survival strategy
 158              ;; X for the CMU CL "nooo! don't bootstrap from scratch!"
 159              ;; X meme?) As far as I can see, there's no even slightly
 160              ;; X portable way to undo the damage, so we'll play the "one
 161              ;; X dirty unportable hack deserves another" game, only even
 162              ;; X dirtierly and more unportably than before..
 163              #+cmu
 164              (let ((symbol (intern key cl)))
 165                (unless (eq (symbol-package symbol) cl)
 166                  (warn "using low-level hack to move ~S from ~S to ~S"
 167                        symbol
 168                        (symbol-package symbol)
 169                        cl)
 170                  (kernel:%set-symbol-package symbol cl))))
 171            standard-ht))