1 ;;;; cross-compile-time-only replacements for miscellaneous unportable
4 ;;;; This software is part of the SBCL system. See the README file for
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.
13 (in-package "SB!IMPL")
15 ;;; In correct code, TRULY-THE has only a performance impact and can
16 ;;; be safely degraded to ordinary THE.
17 (defmacro truly-the (type expr)
20 ;;; MAYBE-INLINE and FREEZE-TYPE declarations can be safely ignored
21 ;;; (possibly at some cost in efficiency).
22 (declaim (declaration freeze-type maybe-inline))
24 ;;; INHIBIT-WARNINGS declarations can be safely ignored (although we
25 ;;; may then have to wade through some irrelevant warnings).
26 (declaim (declaration inhibit-warnings))
28 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
29 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
30 ;;; have a single thread of control.
31 (defmacro without-interrupts (&rest forms)
34 ;;; The GENESIS function works with fasl code which would, in the
35 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
36 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
38 (deftype ansi-stream () 'stream)
40 ;;; In the target SBCL, the INSTANCE type refers to a base
41 ;;; implementation for compound types. There's no way to express
42 ;;; exactly that concept portably, but we can get essentially the same
43 ;;; effect by testing for any of the standard types which would, in
44 ;;; the target SBCL, be derived from INSTANCE:
45 (deftype sb!kernel:instance ()
46 '(or condition standard-object structure-object))
48 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
50 (defun funcallable-instance-p (x)
51 (if (typep x 'generic-function)
52 ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
53 ;; generic functions, so any case which tests for this might in
54 ;; fact be trying to test for generic functions. My (WHN 19990313)
55 ;; expectation is that this case won't arise in the
56 ;; cross-compiler, but if it does, it deserves a little thought,
57 ;; rather than reflexively returning NIL.
58 (error "not clear how to handle GENERIC-FUNCTION")
61 ;;; This seems to be the portable Common Lisp type test which
62 ;;; corresponds to the effect of the target SBCL implementation test...
63 (defun sb!kernel:array-header-p (x)
65 (or (not (typep x 'simple-array))
66 (/= (array-rank x) 1))))
68 ;;; GENESIS needs these at cross-compile time. The target
69 ;;; implementation of these is reasonably efficient by virtue of its
70 ;;; ability to peek into the internals of the package implementation;
71 ;;; this reimplementation is portable but slow.
72 (defun package-internal-symbol-count (package)
74 (declare (type fixnum result))
75 (do-symbols (i package)
76 ;; KLUDGE: The ANSI Common Lisp specification warns that
77 ;; DO-SYMBOLS may execute its body more than once for symbols
78 ;; that are inherited from multiple packages, and we currently
79 ;; make no attempt to correct for that here. (The current uses
80 ;; of this function at cross-compile time don't really care if
81 ;; the count is a little too high.) -- WHN 19990826
82 (multiple-value-bind (symbol status)
83 (find-symbol (symbol-name i) package)
84 (declare (ignore symbol))
85 (when (member status '(:internal :inherited))
88 (defun package-external-symbol-count (package)
90 (declare (type fixnum result))
91 (do-external-symbols (i package)
92 (declare (ignorable i))
96 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
97 ;;; implemented in terms of it. This increases efficiency by letting
98 ;;; us reuse a fixed-size buffer; the alternative would be
99 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
100 ;;; the host Lisp, this is only used at cold load time, and we don't
101 ;;; care as much about efficiency, so it's fine to treat the host
102 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
103 (defun intern* (nameoid length package)
104 (intern (replace (make-string length) nameoid :end2 length) package))
106 ;;; In the target Lisp this is implemented by reading a fixed slot in
107 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
108 ;;; met (more slowly, and with the extra property of repeatability
109 ;;; between runs) by just calling SXHASH.
110 (defun symbol-hash (symbol)
111 (declare (type symbol symbol))
114 ;;; These functions are needed for constant-folding.
115 (defun sb!kernel:simple-array-nil-p (object)
116 (when (typep object 'array)
117 (assert (not (eq (array-element-type object) nil))))
120 (defun sb!kernel:%negate (number)
123 (defun sb!kernel:%single-float (number)
124 (coerce number 'single-float))
126 (defun sb!kernel:%double-float (number)
127 (coerce number 'double-float))
129 (defun sb!kernel:%ldb (size posn integer)
130 (ldb (byte size posn) integer))
132 (defun sb!kernel:%dpb (newbyte size posn integer)
133 (dpb newbyte (byte size posn) integer))
135 (defun sb!kernel:%with-array-data (array start end)
136 (assert (typep array '(simple-array * (*))))
137 (values array start end 0))
139 (defun sb!kernel:signed-byte-32-p (number)
140 (typep number '(signed-byte 32)))
142 ;;; package locking nops for the cross-compiler
144 (defmacro without-package-locks (&body body)
147 (defmacro with-single-package-locked-error ((&optional kind thing &rest format)
149 (declare (ignore kind thing format))
152 (defun compiler-assert-symbol-home-package-unlocked (symbol control)
153 (declare (ignore control))
156 (defun assert-package-unlocked (package &optional control &rest args)
157 (declare (ignore control args))
160 (defun assert-symbol-home-package-unlocked (name format &key continuablep)
161 (declare (ignore format continuablep))
164 (declaim (declaration enable-package-locks disable-package-locks))