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 ;;; Forward declarations
17 ;;; In correct code, TRULY-THE has only a performance impact and can
18 ;;; be safely degraded to ordinary THE.
19 (defmacro truly-the
(type expr
)
22 (defmacro named-lambda
(name args
&body body
)
23 (declare (ignore name
))
24 `#'(lambda ,args
,@body
))
26 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
27 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
28 ;;; have a single thread of control.
29 (defmacro without-interrupts
(&rest forms
)
30 `(macrolet ((allow-with-interrupts (&body body
)
32 (with-local-interrupts (&body body
)
36 (defmacro with-locked-hash-table
((table) &body body
)
37 (declare (ignore table
))
40 (defmacro with-locked-system-table
((table) &body body
)
41 (declare (ignore table
))
44 (defmacro defglobal
(name value
&rest doc
)
45 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
52 ;;; The GENESIS function works with fasl code which would, in the
53 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
54 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
56 (deftype ansi-stream
() 'stream
)
59 '(or condition structure-object standard-object
))
60 (deftype funcallable-instance
()
61 (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
63 ;; The definition of TYPE-SPECIFIER for the target appears in the file
64 ;; 'deftypes-for-target' - it allows CLASSes and CLASOIDs as specifiers.
65 ;; Instances are never used as specifiers when building SBCL,
66 ;; handily avoiding a problem in figuring out an order in which to
67 ;; define the types CLASS, CLASSOID, and TYPE-SPECIFIER.
68 (deftype type-specifier
() '(or list symbol
))
70 ;;; In the target SBCL, the INSTANCE type refers to a base
71 ;;; implementation for compound types with lowtag
72 ;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
73 ;;; concept portably, but we can get essentially the same effect by
74 ;;; testing for any of the standard types which would, in the target
75 ;;; SBCL, be derived from INSTANCE:
77 (typep x
'(or condition structure-object standard-object
)))
79 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
81 (defun funcallable-instance-p (x)
82 (if (typep x
'generic-function
)
83 ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
84 ;; generic functions, so any case which tests for this might in
85 ;; fact be trying to test for generic functions. My (WHN 19990313)
86 ;; expectation is that this case won't arise in the
87 ;; cross-compiler, but if it does, it deserves a little thought,
88 ;; rather than reflexively returning NIL.
89 (error "not clear how to handle GENERIC-FUNCTION")
92 ;;; This seems to be the portable Common Lisp type test which
93 ;;; corresponds to the effect of the target SBCL implementation test...
94 (defun array-header-p (x)
96 (or (not (typep x
'simple-array
))
97 (/= (array-rank x
) 1))))
99 (defvar sb
!xc
:*gensym-counter
* 0)
101 (defun sb!xc
:gensym
(&optional
(thing "G"))
102 (declare (type string thing
))
103 (let ((n sb
!xc
:*gensym-counter
*))
105 (make-symbol (concatenate 'string thing
(write-to-string n
:base
10 :radix nil
:pretty nil
)))
106 (incf sb
!xc
:*gensym-counter
*))))
108 ;;; These functions are needed for constant-folding.
109 (defun simple-array-nil-p (object)
110 (when (typep object
'array
)
111 (assert (not (eq (array-element-type object
) nil
))))
114 (defun %negate
(number)
117 (defun %single-float
(number)
118 (coerce number
'single-float
))
120 (defun %double-float
(number)
121 (coerce number
'double-float
))
123 (defun %ldb
(size posn integer
)
124 (ldb (byte size posn
) integer
))
126 (defun %dpb
(newbyte size posn integer
)
127 (dpb newbyte
(byte size posn
) integer
))
129 (defun %with-array-data
(array start end
)
130 (assert (typep array
'(simple-array * (*))))
131 (values array start end
0))
133 (defun %with-array-data
/fp
(array start end
)
134 (assert (typep array
'(simple-array * (*))))
135 (values array start end
0))
137 (defun signed-byte-32-p (number)
138 (typep number
'(signed-byte 32)))
140 ;; This has an obvious portable implementation
141 ;; as (typep number 'ratio), but apparently we
142 ;; expect never to need it.
143 (defun ratiop (number)
144 (declare (ignore number
))
145 (error "Should not call RATIOP"))
147 (defun make-value-cell (value)
148 (declare (ignore value
))
149 (error "cross-compiler can not make value cells"))
151 ;;; package locking nops for the cross-compiler
153 (defmacro without-package-locks
(&body body
)
156 (defmacro with-single-package-locked-error
((&optional kind thing
&rest format
)
158 ;; FIXME: perhaps this should touch THING to make it used?
159 (declare (ignore kind thing format
))
162 (defun program-assert-symbol-home-package-unlocked (context symbol control
)
163 (declare (ignore context control
))
166 (defun assert-package-unlocked (package &optional format-control
167 &rest format-arguments
)
168 (declare (ignore format-control format-arguments
))
171 (defun assert-symbol-home-package-unlocked (name &optional format-control
172 &rest format-arguments
)
173 (declare (ignore format-control format-arguments
))
176 (declaim (declaration enable-package-locks disable-package-locks
))
178 ;; Nonstandard accessor for when you know you have a valid package in hand.
179 ;; This avoids double lookup in *PACKAGE-NAMES* in a few places.
180 ;; But portably we have to just fallback to PACKAGE-NAME.
181 (defun package-%name
(x) (package-name x
))
183 ;;; printing structures
185 (defun default-structure-print (structure stream depth
)
186 (declare (ignore depth
))
187 (write structure
:stream stream
:circle t
))
189 (in-package "SB!KERNEL")
190 (defun %find-position
(item seq from-end start end key test
)
191 (let ((position (position item seq
:from-end from-end
192 :start start
:end end
:key key
:test test
)))
193 (values (if position
(elt seq position
) nil
) position
)))
195 (defun sb!impl
::split-seconds-for-sleep
(&rest args
)
196 (declare (ignore args
))
197 (error "Can't call SPLIT-SECONDS-FOR-SLEEP"))
199 ;;; Avoid an unknown type reference from globaldb.
200 (deftype fdefn
() '(satisfies fdefn-p
))