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
)
32 `(macrolet ((allow-with-interrupts (&body body
)
34 (with-local-interrupts (&body body
)
38 (defmacro with-locked-hash-table
((table) &body body
)
39 (declare (ignore table
))
42 (defmacro defglobal
(name value
&rest doc
)
43 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
50 ;;; The GENESIS function works with fasl code which would, in the
51 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
52 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
54 (deftype ansi-stream
() 'stream
)
56 (deftype sb
!kernel
:instance
()
57 '(or condition structure-object standard-object
))
58 (deftype sb
!kernel
:funcallable-instance
()
59 (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
61 ;;; In the target SBCL, the INSTANCE type refers to a base
62 ;;; implementation for compound types with lowtag
63 ;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
64 ;;; concept portably, but we can get essentially the same effect by
65 ;;; testing for any of the standard types which would, in the target
66 ;;; SBCL, be derived from INSTANCE:
68 (typep x
'(or condition structure-object standard-object
)))
70 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
72 (defun funcallable-instance-p (x)
73 (if (typep x
'generic-function
)
74 ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
75 ;; generic functions, so any case which tests for this might in
76 ;; fact be trying to test for generic functions. My (WHN 19990313)
77 ;; expectation is that this case won't arise in the
78 ;; cross-compiler, but if it does, it deserves a little thought,
79 ;; rather than reflexively returning NIL.
80 (error "not clear how to handle GENERIC-FUNCTION")
83 ;;; This seems to be the portable Common Lisp type test which
84 ;;; corresponds to the effect of the target SBCL implementation test...
85 (defun sb!kernel
:array-header-p
(x)
87 (or (not (typep x
'simple-array
))
88 (/= (array-rank x
) 1))))
90 ;;; GENESIS needs these at cross-compile time. The target
91 ;;; implementation of these is reasonably efficient by virtue of its
92 ;;; ability to peek into the internals of the package implementation;
93 ;;; this reimplementation is portable but slow.
94 (defun package-internal-symbol-count (package)
96 (declare (type fixnum result
))
97 (do-symbols (i package
)
98 ;; KLUDGE: The ANSI Common Lisp specification warns that
99 ;; DO-SYMBOLS may execute its body more than once for symbols
100 ;; that are inherited from multiple packages, and we currently
101 ;; make no attempt to correct for that here. (The current uses
102 ;; of this function at cross-compile time don't really care if
103 ;; the count is a little too high.) -- WHN 19990826
104 (multiple-value-bind (symbol status
)
105 (find-symbol (symbol-name i
) package
)
106 (declare (ignore symbol
))
107 (when (member status
'(:internal
:inherited
))
110 (defun package-external-symbol-count (package)
112 (declare (type fixnum result
))
113 (do-external-symbols (i package
)
114 (declare (ignorable i
))
118 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
119 ;;; implemented in terms of it. This increases efficiency by letting
120 ;;; us reuse a fixed-size buffer; the alternative would be
121 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
122 ;;; the host Lisp, this is only used at cold load time, and we don't
123 ;;; care as much about efficiency, so it's fine to treat the host
124 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
125 (defun intern* (nameoid length package
)
126 (intern (replace (make-string length
) nameoid
:end2 length
) package
))
128 ;;; In the target Lisp this is implemented by reading a fixed slot in
129 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
130 ;;; met (more slowly, and with the extra property of repeatability
131 ;;; between runs) by just calling SXHASH.
132 (defun symbol-hash (symbol)
133 (declare (type symbol symbol
))
136 (defvar sb
!xc
:*gensym-counter
* 0)
138 (defun sb!xc
:gensym
(&optional
(thing "G"))
139 (declare (type string thing
))
140 (let ((n sb
!xc
:*gensym-counter
*))
142 (make-symbol (concatenate 'string thing
(write-to-string n
:base
10 :radix nil
:pretty nil
)))
143 (incf sb
!xc
:*gensym-counter
*))))
145 ;;; These functions are needed for constant-folding.
146 (defun sb!kernel
:simple-array-nil-p
(object)
147 (when (typep object
'array
)
148 (assert (not (eq (array-element-type object
) nil
))))
151 (defun sb!kernel
:%negate
(number)
154 (defun sb!kernel
:%single-float
(number)
155 (coerce number
'single-float
))
157 (defun sb!kernel
:%double-float
(number)
158 (coerce number
'double-float
))
160 (defun sb!kernel
:%ldb
(size posn integer
)
161 (ldb (byte size posn
) integer
))
163 (defun sb!kernel
:%dpb
(newbyte size posn integer
)
164 (dpb newbyte
(byte size posn
) integer
))
166 (defun sb!kernel
:%with-array-data
(array start end
)
167 (assert (typep array
'(simple-array * (*))))
168 (values array start end
0))
170 (defun sb!kernel
:%with-array-data
/fp
(array start end
)
171 (assert (typep array
'(simple-array * (*))))
172 (values array start end
0))
174 (defun sb!kernel
:signed-byte-32-p
(number)
175 (typep number
'(signed-byte 32)))
177 ;;; package locking nops for the cross-compiler
179 (defmacro without-package-locks
(&body body
)
182 (defmacro with-single-package-locked-error
((&optional kind thing
&rest format
)
184 (declare (ignore kind thing format
))
187 (defun program-assert-symbol-home-package-unlocked (context symbol control
)
188 (declare (ignore context control
))
191 (defun assert-package-unlocked (package &optional control
&rest args
)
192 (declare (ignore control args
))
195 (defun assert-symbol-home-package-unlocked (name format
&key continuablep
)
196 (declare (ignore format continuablep
))
199 (declaim (declaration enable-package-locks disable-package-locks
))