0.7.13.7:
[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   `(progn ,@forms))
33
34 ;;; When we're running as a cross-compiler in an arbitrary host ANSI
35 ;;; Lisp, we shouldn't be doing anything which is sensitive to GC.
36 ;;; KLUDGE: I (WHN 19990131) think the proper long-term solution would
37 ;;; be to remove any operations from cross-compiler source files
38 ;;; (putting them in target-only source files) if they refer to these
39 ;;; hooks. This is a short-term hack.
40 (defvar *before-gc-hooks* nil)
41 (defvar *after-gc-hooks* nil)
42
43 ;;; The GENESIS function works with fasl code which would, in the
44 ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
45 ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
46 ;;; CL:STREAM.
47 (deftype ansi-stream () 'stream)
48
49 ;;; In the target SBCL, the INSTANCE type refers to a base
50 ;;; implementation for compound types. There's no way to express
51 ;;; exactly that concept portably, but we can get essentially the same
52 ;;; effect by testing for any of the standard types which would, in
53 ;;; the target SBCL, be derived from INSTANCE:
54 (deftype sb!kernel:instance ()
55   '(or condition standard-object structure-object))
56
57 ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
58 ;;; host Common Lisp.
59 (defun funcallable-instance-p (x)
60   (if (typep x 'generic-function)
61     ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement
62     ;; generic functions, so any case which tests for this might in
63     ;; fact be trying to test for generic functions. My (WHN 19990313)
64     ;; expectation is that this case won't arise in the
65     ;; cross-compiler, but if it does, it deserves a little thought,
66     ;; rather than reflexively returning NIL.
67     (error "not clear how to handle GENERIC-FUNCTION")
68     nil))
69
70 ;;; This seems to be the portable Common Lisp type test which
71 ;;; corresponds to the effect of the target SBCL implementation test...
72 (defun sb!kernel:array-header-p (x)
73   (and (typep x 'array)
74        (or (not (typep x 'simple-array))
75            (/= (array-rank x) 1))))
76
77 ;;; GENESIS needs these at cross-compile time. The target
78 ;;; implementation of these is reasonably efficient by virtue of its
79 ;;; ability to peek into the internals of the package implementation;
80 ;;; this reimplementation is portable but slow.
81 (defun package-internal-symbol-count (package)
82   (let ((result 0))
83     (declare (type fixnum result))
84     (do-symbols (i package)
85       ;; KLUDGE: The ANSI Common Lisp specification warns that
86       ;; DO-SYMBOLS may execute its body more than once for symbols
87       ;; that are inherited from multiple packages, and we currently
88       ;; make no attempt to correct for that here. (The current uses
89       ;; of this function at cross-compile time don't really care if
90       ;; the count is a little too high.) -- WHN 19990826
91       (multiple-value-bind (symbol status)
92           (find-symbol (symbol-name i) package)
93         (declare (ignore symbol))
94         (when (member status '(:internal :inherited))
95           (incf result))))
96     result))
97 (defun package-external-symbol-count (package)
98   (let ((result 0))
99     (declare (type fixnum result))
100     (do-external-symbols (i package)
101       (declare (ignorable i))
102       (incf result))
103     result))
104
105 ;;; In the target Lisp, INTERN* is the primitive and INTERN is
106 ;;; implemented in terms of it. This increases efficiency by letting
107 ;;; us reuse a fixed-size buffer; the alternative would be
108 ;;; particularly painful because we don't implement DYNAMIC-EXTENT. In
109 ;;; the host Lisp, this is only used at cold load time, and we don't
110 ;;; care as much about efficiency, so it's fine to treat the host
111 ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it.
112 (defun intern* (nameoid length package)
113   (intern (replace (make-string length) nameoid :end2 length) package))
114
115 ;;; In the target Lisp this is implemented by reading a fixed slot in
116 ;;; the symbol. In portable ANSI Common Lisp the same criteria can be
117 ;;; met (more slowly, and with the extra property of repeatability
118 ;;; between runs) by just calling SXHASH.
119 (defun symbol-hash (symbol)
120   (declare (type symbol symbol))
121   (sxhash symbol))