1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | ;; Non-portable type-predicates & such. |
---|
20 | |
---|
21 | |
---|
22 | ;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils |
---|
23 | |
---|
24 | (defun find-builtin-cell (type &optional create) |
---|
25 | (declare (ignore create)) |
---|
26 | (cons type nil)) |
---|
27 | |
---|
28 | (defun find-class-cell (type create?) |
---|
29 | (declare (ignore create?)) |
---|
30 | (make-class-cell type)) |
---|
31 | |
---|
32 | (defun builtin-typep (form cell) |
---|
33 | (typep form (class-cell-name cell))) |
---|
34 | |
---|
35 | (defun class-cell-typep (arg class-cell) |
---|
36 | (typep arg (class-cell-name class-cell))) |
---|
37 | |
---|
38 | (defun class-cell-find-class (class-cell errorp) |
---|
39 | (declare (ignore errorp)) ; AARGH can't be right |
---|
40 | ;(dbg-paws #x100) |
---|
41 | (let ((class (and class-cell (class-cell-class class-cell)))) |
---|
42 | (or class |
---|
43 | (if (fboundp 'find-class) |
---|
44 | (find-class (class-cell-name class-cell) nil))))) |
---|
45 | |
---|
46 | (defun %require-type-builtin (form foo) |
---|
47 | (declare (ignore foo)) |
---|
48 | form) |
---|
49 | |
---|
50 | (defun %require-type-class-cell (form cell) |
---|
51 | (declare (ignore cell)) |
---|
52 | form) |
---|
53 | |
---|
54 | (defun non-nil-symbol-p (x) |
---|
55 | (if (symbolp x) x)) |
---|
56 | |
---|
57 | (defun pathnamep (thing) |
---|
58 | (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname))) |
---|
59 | |
---|
60 | (defun compiled-function-p (form) |
---|
61 | "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise." |
---|
62 | (and (functionp form) |
---|
63 | (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form)))))) |
---|
64 | |
---|
65 | ;;; all characters are base-chars. |
---|
66 | (defun extended-char-p (c) |
---|
67 | (declare (ignore c))) |
---|
68 | |
---|
69 | |
---|
70 | ;;; Some of these things are probably open-coded. |
---|
71 | ;;; The functions have to exist SOMEWHERE ... |
---|
72 | (defun fixnump (x) |
---|
73 | (= (the fixnum (lisptag x)) target::tag-fixnum)) |
---|
74 | |
---|
75 | (defun bignump (x) |
---|
76 | (= (the fixnum (typecode x)) target::subtag-bignum)) |
---|
77 | |
---|
78 | (defun integerp (x) |
---|
79 | "Return true if OBJECT is an INTEGER, and NIL otherwise." |
---|
80 | (let* ((typecode (typecode x))) |
---|
81 | (declare (fixnum typecode)) |
---|
82 | (or (= typecode target::tag-fixnum) |
---|
83 | (= typecode target::subtag-bignum)))) |
---|
84 | |
---|
85 | (defun ratiop (x) |
---|
86 | (= (the fixnum (typecode x)) target::subtag-ratio)) |
---|
87 | |
---|
88 | |
---|
89 | (defun rationalp (x) |
---|
90 | "Return true if OBJECT is a RATIONAL, and NIL otherwise." |
---|
91 | (or (fixnump x) |
---|
92 | (let* ((typecode (typecode x))) |
---|
93 | (declare (fixnum typecode)) |
---|
94 | #+ppc32-target |
---|
95 | (and (>= typecode ppc32::min-numeric-subtag) |
---|
96 | (<= typecode ppc32::max-rational-subtag)) |
---|
97 | #+(or ppc64-target x8664-target) |
---|
98 | (cond ((= typecode target::subtag-bignum) t) |
---|
99 | ((= typecode target::subtag-ratio) t))))) |
---|
100 | |
---|
101 | (defun short-float-p (x) |
---|
102 | (= (the fixnum (typecode x)) target::subtag-single-float)) |
---|
103 | |
---|
104 | |
---|
105 | (defun double-float-p (x) |
---|
106 | (= (the fixnum (typecode x)) target::subtag-double-float)) |
---|
107 | |
---|
108 | (defun floatp (x) |
---|
109 | "Return true if OBJECT is a FLOAT, and NIL otherwise." |
---|
110 | (let* ((typecode (typecode x))) |
---|
111 | (declare (fixnum typecode)) |
---|
112 | (or (= typecode target::subtag-single-float) |
---|
113 | (= typecode target::subtag-double-float)))) |
---|
114 | |
---|
115 | (defun realp (x) |
---|
116 | "Return true if OBJECT is a REAL, and NIL otherwise." |
---|
117 | (let* ((typecode (typecode x))) |
---|
118 | (declare (fixnum typecode)) |
---|
119 | #+ppc32-target |
---|
120 | (or (= typecode ppc32::tag-fixnum) |
---|
121 | (and (>= typecode ppc32::min-numeric-subtag) |
---|
122 | (<= typecode ppc32::max-real-subtag))) |
---|
123 | #+ppc64-target |
---|
124 | (if (<= typecode ppc64::subtag-double-float) |
---|
125 | (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) |
---|
126 | (logior (ash 1 ppc64::tag-fixnum) |
---|
127 | (ash 1 ppc64::subtag-single-float) |
---|
128 | (ash 1 ppc64::subtag-double-float) |
---|
129 | (ash 1 ppc64::subtag-bignum) |
---|
130 | (ash 1 ppc64::subtag-ratio)))) |
---|
131 | #+x8664-target |
---|
132 | (if (<= typecode x8664::subtag-double-float) |
---|
133 | (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) |
---|
134 | (logior (ash 1 x8664::tag-fixnum) |
---|
135 | (ash 1 x8664::subtag-bignum) |
---|
136 | (ash 1 x8664::tag-single-float) |
---|
137 | (ash 1 x8664::subtag-double-float) |
---|
138 | (ash 1 x8664::subtag-ratio)))))) |
---|
139 | |
---|
140 | (defun complexp (x) |
---|
141 | "Return true if OBJECT is a COMPLEX, and NIL otherwise." |
---|
142 | (= (the fixnum (typecode x)) target::subtag-complex)) |
---|
143 | |
---|
144 | (defun numberp (x) |
---|
145 | "Return true if OBJECT is a NUMBER, and NIL otherwise." |
---|
146 | (let* ((typecode (typecode x))) |
---|
147 | (declare (fixnum typecode)) |
---|
148 | #+ppc32-target |
---|
149 | (or (= typecode ppc32::tag-fixnum) |
---|
150 | (and (>= typecode ppc32::min-numeric-subtag) |
---|
151 | (<= typecode ppc32::max-numeric-subtag))) |
---|
152 | #+ppc64-target |
---|
153 | (if (<= typecode ppc64::subtag-double-float) |
---|
154 | (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) |
---|
155 | (logior (ash 1 ppc64::tag-fixnum) |
---|
156 | (ash 1 ppc64::subtag-bignum) |
---|
157 | (ash 1 ppc64::subtag-single-float) |
---|
158 | (ash 1 ppc64::subtag-double-float) |
---|
159 | (ash 1 ppc64::subtag-ratio) |
---|
160 | (ash 1 ppc64::subtag-complex)))) |
---|
161 | #+x8664-target |
---|
162 | (if (< typecode x8664::nbits-in-word) |
---|
163 | (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) |
---|
164 | (logior (ash 1 x8664::tag-fixnum) |
---|
165 | (ash 1 x8664::subtag-bignum) |
---|
166 | (ash 1 x8664::tag-single-float) |
---|
167 | (ash 1 x8664::subtag-double-float) |
---|
168 | (ash 1 x8664::subtag-ratio) |
---|
169 | (ash 1 x8664::subtag-complex)))) |
---|
170 | |
---|
171 | )) |
---|
172 | |
---|
173 | (defun arrayp (x) |
---|
174 | "Return true if OBJECT is an ARRAY, and NIL otherwise." |
---|
175 | (>= (the fixnum (typecode x)) target::min-array-subtag)) |
---|
176 | |
---|
177 | (defun vectorp (x) |
---|
178 | "Return true if OBJECT is a VECTOR, and NIL otherwise." |
---|
179 | (>= (the fixnum (typecode x)) target::min-vector-subtag)) |
---|
180 | |
---|
181 | |
---|
182 | (defun stringp (x) |
---|
183 | "Return true if OBJECT is a STRING, and NIL otherwise." |
---|
184 | (let* ((typecode (typecode x))) |
---|
185 | (declare (fixnum typecode)) |
---|
186 | (if (= typecode target::subtag-vectorH) |
---|
187 | (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell))))) |
---|
188 | (= typecode target::subtag-simple-base-string))) |
---|
189 | |
---|
190 | |
---|
191 | (defun simple-base-string-p (x) |
---|
192 | (= (the fixnum (typecode x)) target::subtag-simple-base-string)) |
---|
193 | |
---|
194 | (defun simple-string-p (x) |
---|
195 | "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise." |
---|
196 | (= (the fixnum (typecode x)) target::subtag-simple-base-string)) |
---|
197 | |
---|
198 | (defun complex-array-p (x) |
---|
199 | (let* ((typecode (typecode x))) |
---|
200 | (declare (fixnum typecode)) |
---|
201 | (if (or (= typecode target::subtag-arrayH) |
---|
202 | (= typecode target::subtag-vectorH)) |
---|
203 | (not (%array-header-simple-p x))))) |
---|
204 | |
---|
205 | (defun simple-array-p (thing) |
---|
206 | "Returns T if the object is a simple array, else returns NIL. |
---|
207 | That's why it's called SIMPLE-ARRAY-P. Get it ? |
---|
208 | A simple-array may have no fill-pointer, may not be displaced, |
---|
209 | and may not be adjustable." |
---|
210 | (let* ((typecode (typecode thing))) |
---|
211 | (declare (fixnum typecode)) |
---|
212 | (if (or (= typecode target::subtag-arrayH) |
---|
213 | (= typecode target::subtag-vectorH)) |
---|
214 | (%array-header-simple-p thing) |
---|
215 | (> typecode target::subtag-vectorH)))) |
---|
216 | |
---|
217 | (defun macptrp (x) |
---|
218 | (= (the fixnum (typecode x)) target::subtag-macptr)) |
---|
219 | |
---|
220 | (defun dead-macptr-p (x) |
---|
221 | (= (the fixnum (typecode x)) target::subtag-dead-macptr)) |
---|
222 | |
---|
223 | |
---|
224 | ;;; Note that this is true of symbols and functions and many other |
---|
225 | ;;; things that it wasn't true of on the 68K. |
---|
226 | (defun gvectorp (x) |
---|
227 | #+ppc32-target |
---|
228 | (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::fulltag-nodeheader) |
---|
229 | #+ppc64-target |
---|
230 | (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader) |
---|
231 | #+x8664-target |
---|
232 | (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) |
---|
233 | (declare (fixnum fulltag)) |
---|
234 | (or (= fulltag x8664::fulltag-nodeheader-0) |
---|
235 | (= fulltag x8664::fulltag-nodeheader-1))) |
---|
236 | ) |
---|
237 | |
---|
238 | |
---|
239 | (setf (type-predicate 'gvector) 'gvectorp) |
---|
240 | |
---|
241 | (defun ivectorp (x) |
---|
242 | #+ppc32-target |
---|
243 | (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) |
---|
244 | ppc32::fulltag-immheader) |
---|
245 | #+ppc64-target |
---|
246 | (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader) |
---|
247 | #+x8664-target |
---|
248 | (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) |
---|
249 | (declare (fixnum fulltag)) |
---|
250 | (or (= fulltag x8664::fulltag-immheader-0) |
---|
251 | (= fulltag x8664::fulltag-immheader-1) |
---|
252 | (= fulltag x8664::fulltag-immheader-2))) |
---|
253 | ) |
---|
254 | |
---|
255 | (setf (type-predicate 'ivector) 'ivectorp) |
---|
256 | |
---|
257 | (defun miscobjp (x) |
---|
258 | #+(or ppc32-target x8664-target) |
---|
259 | (= (the fixnum (lisptag x)) target::tag-misc) |
---|
260 | #+ppc64-target |
---|
261 | (= (the fixnum (fulltag x)) ppc64::fulltag-misc) |
---|
262 | ) |
---|
263 | |
---|
264 | (defun simple-vector-p (x) |
---|
265 | "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise." |
---|
266 | (= (the fixnum (typecode x)) target::subtag-simple-vector)) |
---|
267 | |
---|
268 | (defun base-string-p (thing) |
---|
269 | (let* ((typecode (typecode thing))) |
---|
270 | (declare (fixnum typecode)) |
---|
271 | (or (= typecode target::subtag-simple-base-string) |
---|
272 | (and (= typecode target::subtag-vectorh) |
---|
273 | (= (the fixnum |
---|
274 | (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) |
---|
275 | target::subtag-simple-base-string))))) |
---|
276 | |
---|
277 | (defun simple-bit-vector-p (form) |
---|
278 | "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise." |
---|
279 | (= (the fixnum (typecode form)) target::subtag-bit-vector)) |
---|
280 | |
---|
281 | (defun bit-vector-p (thing) |
---|
282 | "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise." |
---|
283 | (let* ((typecode (typecode thing))) |
---|
284 | (declare (fixnum typecode)) |
---|
285 | (or (= typecode target::subtag-bit-vector) |
---|
286 | (and (= typecode target::subtag-vectorh) |
---|
287 | (= (the fixnum |
---|
288 | (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) |
---|
289 | target::subtag-bit-vector))))) |
---|
290 | |
---|
291 | (defun displaced-array-p (array) |
---|
292 | (if (%array-is-header array) |
---|
293 | (do* ((disp (%svref array target::arrayH.displacement-cell) |
---|
294 | (+ disp (the fixnum (%svref target target::arrayH.displacement-cell)))) |
---|
295 | (target (%svref array target::arrayH.data-vector-cell) |
---|
296 | (%svref target target::arrayH.data-vector-cell))) |
---|
297 | ((not (%array-is-header target)) |
---|
298 | (values target disp))) |
---|
299 | (values nil 0))) |
---|
300 | |
---|
301 | |
---|
302 | |
---|
303 | (defun eq (x y) |
---|
304 | "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." |
---|
305 | (eq x y)) |
---|
306 | |
---|
307 | |
---|
308 | (defun cons-equal (x y) |
---|
309 | (declare (cons x y)) |
---|
310 | (if (equal (car x) (car y)) |
---|
311 | (equal (cdr x) (cdr y)))) |
---|
312 | |
---|
313 | (defun hairy-equal (x y) |
---|
314 | (declare (optimize (speed 3))) |
---|
315 | ;; X and Y are not EQL, and are both of tag target::fulltag-misc. |
---|
316 | (let* ((x-type (typecode x)) |
---|
317 | (y-type (typecode y))) |
---|
318 | (declare (fixnum x-type y-type)) |
---|
319 | (if (and (>= x-type target::subtag-vectorH) |
---|
320 | (>= y-type target::subtag-vectorH)) |
---|
321 | (let* ((x-simple (if (= x-type target::subtag-vectorH) |
---|
322 | (ldb target::arrayH.flags-cell-subtag-byte |
---|
323 | (the fixnum (%svref x target::arrayH.flags-cell))) |
---|
324 | x-type)) |
---|
325 | (y-simple (if (= y-type target::subtag-vectorH) |
---|
326 | (ldb target::arrayH.flags-cell-subtag-byte |
---|
327 | (the fixnum (%svref y target::arrayH.flags-cell))) |
---|
328 | y-type))) |
---|
329 | (declare (fixnum x-simple y-simple)) |
---|
330 | (if (= x-simple target::subtag-simple-base-string) |
---|
331 | (if (= y-simple target::subtag-simple-base-string) |
---|
332 | (locally |
---|
333 | (declare (optimize (speed 3) (safety 0))) |
---|
334 | (let* ((x-len (if (= x-type target::subtag-vectorH) |
---|
335 | (%svref x target::vectorH.logsize-cell) |
---|
336 | (uvsize x))) |
---|
337 | (x-pos 0) |
---|
338 | (y-len (if (= y-type target::subtag-vectorH) |
---|
339 | (%svref y target::vectorH.logsize-cell) |
---|
340 | (uvsize y))) |
---|
341 | (y-pos 0)) |
---|
342 | (declare (fixnum x-len x-pos y-len y-pos)) |
---|
343 | (when (= x-type target::subtag-vectorH) |
---|
344 | (multiple-value-setq (x x-pos) (array-data-and-offset x))) |
---|
345 | (when (= y-type target::subtag-vectorH) |
---|
346 | (multiple-value-setq (y y-pos) (array-data-and-offset y))) |
---|
347 | (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len)))))) |
---|
348 | ;;Bit-vector case or fail. |
---|
349 | (and (= x-simple target::subtag-bit-vector) |
---|
350 | (= y-simple target::subtag-bit-vector) |
---|
351 | (locally |
---|
352 | (declare (optimize (speed 3) (safety 0))) |
---|
353 | (let* ((x-len (if (= x-type target::subtag-vectorH) |
---|
354 | (%svref x target::vectorH.logsize-cell) |
---|
355 | (uvsize x))) |
---|
356 | (x-pos 0) |
---|
357 | (y-len (if (= y-type target::subtag-vectorH) |
---|
358 | (%svref y target::vectorH.logsize-cell) |
---|
359 | (uvsize y))) |
---|
360 | (y-pos 0)) |
---|
361 | (declare (fixnum x-len x-pos y-len y-pos)) |
---|
362 | (when (= x-len y-len) |
---|
363 | (when (= x-type target::subtag-vectorH) |
---|
364 | (multiple-value-setq (x x-pos) (array-data-and-offset x))) |
---|
365 | (when (= y-type target::subtag-vectorH) |
---|
366 | (multiple-value-setq (y y-pos) (array-data-and-offset y))) |
---|
367 | (do* ((i 0 (1+ i))) |
---|
368 | ((= i x-len) t) |
---|
369 | (declare (fixnum i)) |
---|
370 | (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos))) |
---|
371 | (return)) |
---|
372 | (incf x-pos) |
---|
373 | (incf y-pos)))))))) |
---|
374 | (if (= x-type y-type) |
---|
375 | (if (= x-type target::subtag-istruct) |
---|
376 | (and (let* ((structname (%svref x 0))) |
---|
377 | (and (eq structname (%svref y 0)) |
---|
378 | (or (eq structname 'pathname) |
---|
379 | (eq structname 'logical-pathname))) |
---|
380 | (locally |
---|
381 | (declare (optimize (speed 3) (safety 0))) |
---|
382 | (let* ((x-size (uvsize x))) |
---|
383 | (declare (fixnum x-size)) |
---|
384 | (when (= x-size (the fixnum (uvsize y))) |
---|
385 | ;; Ignore last (version) slot in physical pathnames. |
---|
386 | (when (eq structname 'pathname) |
---|
387 | (decf x-size)) |
---|
388 | (do* ((i 1 (1+ i))) |
---|
389 | ((= i x-size) t) |
---|
390 | (declare (fixnum i)) |
---|
391 | (unless (equal (%svref x i) (%svref y i)) |
---|
392 | (return))))))))))))) |
---|
393 | |
---|
394 | #+ppc32-target |
---|
395 | (progn |
---|
396 | (defparameter *nodeheader-types* |
---|
397 | #(bogus ; 0 |
---|
398 | ratio ; 1 |
---|
399 | bogus ; 2 |
---|
400 | complex ; 3 |
---|
401 | catch-frame ; 4 |
---|
402 | function ; 5 |
---|
403 | basic-stream ; 6 |
---|
404 | symbol ; 7 |
---|
405 | lock ; 8 |
---|
406 | hash-table-vector ; 9 |
---|
407 | pool ; 10 |
---|
408 | population ; 11 |
---|
409 | package ; 12 |
---|
410 | slot-vector ; 13 |
---|
411 | standard-instance ; 14 |
---|
412 | structure ; 15 |
---|
413 | internal-structure ; 16 |
---|
414 | value-cell ; 17 |
---|
415 | xfunction ; 18 |
---|
416 | array-header ; 19 |
---|
417 | vector-header ; 20 |
---|
418 | simple-vector ; 21 |
---|
419 | bogus ; 22 |
---|
420 | bogus ; 23 |
---|
421 | bogus ; 24 |
---|
422 | bogus ; 25 |
---|
423 | bogus ; 26 |
---|
424 | bogus ; 27 |
---|
425 | bogus ; 28 |
---|
426 | bogus ; 29 |
---|
427 | bogus ; 30 |
---|
428 | bogus ; 31 |
---|
429 | )) |
---|
430 | |
---|
431 | |
---|
432 | (defparameter *immheader-types* |
---|
433 | #(bignum ; 0 |
---|
434 | short-float ; 1 |
---|
435 | double-float ; 2 |
---|
436 | macptr ; 3 |
---|
437 | dead-macptr ; 4 |
---|
438 | code-vector ; 5 |
---|
439 | creole-object ; 6 |
---|
440 | ;; 8-19 are unused |
---|
441 | xcode-vector ; 7 |
---|
442 | bogus ; 8 |
---|
443 | bogus ; 9 |
---|
444 | bogus ; 10 |
---|
445 | bogus ; 11 |
---|
446 | bogus ; 12 |
---|
447 | bogus ; 13 |
---|
448 | bogus ; 14 |
---|
449 | bogus ; 15 |
---|
450 | bogus ; 16 |
---|
451 | bogus ; 17 |
---|
452 | bogus ; 18 |
---|
453 | bogus ; 19 |
---|
454 | simple-short-float-vector ; 20 |
---|
455 | simple-unsigned-long-vector ; 21 |
---|
456 | simple-signed-long-vector ; 22 |
---|
457 | simple-fixnum-vector ; 23 |
---|
458 | simple-base-string ; 24 |
---|
459 | simple-unsigned-byte-vector ; 25 |
---|
460 | simple-signed-byte-vector ; 26 |
---|
461 | bogus ; 27 |
---|
462 | simple-unsigned-word-vector ; 28 |
---|
463 | simple-signed-word-vector ; 29 |
---|
464 | simple-double-float-vector ; 30 |
---|
465 | simple-bit-vector ; 31 |
---|
466 | )) |
---|
467 | |
---|
468 | (defun %type-of (thing) |
---|
469 | (let* ((typecode (typecode thing))) |
---|
470 | (declare (fixnum typecode)) |
---|
471 | (if (= typecode ppc32::tag-fixnum) |
---|
472 | 'fixnum |
---|
473 | (if (= typecode ppc32::tag-list) |
---|
474 | (if thing 'cons 'null) |
---|
475 | (if (= typecode ppc32::tag-imm) |
---|
476 | (if (base-char-p thing) |
---|
477 | 'base-char |
---|
478 | 'immediate) |
---|
479 | (if (= typecode ppc32::subtag-macptr) |
---|
480 | (if (classp thing) |
---|
481 | (class-name thing) |
---|
482 | 'macptr) |
---|
483 | (let* ((tag-type (logand typecode ppc32::full-tag-mask)) |
---|
484 | (tag-val (ash typecode (- ppc32::ntagbits)))) |
---|
485 | (declare (fixnum tag-type tag-val)) |
---|
486 | (if (/= tag-type ppc32::fulltag-nodeheader) |
---|
487 | (%svref *immheader-types* tag-val) |
---|
488 | (let ((type (%svref *nodeheader-types* tag-val))) |
---|
489 | (if (eq type 'function) |
---|
490 | (let ((bits (lfun-bits thing))) |
---|
491 | (declare (fixnum bits)) |
---|
492 | (if (logbitp $lfbits-trampoline-bit bits) |
---|
493 | (let ((inner-fn (closure-function thing))) |
---|
494 | (if (neq inner-fn thing) |
---|
495 | (let ((inner-bits (lfun-bits inner-fn))) |
---|
496 | (if (logbitp $lfbits-method-bit inner-bits) |
---|
497 | 'compiled-lexical-closure |
---|
498 | (if (logbitp $lfbits-gfn-bit inner-bits) |
---|
499 | 'standard-generic-function ; not precisely - see class-of |
---|
500 | (if (logbitp $lfbits-cm-bit inner-bits) |
---|
501 | 'combined-method |
---|
502 | 'compiled-lexical-closure)))) |
---|
503 | 'compiled-lexical-closure)) |
---|
504 | (if (logbitp $lfbits-method-bit bits) |
---|
505 | 'method-function |
---|
506 | 'compiled-function))) |
---|
507 | (if (eq type 'lock) |
---|
508 | (or (uvref thing ppc32::lock.kind-cell) |
---|
509 | type) |
---|
510 | type))))))))))) |
---|
511 | |
---|
512 | );#+ppc32-target |
---|
513 | |
---|
514 | #+ppc64-target |
---|
515 | (progn |
---|
516 | (defparameter *immheader-types* |
---|
517 | #(bogus |
---|
518 | bogus |
---|
519 | code-vector |
---|
520 | bogus |
---|
521 | bogus |
---|
522 | bogus |
---|
523 | xcode-vector |
---|
524 | macptr |
---|
525 | bogus |
---|
526 | bogus |
---|
527 | bignum |
---|
528 | dead-macptr |
---|
529 | bogus |
---|
530 | bogus |
---|
531 | double-float |
---|
532 | bogus |
---|
533 | bogus |
---|
534 | bogus |
---|
535 | bogus |
---|
536 | bogus |
---|
537 | bogus |
---|
538 | bogus |
---|
539 | bogus |
---|
540 | bogus |
---|
541 | bogus |
---|
542 | bogus |
---|
543 | bogus |
---|
544 | bogus |
---|
545 | bogus |
---|
546 | bogus |
---|
547 | bogus |
---|
548 | bogus |
---|
549 | bogus |
---|
550 | bogus |
---|
551 | bogus |
---|
552 | bogus |
---|
553 | simple-signed-byte-vector |
---|
554 | simple-signed-word-vector |
---|
555 | simple-signed-long-vector |
---|
556 | simple-signed-doubleword-vector |
---|
557 | simple-unsigned-byte-vector |
---|
558 | simple-unsigned-word-vector |
---|
559 | simple-unsigned-long-vector |
---|
560 | simple-unsigned-doubleword-vector |
---|
561 | bogus |
---|
562 | bogus |
---|
563 | simple-short-float-vector |
---|
564 | simple-fixnum-vector |
---|
565 | bogus |
---|
566 | bogus |
---|
567 | bogus |
---|
568 | simple-double-float-vector |
---|
569 | bogus |
---|
570 | bogus |
---|
571 | simple-base-string |
---|
572 | bogus |
---|
573 | bogus |
---|
574 | bogus |
---|
575 | bogus |
---|
576 | bogus |
---|
577 | bogus |
---|
578 | simple-bit-vector |
---|
579 | bogus |
---|
580 | bogus)) |
---|
581 | |
---|
582 | (defparameter *nodeheader-types* |
---|
583 | #(function |
---|
584 | catch-frame |
---|
585 | slot-vector |
---|
586 | ratio |
---|
587 | symbol |
---|
588 | basic-stream |
---|
589 | standard-instance |
---|
590 | complex |
---|
591 | bogus |
---|
592 | lock |
---|
593 | structure |
---|
594 | bogus |
---|
595 | bogus |
---|
596 | hash-vector |
---|
597 | internal-structure |
---|
598 | bogus |
---|
599 | bogus |
---|
600 | pool |
---|
601 | value-cell |
---|
602 | bogus |
---|
603 | bogus |
---|
604 | population |
---|
605 | xfunction |
---|
606 | bogus |
---|
607 | bogus |
---|
608 | package |
---|
609 | bogus |
---|
610 | bogus |
---|
611 | bogus |
---|
612 | bogus |
---|
613 | bogus |
---|
614 | bogus |
---|
615 | bogus |
---|
616 | array-header |
---|
617 | vector-header |
---|
618 | simple-vector |
---|
619 | bogus |
---|
620 | bogus |
---|
621 | bogus |
---|
622 | bogus |
---|
623 | bogus |
---|
624 | bogus |
---|
625 | bogus |
---|
626 | bogus |
---|
627 | bogus |
---|
628 | bogus |
---|
629 | bogus |
---|
630 | bogus |
---|
631 | bogus |
---|
632 | bogus |
---|
633 | bogus |
---|
634 | bogus |
---|
635 | bogus |
---|
636 | bogus |
---|
637 | bogus |
---|
638 | bogus |
---|
639 | bogus |
---|
640 | bogus |
---|
641 | bogus |
---|
642 | bogus |
---|
643 | bogus |
---|
644 | bogus |
---|
645 | bogus |
---|
646 | bogus |
---|
647 | ) |
---|
648 | ) |
---|
649 | |
---|
650 | |
---|
651 | (defun %type-of (thing) |
---|
652 | (if (null thing) |
---|
653 | 'null |
---|
654 | (let* ((typecode (typecode thing))) |
---|
655 | (declare (fixnum typecode)) |
---|
656 | (cond ((= typecode ppc64::tag-fixnum) 'fixnum) |
---|
657 | ((= typecode ppc64::fulltag-cons) 'cons) |
---|
658 | ((= typecode ppc64::subtag-character) 'character) |
---|
659 | ((= typecode ppc64::subtag-single-float) 'short-float) |
---|
660 | (t (let* ((lowtag (logand typecode ppc64::lowtagmask))) |
---|
661 | (declare (fixnum lowtag)) |
---|
662 | (cond ((= lowtag ppc64::lowtag-immheader) |
---|
663 | (%svref *immheader-types* (ash typecode -2))) |
---|
664 | ((= lowtag ppc64::lowtag-nodeheader) |
---|
665 | (let* ((type (%svref *nodeheader-types* |
---|
666 | (ash typecode -2)))) |
---|
667 | (cond ((eq type 'function) |
---|
668 | (let ((bits (lfun-bits thing))) |
---|
669 | (declare (fixnum bits)) |
---|
670 | (if (logbitp $lfbits-trampoline-bit bits) |
---|
671 | (let ((inner-fn (closure-function thing))) |
---|
672 | (if (neq inner-fn thing) |
---|
673 | (let ((inner-bits (lfun-bits inner-fn))) |
---|
674 | (if (logbitp $lfbits-method-bit inner-bits) |
---|
675 | 'compiled-lexical-closure |
---|
676 | (if (logbitp $lfbits-gfn-bit inner-bits) |
---|
677 | 'standard-generic-function ; not precisely - see class-of |
---|
678 | (if (logbitp $lfbits-cm-bit inner-bits) |
---|
679 | 'combined-method |
---|
680 | 'compiled-lexical-closure)))) |
---|
681 | 'compiled-lexical-closure)) |
---|
682 | (if (logbitp $lfbits-method-bit bits) |
---|
683 | 'method-function |
---|
684 | 'compiled-function)))) |
---|
685 | ((eq type 'lock) |
---|
686 | (or (uvref thing ppc64::lock.kind-cell) |
---|
687 | type)) |
---|
688 | (t type)))) |
---|
689 | (t 'immediate)))))))) |
---|
690 | );#+ppc64-target |
---|
691 | |
---|
692 | |
---|
693 | |
---|
694 | #+x8664-target |
---|
695 | (progn |
---|
696 | (defparameter *nodeheader-0-types* |
---|
697 | #(bogus |
---|
698 | symbol-vector |
---|
699 | catch-frame |
---|
700 | hash-vector |
---|
701 | pool |
---|
702 | population |
---|
703 | package |
---|
704 | slot-vector |
---|
705 | basic-stream |
---|
706 | function-vector ;8 |
---|
707 | array-header |
---|
708 | bogus |
---|
709 | bogus |
---|
710 | bogus |
---|
711 | bogus |
---|
712 | bogus |
---|
713 | )) |
---|
714 | |
---|
715 | (defparameter *nodeheader-1-types* |
---|
716 | #(bogus |
---|
717 | ratio |
---|
718 | complex |
---|
719 | structure |
---|
720 | istruct |
---|
721 | value-cell |
---|
722 | xfunction |
---|
723 | lock |
---|
724 | instance |
---|
725 | bogus |
---|
726 | vector-header |
---|
727 | simple-vector |
---|
728 | bogus |
---|
729 | bogus |
---|
730 | bogus |
---|
731 | bogus |
---|
732 | )) |
---|
733 | |
---|
734 | (defparameter *immheader-0-types* |
---|
735 | #(bogus |
---|
736 | bogus |
---|
737 | bogus |
---|
738 | bogus |
---|
739 | bogus |
---|
740 | bogus |
---|
741 | bogus |
---|
742 | bogus |
---|
743 | bogus |
---|
744 | bogus |
---|
745 | simple-signed-word-vector |
---|
746 | simple-unsigned-word-vector |
---|
747 | bogus |
---|
748 | simple-signed-byte-vector |
---|
749 | simple-unsigned-byte-vector |
---|
750 | bit-vector)) |
---|
751 | |
---|
752 | (defparameter *immheader-1-types* |
---|
753 | #(bogus |
---|
754 | bignum |
---|
755 | double-float |
---|
756 | xcode-vector |
---|
757 | bogus |
---|
758 | bogus |
---|
759 | bogus |
---|
760 | bogus |
---|
761 | bogus |
---|
762 | bogus |
---|
763 | bogus |
---|
764 | bogus |
---|
765 | simple-base-string |
---|
766 | simple-signed-long-vector |
---|
767 | simple-unsigned-long-vector |
---|
768 | single-float-vector)) |
---|
769 | |
---|
770 | (defparameter *immheader-2-types* |
---|
771 | #(bogus |
---|
772 | macptr |
---|
773 | dead-macptr |
---|
774 | bogus |
---|
775 | bogus |
---|
776 | bogus |
---|
777 | bogus |
---|
778 | bogus |
---|
779 | bogus |
---|
780 | bogus |
---|
781 | bogus |
---|
782 | bogus |
---|
783 | simple-fixnum-vector |
---|
784 | simple-signed-doubleword-vector |
---|
785 | simple-unsigned-doubleword-vector |
---|
786 | double-float-vector)) |
---|
787 | |
---|
788 | |
---|
789 | (defparameter *x8664-%type-of-functions* nil) |
---|
790 | |
---|
791 | (let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum)) |
---|
792 | (tra (lambda (x) (declare (ignore x)) 'tagged-return-address)) |
---|
793 | (bogus (lambda (x) (declare (ignore x)) 'bogus))) |
---|
794 | (setq *x8664-%type-of-functions* |
---|
795 | (vector |
---|
796 | fixnum ;0 |
---|
797 | (lambda (x) (declare (ignore x)) 'short-float) ;1 |
---|
798 | (lambda (x) (if (characterp x) 'character 'immediate)) ;2 |
---|
799 | (lambda (x) (declare (ignore x)) 'cons) ;3 |
---|
800 | tra ;4 |
---|
801 | bogus ;5 |
---|
802 | bogus ;6 |
---|
803 | bogus ;7 |
---|
804 | fixnum ;8 |
---|
805 | bogus ;9 |
---|
806 | bogus ;10 |
---|
807 | (lambda (x) (declare (ignore x)) 'null) ;11 |
---|
808 | tra ;12 |
---|
809 | (lambda (x) (let* ((typecode (typecode x)) |
---|
810 | (low4 (logand typecode x8664::fulltagmask)) |
---|
811 | (high4 (ash typecode (- x8664::ntagbits)))) |
---|
812 | (declare (type (unsigned-byte 8) typecode) |
---|
813 | (type (unsigned-byte 4) low4 high4)) |
---|
814 | (let* ((name |
---|
815 | (cond ((= low4 x8664::fulltag-immheader-0) |
---|
816 | (%svref *immheader-0-types* high4)) |
---|
817 | ((= low4 x8664::fulltag-immheader-1) |
---|
818 | (%svref *immheader-1-types* high4)) |
---|
819 | ((= low4 x8664::fulltag-immheader-2) |
---|
820 | (%svref *immheader-2-types* high4)) |
---|
821 | ((= low4 x8664::fulltag-nodeheader-0) |
---|
822 | (%svref *nodeheader-0-types* high4)) |
---|
823 | ((= low4 x8664::fulltag-nodeheader-1) |
---|
824 | (%svref *nodeheader-1-types* high4)) |
---|
825 | (t 'bogus)))) |
---|
826 | (or (and (eq name 'lock) |
---|
827 | (uvref x x8664::lock.kind-cell)) |
---|
828 | name)))) ;13 |
---|
829 | (lambda (x) (declare (ignore x)) 'symbol) ;14 |
---|
830 | (lambda (thing) |
---|
831 | (let ((bits (lfun-bits thing))) |
---|
832 | (declare (fixnum bits)) |
---|
833 | (if (logbitp $lfbits-trampoline-bit bits) |
---|
834 | (let ((inner-fn (closure-function thing))) |
---|
835 | (if (neq inner-fn thing) |
---|
836 | (let ((inner-bits (lfun-bits inner-fn))) |
---|
837 | (if (logbitp $lfbits-method-bit inner-bits) |
---|
838 | 'compiled-lexical-closure |
---|
839 | (if (logbitp $lfbits-gfn-bit inner-bits) |
---|
840 | 'standard-generic-function ; not precisely - see class-of |
---|
841 | (if (logbitp $lfbits-cm-bit inner-bits) |
---|
842 | 'combined-method |
---|
843 | 'compiled-lexical-closure)))) |
---|
844 | 'compiled-lexical-closure)) |
---|
845 | (if (logbitp $lfbits-method-bit bits) |
---|
846 | 'method-function |
---|
847 | 'compiled-function))))))) ;15 |
---|
848 | |
---|
849 | |
---|
850 | |
---|
851 | |
---|
852 | |
---|
853 | (defun %type-of (thing) |
---|
854 | (let* ((f (fulltag thing))) |
---|
855 | (funcall (%svref *x8664-%type-of-functions* f) thing))) |
---|
856 | |
---|
857 | |
---|
858 | |
---|
859 | );#+x8664-target |
---|
860 | |
---|
861 | |
---|
862 | ;;; real machine specific huh |
---|
863 | (defun consp (x) |
---|
864 | "Return true if OBJECT is a CONS, and NIL otherwise." |
---|
865 | (consp x)) |
---|
866 | |
---|
867 | (defun characterp (arg) |
---|
868 | "Return true if OBJECT is a CHARACTER, and NIL otherwise." |
---|
869 | (characterp arg)) |
---|
870 | |
---|
871 | (defun base-char-p (c) |
---|
872 | (base-char-p c)) |
---|
873 | |
---|
874 | |
---|
875 | |
---|
876 | |
---|
877 | (defun structurep (form) |
---|
878 | "True if the given object is a named structure, Nil otherwise." |
---|
879 | (= (the fixnum (typecode form)) target::subtag-struct)) |
---|
880 | |
---|
881 | (defun istructp (form) |
---|
882 | (= (the fixnum (typecode form)) target::subtag-istruct)) |
---|
883 | |
---|
884 | (defun structure-typep (thing type) |
---|
885 | (if (= (the fixnum (typecode thing)) target::subtag-struct) |
---|
886 | (if (memq type (%svref thing 0)) |
---|
887 | t))) |
---|
888 | |
---|
889 | |
---|
890 | (defun istruct-typep (thing type) |
---|
891 | (if (= (the fixnum (typecode thing)) target::subtag-istruct) |
---|
892 | (eq (%svref thing 0) type))) |
---|
893 | |
---|
894 | (defun symbolp (thing) |
---|
895 | "Return true if OBJECT is a SYMBOL, and NIL otherwise." |
---|
896 | #+ppc32-target |
---|
897 | (if thing |
---|
898 | (= (the fixnum (typecode thing)) ppc32::subtag-symbol) |
---|
899 | t) |
---|
900 | #+ppc64-target |
---|
901 | (= (the fixnum (typecode thing)) ppc64::subtag-symbol) |
---|
902 | #+x8664-target |
---|
903 | (if thing |
---|
904 | (= (the fixnum (lisptag thing)) x8664::tag-symbol) |
---|
905 | t) |
---|
906 | ) |
---|
907 | |
---|
908 | (defun packagep (thing) |
---|
909 | (= (the fixnum (typecode thing)) target::subtag-package)) |
---|
910 | |
---|
911 | ;;; 1 if by land, 2 if by sea. |
---|
912 | (defun sequence-type (x) |
---|
913 | (unless (>= (the fixnum (typecode x)) target::min-vector-subtag) |
---|
914 | (or (listp x) |
---|
915 | (report-bad-arg x 'sequence)))) |
---|
916 | |
---|
917 | (defun uvectorp (x) |
---|
918 | (= (the fixnum (fulltag x)) target::fulltag-misc)) |
---|
919 | |
---|
920 | (setf (type-predicate 'uvector) 'uvectorp) |
---|
921 | |
---|
922 | (defun listp (x) |
---|
923 | (listp x)) |
---|