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 #+clisp
  16 (ext:without-package-lock ("SYSTEM")
  17   (setf system::*inhibit-floating-point-underflow* t))
  18 \f
  19 ;;;; CMU CL issues
  20
  21 ;;; CMU CL, at least as of 18b, doesn't support PRINT-OBJECT. In
  22 ;;; particular, it refuses to compile :PRINT-OBJECT options to
  23 ;;; DEFSTRUCT, so we need to conditionalize such options on the
  24 ;;; :NO-ANSI-PRINT-OBJECT feature in order to get the code to compile.
  25 ;;; (It also fails to do anything useful with DEFMETHOD PRINT-OBJECT,
  26 ;;; but that doesn't matter much, since it doesn't stop the
  27 ;;; cross-compiler from working.)
  28 #+cmu
  29 (progn
  30   (warn "CMU CL doesn't support the :PRINT-OBJECT option to DEFSTRUCT.~%")
  31   (pushnew :no-ansi-print-object *features*))
  32
  33 ;;; KLUDGE: In CMU CL, at least as of 18b, READ-SEQUENCE is somewhat
  34 ;;; dain-bramaged. Running
  35 ;;;   (defvar *buffer* (make-array (expt 10 6) :element-type 'character))
  36 ;;;   (with-open-file (s "/tmp/long-file.tmp")
  37 ;;;     (/show (read-sequence *buffer* s :start 0 :end 3000))
  38 ;;;     (/show (read-sequence *buffer* s :start 0 :end 15000))
  39 ;;;     (/show (read-sequence *buffer* s :start 0 :end 15000)))
  40 ;;; on a large test file gives
  41 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 3000)=3000
  42 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=1096
  43 ;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=0
  44 #+cmu
  45 (progn
  46   (warn "CMU CL has a broken implementation of READ-SEQUENCE.")
  47   (pushnew :no-ansi-read-sequence *features*))
  48
  49 #+(and cmu alpha)
  50 (unless (ignore-errors (read-from-string "1.0l0"))
  51   (error "CMUCL on Alpha can't read floats in the format \"1.0l0\".  Patch your core file~%~%"))
  52
  53 #+(and cmu sparc)
  54 (ext:set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
  55 \f
  56 ;;;; OpenMCL issues
  57 #+openmcl
  58 (unless (ignore-errors (funcall (constantly t) 1 2 3))
  59   (error "please find a binary that understands CONSTANTLY to build from"))
  60
  61 \f
  62 ;;;; general non-ANSI-ness
  63
  64 (in-package :sb-cold)
  65
  66 (defmacro munging-cl-package (&body body)
  67   #-clisp `(progn ,@body)
  68   #+clisp `(ext:without-package-lock ("CL")
  69              ,@body))
  70
  71 ;;; Do the exports of COMMON-LISP conform to the standard? If not, try
  72 ;;; to make them conform. (Of course, ANSI says that bashing symbols
  73 ;;; in the COMMON-LISP package like this is undefined, but then if the
  74 ;;; host Common Lisp were ANSI, we wouldn't be doing this, now would
  75 ;;; we? "One dirty unportable hack deserves another.":-)
  76 (let ((standard-ht (make-hash-table :test 'equal))
  77       (host-ht     (make-hash-table :test 'equal))
  78       (cl         (find-package "COMMON-LISP")))
  79   (do-external-symbols (i cl)
  80     (setf (gethash (symbol-name i) host-ht) t))
  81   (dolist (i (read-from-file "common-lisp-exports.lisp-expr"))
  82     (setf (gethash i standard-ht) t))
  83   (maphash (lambda (key value)
  84              (declare (ignore value))
  85              (unless (gethash key standard-ht)
  86                (warn "removing non-ANSI export from package CL: ~S" key)
  87                (munging-cl-package
  88                 (unexport (intern key cl) cl))))
  89            host-ht)
  90   (maphash (lambda (key value)
  91              (declare (ignore value))
  92              (unless (gethash key host-ht)
  93                (warn "adding required-by-ANSI export to package CL: ~S" key)
  94                (munging-cl-package
  95                 (export (intern key cl) cl)))
  96
  97              ;; FIXME: My righteous indignation below was misplaced. ANSI sez
  98              ;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for
  99              ;; COMMON-LISP things to have their home packages elsewhere.
 100              ;; For now, the hack below works, but it's not good to rely
 101              ;; on this nonstandardness. Ergo, I should fix things so that even
 102              ;; when the cross-compilation host COMMON-LISP package has
 103              ;; symbols with home packages elsewhere, genesis dumps out
 104              ;; the correct stuff. (For each symbol dumped, check whether it's
 105              ;; exported from COMMON-LISP, and if so, dump it as though its
 106              ;; home package is COMMON-LISP regardless of whether it actually
 107              ;; is. I think..)
 108              ;;
 109              ;; X CMU CL, at least the Debian versions ca. 2.4.9 that I'm
 110              ;; X using as I write this, plays a sneaky trick on us by
 111              ;; X putting DEBUG and FLOATING-POINT-INEXACT in the
 112              ;; X EXTENSIONS package, then IMPORTing them into
 113              ;; X COMMON-LISP, then reEXPORTing them from COMMON-LISP.
 114              ;; X This leaves their home packages bogusly set to
 115              ;; X EXTENSIONS, which confuses genesis into thinking that
 116              ;; X the CMU CL EXTENSIONS package has to be dumped into the
 117              ;; X target SBCL. (perhaps a last-ditch survival strategy
 118              ;; X for the CMU CL "nooo! don't bootstrap from scratch!"
 119              ;; X meme?) As far as I can see, there's no even slightly
 120              ;; X portable way to undo the damage, so we'll play the "one
 121              ;; X dirty unportable hack deserves another" game, only even
 122              ;; X dirtierly and more unportably than before..
 123              #+cmu
 124              (let ((symbol (intern key cl)))
 125                (unless (eq (symbol-package symbol) cl)
 126                  (warn "using low-level hack to move ~S from ~S to ~S"
 127                        symbol
 128                        (symbol-package symbol)
 129                        cl)
 130                  (kernel:%set-symbol-package symbol cl))))
 131            standard-ht))