src/code/cross-misc.lisp

   1 ;;;; cross-compile-time-only replacements for miscellaneous unportable
   2 ;;;; stuff
   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
  13 (in-package "SB!IMPL")
  14
  15 ;;; Forward declarations
  16
  17 (declaim (ftype (function (t &rest t) nil) sb!c::compiler-error)
  18          (ftype (function (t &rest t) (values &optional))
  19                 sb!c::compiler-warn sb!c::compiler-style-warn)
  20          (ftype function
  21                 bad-type
  22                 parse-body
  23                 sane-package
  24                 style-warn)
  25          (ftype function
  26                 sb!fasl::allocate-struct
  27                 sb!fasl::target-push
  28                 sb!fasl::cold-cons
  29                 sb!fasl::cold-intern
  30                 sb!fasl::cold-svset
  31                 sb!fasl::cold-symbol-value
  32                 sb!fasl::write-slots))
  33
  34 ;;; In correct code, TRULY-THE has only a performance impact and can
  35 ;;; be safely degraded to ordinary THE.
  36 (defmacro truly-the (type expr)
  37   `(the ,type ,expr))
  38
  39 (defmacro named-lambda (name args &body body)
  40   (declare (ignore name))
  41   `#'(lambda ,args ,@body))
  42
  43 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
  44 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
  45 ;;; have a single thread of control.
  46 (defmacro without-interrupts (&rest forms)
  47   `(macrolet ((allow-with-interrupts (&body body)
  48                 `(progn ,@body))
  49               (with-local-interrupts (&body body)
  50                 `(progn ,@body)))
  51      ,@forms))
  52
  53 (defmacro with-locked-hash-table ((table) &body body)
  54   (declare (ignore table))
  55   `(progn ,@body))
  56
  57 (defmacro with-locked-system-table ((table) &body body)
  58   (declare (ignore table))
  59   `(progn ,@body))
  60
  61 (defmacro defglobal (name value &rest doc)
  62   `(eval-when (:compile-toplevel :load-toplevel :execute)
  63      (defparameter ,name
  64        (if (boundp ',name)
  65            (symbol-value ',name)
  66            ,value)
  67        ,@doc)))
  68
  69 ;;; The GENESIS function works with fasl code which would, in the
  70 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
  71 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
  72 ;;; CL:STREAM.
  73 (deftype ansi-stream () 'stream)
  74
  75 (deftype instance ()
  76   '(or condition structure-object standard-object))
  77 (deftype funcallable-instance ()
  78   (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
  79
  80 ;;; In the target SBCL, the INSTANCE type refers to a base
  81 ;;; implementation for compound types with lowtag
  82 ;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
  83 ;;; concept portably, but we can get essentially the same effect by
  84 ;;; testing for any of the standard types which would, in the target
  85 ;;; SBCL, be derived from INSTANCE:
  86 (defun %instancep (x)
  87   (typep x '(or condition structure-object standard-object)))
  88
  89 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
  90 ;;; host Common Lisp.
  91 (defun funcallable-instance-p (x)
  92   (if (typep x 'generic-function)
  93     ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
  94     ;; generic functions, so any case which tests for this might in
  95     ;; fact be trying to test for generic functions. My (WHN 19990313)
  96     ;; expectation is that this case won't arise in the
  97     ;; cross-compiler, but if it does, it deserves a little thought,
  98     ;; rather than reflexively returning NIL.
  99     (error "not clear how to handle GENERIC-FUNCTION")
 100     nil))
 101
 102 ;;; This seems to be the portable Common Lisp type test which
 103 ;;; corresponds to the effect of the target SBCL implementation test...
 104 (defun array-header-p (x)
 105   (and (typep x 'array)
 106        (or (not (typep x 'simple-array))
 107            (/= (array-rank x) 1))))
 108
 109 (defvar sb!xc:*gensym-counter* 0)
 110
 111 (defun sb!xc:gensym (&optional (thing "G"))
 112   (declare (type string thing))
 113   (let ((n sb!xc:*gensym-counter*))
 114     (prog1
 115         (make-symbol (concatenate 'string thing (write-to-string n :base 10 :radix nil :pretty nil)))
 116       (incf sb!xc:*gensym-counter*))))
 117
 118 ;;; These functions are needed for constant-folding.
 119 (defun simple-array-nil-p (object)
 120   (when (typep object 'array)
 121     (assert (not (eq (array-element-type object) nil))))
 122   nil)
 123
 124 (defun %negate (number)
 125   (- number))
 126
 127 (defun %single-float (number)
 128   (coerce number 'single-float))
 129
 130 (defun %double-float (number)
 131   (coerce number 'double-float))
 132
 133 (defun %ldb (size posn integer)
 134   (ldb (byte size posn) integer))
 135
 136 (defun %dpb (newbyte size posn integer)
 137   (dpb newbyte (byte size posn) integer))
 138
 139 (defun %with-array-data (array start end)
 140   (assert (typep array '(simple-array * (*))))
 141   (values array start end 0))
 142
 143 (defun %with-array-data/fp (array start end)
 144   (assert (typep array '(simple-array * (*))))
 145   (values array start end 0))
 146
 147 (defun signed-byte-32-p (number)
 148   (typep number '(signed-byte 32)))
 149
 150 ;;; package locking nops for the cross-compiler
 151
 152 (defmacro without-package-locks (&body body)
 153   `(progn ,@body))
 154
 155 (defmacro with-single-package-locked-error ((&optional kind thing &rest format)
 156                                             &body body)
 157   ;; FIXME: perhaps this should touch THING to make it used?
 158   (declare (ignore kind thing format))
 159   `(progn ,@body))
 160
 161 (defun program-assert-symbol-home-package-unlocked (context symbol control)
 162   (declare (ignore context control))
 163   symbol)
 164
 165 (defun assert-package-unlocked (package &optional format-control
 166                                 &rest format-arguments)
 167   (declare (ignore format-control format-arguments))
 168   package)
 169
 170 (defun assert-symbol-home-package-unlocked (name &optional format-control
 171                                             &rest format-arguments)
 172   (declare (ignore format-control format-arguments))
 173   name)
 174
 175 (declaim (declaration enable-package-locks disable-package-locks))
 176
 177 ;;; printing structures
 178
 179 (defun default-structure-print (structure stream depth)
 180   (declare (ignore depth))
 181   (write structure :stream stream :circle t))