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 (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
)
26 sb
!fasl
::allocate-struct
31 sb
!fasl
::cold-symbol-value
32 sb
!fasl
::write-slots
))
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
)
39 (defmacro named-lambda
(name args
&body body
)
40 (declare (ignore name
))
41 `#'(lambda ,args
,@body
))
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
)
49 (with-local-interrupts (&body body
)
53 (defmacro with-locked-hash-table
((table) &body body
)
54 (declare (ignore table
))
57 (defmacro with-locked-system-table
((table) &body body
)
58 (declare (ignore table
))
61 (defmacro defglobal
(name value
&rest doc
)
62 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
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
73 (deftype ansi-stream
() 'stream
)
76 '(or condition structure-object standard-object
))
77 (deftype funcallable-instance
()
78 (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
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:
87 (typep x
'(or condition structure-object standard-object
)))
89 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
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")
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))))
109 (defvar sb
!xc
:*gensym-counter
* 0)
111 (defun sb!xc
:gensym
(&optional
(thing "G"))
112 (declare (type string thing
))
113 (let ((n sb
!xc
:*gensym-counter
*))
115 (make-symbol (concatenate 'string thing
(write-to-string n
:base
10 :radix nil
:pretty nil
)))
116 (incf sb
!xc
:*gensym-counter
*))))
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
))))
124 (defun %negate
(number)
127 (defun %single-float
(number)
128 (coerce number
'single-float
))
130 (defun %double-float
(number)
131 (coerce number
'double-float
))
133 (defun %ldb
(size posn integer
)
134 (ldb (byte size posn
) integer
))
136 (defun %dpb
(newbyte size posn integer
)
137 (dpb newbyte
(byte size posn
) integer
))
139 (defun %with-array-data
(array start end
)
140 (assert (typep array
'(simple-array * (*))))
141 (values array start end
0))
143 (defun %with-array-data
/fp
(array start end
)
144 (assert (typep array
'(simple-array * (*))))
145 (values array start end
0))
147 (defun signed-byte-32-p (number)
148 (typep number
'(signed-byte 32)))
150 ;;; package locking nops for the cross-compiler
152 (defmacro without-package-locks
(&body body
)
155 (defmacro with-single-package-locked-error
((&optional kind thing
&rest format
)
157 ;; FIXME: perhaps this should touch THING to make it used?
158 (declare (ignore kind thing format
))
161 (defun program-assert-symbol-home-package-unlocked (context symbol control
)
162 (declare (ignore context control
))
165 (defun assert-package-unlocked (package &optional format-control
166 &rest format-arguments
)
167 (declare (ignore format-control format-arguments
))
170 (defun assert-symbol-home-package-unlocked (name &optional format-control
171 &rest format-arguments
)
172 (declare (ignore format-control format-arguments
))
175 (declaim (declaration enable-package-locks disable-package-locks
))
177 ;;; printing structures
179 (defun default-structure-print (structure stream depth
)
180 (declare (ignore depth
))
181 (write structure
:stream stream
:circle t
))