1.0.11.34: better SUBSEQ on lists
[sbcl.git] / src / code / cross-misc.lisp
1 ;;;; cross-compile-time-only replacements for miscellaneous unportable
2 ;;;; stuff
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!IMPL")
14
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)
18   `(the ,type ,expr))
19
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))
23
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))
27
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)
33                 `(progn ,@body))
34               (with-local-interrupts (&body body)
35                 `(progn ,@body)))
36      ,@forms))
37
38 (defmacro with-locked-hash-table ((table) &body body)
39   (declare (ignore table))
40   `(progn ,@body))
41
42 ;;; The GENESIS function works with fasl code which would, in the
43 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
44 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
45 ;;; CL:STREAM.
46 (deftype ansi-stream () 'stream)
47
48 (deftype sb!kernel:instance ()
49   '(or condition structure-object standard-object))
50 (deftype sb!kernel:funcallable-instance ()
51   (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
52
53 ;;; In the target SBCL, the INSTANCE type refers to a base
54 ;;; implementation for compound types with lowtag
55 ;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
56 ;;; concept portably, but we can get essentially the same effect by
57 ;;; testing for any of the standard types which would, in the target
58 ;;; SBCL, be derived from INSTANCE:
59 (defun %instancep (x)
60   (typep x '(or condition structure-object standard-object)))
61
62 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
63 ;;; host Common Lisp.
64 (defun funcallable-instance-p (x)
65   (if (typep x 'generic-function)
66     ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
67     ;; generic functions, so any case which tests for this might in
68     ;; fact be trying to test for generic functions. My (WHN 19990313)
69     ;; expectation is that this case won't arise in the
70     ;; cross-compiler, but if it does, it deserves a little thought,
71     ;; rather than reflexively returning NIL.
72     (error "not clear how to handle GENERIC-FUNCTION")
73     nil))
74
75 ;;; This seems to be the portable Common Lisp type test which
76 ;;; corresponds to the effect of the target SBCL implementation test...
77 (defun sb!kernel:array-header-p (x)
78   (and (typep x 'array)
79        (or (not (typep x 'simple-array))
80            (/= (array-rank x) 1))))
81
82 ;;; GENESIS needs these at cross-compile time. The target
83 ;;; implementation of these is reasonably efficient by virtue of its
84 ;;; ability to peek into the internals of the package implementation;
85 ;;; this reimplementation is portable but slow.
86 (defun package-internal-symbol-count (package)
87   (let ((result 0))
88     (declare (type fixnum result))
89     (do-symbols (i package)
90       ;; KLUDGE: The ANSI Common Lisp specification warns that
91       ;; DO-SYMBOLS may execute its body more than once for symbols
92       ;; that are inherited from multiple packages, and we currently
93       ;; make no attempt to correct for that here. (The current uses
94       ;; of this function at cross-compile time don't really care if
95       ;; the count is a little too high.) -- WHN 19990826
96       (multiple-value-bind (symbol status)
97           (find-symbol (symbol-name i) package)
98         (declare (ignore symbol))
99         (when (member status '(:internal :inherited))
100           (incf result))))
101     result))
102 (defun package-external-symbol-count (package)
103   (let ((result 0))
104     (declare (type fixnum result))
105     (do-external-symbols (i package)
106       (declare (ignorable i))
107       (incf result))
108     result))
109
110 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
111 ;;; implemented in terms of it. This increases efficiency by letting
112 ;;; us reuse a fixed-size buffer; the alternative would be
113 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
114 ;;; the host Lisp, this is only used at cold load time, and we don't
115 ;;; care as much about efficiency, so it's fine to treat the host
116 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
117 (defun intern* (nameoid length package)
118   (intern (replace (make-string length) nameoid :end2 length) package))
119
120 ;;; In the target Lisp this is implemented by reading a fixed slot in
121 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
122 ;;; met (more slowly, and with the extra property of repeatability
123 ;;; between runs) by just calling SXHASH.
124 (defun symbol-hash (symbol)
125   (declare (type symbol symbol))
126   (sxhash symbol))
127
128 ;;; These functions are needed for constant-folding.
129 (defun sb!kernel:simple-array-nil-p (object)
130   (when (typep object 'array)
131     (assert (not (eq (array-element-type object) nil))))
132   nil)
133
134 (defun sb!kernel:%negate (number)
135   (- number))
136
137 (defun sb!kernel:%single-float (number)
138   (coerce number 'single-float))
139
140 (defun sb!kernel:%double-float (number)
141   (coerce number 'double-float))
142
143 (defun sb!kernel:%ldb (size posn integer)
144   (ldb (byte size posn) integer))
145
146 (defun sb!kernel:%dpb (newbyte size posn integer)
147   (dpb newbyte (byte size posn) integer))
148
149 (defun sb!kernel:%with-array-data (array start end)
150   (assert (typep array '(simple-array * (*))))
151   (values array start end 0))
152
153 (defun sb!kernel:signed-byte-32-p (number)
154   (typep number '(signed-byte 32)))
155
156 ;;; package locking nops for the cross-compiler
157
158 (defmacro without-package-locks (&body body)
159   `(progn ,@body))
160
161 (defmacro with-single-package-locked-error ((&optional kind thing &rest format)
162                                             &body body)
163   (declare (ignore kind thing format))
164   `(progn ,@body))
165
166 (defun program-assert-symbol-home-package-unlocked (context symbol control)
167   (declare (ignore context control))
168   symbol)
169
170 (defun assert-package-unlocked (package &optional control &rest args)
171   (declare (ignore control args))
172   package)
173
174 (defun assert-symbol-home-package-unlocked (name format &key continuablep)
175   (declare (ignore format continuablep))
176   name)
177
178 (declaim (declaration enable-package-locks disable-package-locks))