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 (defmacro named-lambda
(name args
&body body
)
21 (declare (ignore name
))
22 `#'(lambda ,args
,@body
))
24 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
25 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
26 ;;; have a single thread of control.
27 (defmacro without-interrupts
(&rest forms
)
28 `(macrolet ((allow-with-interrupts (&body body
)
30 (with-local-interrupts (&body body
)
34 (defmacro with-locked-hash-table
((table) &body body
)
35 (declare (ignore table
))
38 (defmacro with-locked-system-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
)
57 '(or condition structure-object standard-object
))
58 (deftype 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 array-header-p (x)
87 (or (not (typep x
'simple-array
))
88 (/= (array-rank x
) 1))))
90 (defvar sb
!xc
:*gensym-counter
* 0)
92 (defun sb!xc
:gensym
(&optional
(thing "G"))
93 (declare (type string thing
))
94 (let ((n sb
!xc
:*gensym-counter
*))
96 (make-symbol (concatenate 'string thing
(write-to-string n
:base
10 :radix nil
:pretty nil
)))
97 (incf sb
!xc
:*gensym-counter
*))))
99 ;;; These functions are needed for constant-folding.
100 (defun simple-array-nil-p (object)
101 (when (typep object
'array
)
102 (assert (not (eq (array-element-type object
) nil
))))
105 (defun %negate
(number)
108 (defun %single-float
(number)
109 (coerce number
'single-float
))
111 (defun %double-float
(number)
112 (coerce number
'double-float
))
114 (defun %ldb
(size posn integer
)
115 (ldb (byte size posn
) integer
))
117 (defun %dpb
(newbyte size posn integer
)
118 (dpb newbyte
(byte size posn
) integer
))
120 (defun %with-array-data
(array start end
)
121 (assert (typep array
'(simple-array * (*))))
122 (values array start end
0))
124 (defun %with-array-data
/fp
(array start end
)
125 (assert (typep array
'(simple-array * (*))))
126 (values array start end
0))
128 (defun signed-byte-32-p (number)
129 (typep number
'(signed-byte 32)))
131 ;;; package locking nops for the cross-compiler
133 (defmacro without-package-locks
(&body body
)
136 (defmacro with-single-package-locked-error
((&optional kind thing
&rest format
)
138 (declare (ignore kind thing format
))
141 (defun program-assert-symbol-home-package-unlocked (context symbol control
)
142 (declare (ignore context control
))
145 (defun assert-package-unlocked (package &optional format-control
146 &rest format-arguments
)
147 (declare (ignore format-control format-arguments
))
150 (defun assert-symbol-home-package-unlocked (name &optional format-control
151 &rest format-arguments
)
152 (declare (ignore format-control format-arguments
))
155 (declaim (declaration enable-package-locks disable-package-locks
))
157 ;;; printing structures
159 (defun default-structure-print (structure stream depth
)
160 (declare (ignore depth
))
161 (write structure
:stream stream
:circle t
))