source: trunk/source/level-0/l0-pred.lisp @ 10159

Last change on this file since 10159 was 10159, checked in by rme, 11 years ago

Conditionalize for x8632 (note that x8632 follows the ppc32 tagging
scheme except for NIL).

%TYPE-OF for x8632.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.3 KB
Line 
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        #+(or ppc32-target x8632-target)
95        (and (>= typecode target::min-numeric-subtag)
96             (<= typecode target::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    #+(or ppc32-target x8632-target)
120    (or (= typecode target::tag-fixnum)
121        (and (>= typecode target::min-numeric-subtag)
122             (<= typecode target::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    #+(or ppc32-target x8632-target)
149    (or (= typecode target::tag-fixnum)
150        (and (>= typecode target::min-numeric-subtag)
151             (<= typecode target::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  #+(or ppc32-target x8632-target)
228  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::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  #+(or ppc32-target x8632-target)
243  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask))
244     target::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 x8632-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#+x8632-target
694(progn
695(defparameter *nodeheader-types*
696  #(bogus                               ; 0
697    ratio                               ; 1
698    bogus                               ; 2
699    complex                             ; 3
700    catch-frame                         ; 4
701    function                            ; 5
702    lisp-thread                         ; 6 (basic-stream?)
703    symbol                              ; 7
704    lock                                ; 8
705    hash-table-vector                   ; 9
706    pool                                ; 10
707    population                          ; 11 (weak?)
708    package                             ; 12
709    slot-vector                         ; 13
710    standard-instance                   ; 14
711    structure                           ; 15
712    internal-structure                  ; 16
713    value-cell                          ; 17
714    xfunction                           ; 18
715    array-header                        ; 19
716    vector-header                       ; 20
717    simple-vector                       ; 21
718    bogus                               ; 22
719    bogus                               ; 23
720    bogus                               ; 24
721    bogus                               ; 25
722    bogus                               ; 26
723    bogus                               ; 27
724    bogus                               ; 28
725    bogus                               ; 29
726    bogus                               ; 30
727    bogus                               ; 31
728    ))
729
730
731(defparameter *immheader-types*
732  #(bignum                              ; 0
733    short-float                         ; 1
734    double-float                        ; 2
735    macptr                              ; 3
736    dead-macptr                         ; 4
737    code-vector                         ; 5
738    creole-object                       ; 6
739    ;; 8-19 are unused
740    xcode-vector                        ; 7
741    bogus                               ; 8
742    bogus                               ; 9
743    bogus                               ; 10
744    bogus                               ; 11
745    bogus                               ; 12
746    bogus                               ; 13
747    bogus                               ; 14
748    bogus                               ; 15
749    bogus                               ; 16
750    bogus                               ; 17
751    bogus                               ; 18
752    bogus                               ; 19
753    simple-short-float-vector           ; 20
754    simple-unsigned-long-vector         ; 21
755    simple-signed-long-vector           ; 22
756    simple-fixnum-vector                ; 23
757    simple-base-string                  ; 24
758    simple-unsigned-byte-vector         ; 25
759    simple-signed-byte-vector           ; 26
760    bogus                               ; 27
761    simple-unsigned-word-vector         ; 28
762    simple-signed-word-vector           ; 29
763    simple-double-float-vector          ; 30
764    simple-bit-vector                   ; 31
765    ))
766
767(defun %type-of (thing)
768  (let* ((typecode (typecode thing)))
769    (declare (fixnum typecode))
770    (if (= typecode x8632::tag-fixnum)
771      'fixnum
772      (if (= typecode x8632::tag-list)  ;a misnomer on x8632...
773        (if (= typecode x8632::fulltag-cons)
774          (if thing 'cons 'null)
775          'tagged-return-address)
776        (if (= typecode x8632::tag-imm)
777          (if (base-char-p thing)
778            'base-char
779            'immediate)
780          (if (= typecode x8632::subtag-macptr)
781            (if (classp thing)
782              (class-name thing)
783              'macptr)
784            (let* ((tag-type (logand typecode x8632::fulltagmask))
785                   (tag-val (ash typecode (- x8632::ntagbits))))
786              (declare (fixnum tag-type tag-val))
787              (if (/= tag-type x8632::fulltag-nodeheader)
788                (%svref *immheader-types* tag-val)
789                (let ((type (%svref *nodeheader-types* tag-val)))
790                  (if (eq type 'function)
791                    (let ((bits (lfun-bits thing)))
792                      (declare (fixnum bits))
793                      (if (logbitp $lfbits-trampoline-bit bits)
794                        (let ((inner-fn (closure-function thing)))
795                          (if (neq inner-fn thing)
796                            (let ((inner-bits (lfun-bits inner-fn)))
797                              (if (logbitp $lfbits-method-bit inner-bits)
798                                'compiled-lexical-closure
799                                (if (logbitp $lfbits-gfn-bit inner-bits)
800                                  'standard-generic-function ; not precisely - see class-of
801                                  (if (logbitp  $lfbits-cm-bit inner-bits)
802                                    'combined-method
803                                    'compiled-lexical-closure))))
804                            'compiled-lexical-closure))
805                        (if (logbitp  $lfbits-method-bit bits)
806                          'method-function         
807                          'compiled-function)))
808                    (if (eq type 'lock)
809                      (or (uvref thing x8632::lock.kind-cell)
810                          type)
811                      type)))))))))))
812
813) ;x8632-target
814
815#+x8664-target
816(progn
817(defparameter *nodeheader-0-types*
818  #(bogus
819    symbol-vector
820    catch-frame
821    hash-vector
822    pool
823    population
824    package
825    slot-vector
826    basic-stream
827    function-vector                                        ;8
828    array-header
829    bogus
830    bogus
831    bogus
832    bogus
833    bogus
834    ))
835
836(defparameter *nodeheader-1-types*
837  #(bogus
838    ratio
839    complex
840    structure
841    istruct
842    value-cell
843    xfunction
844    lock
845    instance
846    bogus
847    vector-header
848    simple-vector
849    bogus
850    bogus
851    bogus
852    bogus
853    ))
854
855(defparameter *immheader-0-types*
856  #(bogus
857    bogus
858    bogus
859    bogus
860    bogus
861    bogus
862    bogus
863    bogus
864    bogus
865    bogus
866    simple-signed-word-vector
867    simple-unsigned-word-vector
868    bogus
869    simple-signed-byte-vector
870    simple-unsigned-byte-vector
871    bit-vector))
872
873(defparameter *immheader-1-types*
874  #(bogus
875    bignum
876    double-float
877    xcode-vector
878    bogus
879    bogus
880    bogus
881    bogus
882    bogus
883    bogus
884    bogus
885    bogus
886    simple-base-string
887    simple-signed-long-vector
888    simple-unsigned-long-vector
889    single-float-vector))
890
891(defparameter *immheader-2-types*
892  #(bogus
893    macptr
894    dead-macptr
895    bogus
896    bogus
897    bogus
898    bogus
899    bogus
900    bogus
901    bogus
902    bogus
903    bogus
904    simple-fixnum-vector
905    simple-signed-doubleword-vector
906    simple-unsigned-doubleword-vector
907    double-float-vector))
908
909
910(defparameter *x8664-%type-of-functions* nil)
911
912(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum))
913       (tra (lambda (x) (declare (ignore x)) 'tagged-return-address))
914       (bogus (lambda (x) (declare (ignore x)) 'bogus)))
915  (setq *x8664-%type-of-functions*
916        (vector
917         fixnum                         ;0
918         (lambda (x) (declare (ignore x)) 'short-float) ;1
919         (lambda (x) (if (characterp x) 'character 'immediate)) ;2
920         (lambda (x) (declare (ignore x)) 'cons) ;3
921         tra                            ;4
922         bogus                          ;5
923         bogus                          ;6
924         bogus                          ;7
925         fixnum                         ;8
926         bogus                          ;9
927         bogus                          ;10
928         (lambda (x) (declare (ignore x)) 'null) ;11
929         tra                            ;12
930         (lambda (x) (let* ((typecode (typecode x)) 
931                            (low4 (logand typecode x8664::fulltagmask))
932                            (high4 (ash typecode (- x8664::ntagbits))))
933                       (declare (type (unsigned-byte 8) typecode)
934                                (type (unsigned-byte 4) low4 high4))
935                       (let* ((name
936                               (cond ((= low4 x8664::fulltag-immheader-0)
937                                      (%svref *immheader-0-types* high4))
938                                     ((= low4 x8664::fulltag-immheader-1)
939                                      (%svref *immheader-1-types* high4))
940                                     ((= low4 x8664::fulltag-immheader-2)
941                                      (%svref *immheader-2-types* high4))
942                                     ((= low4 x8664::fulltag-nodeheader-0)
943                                      (%svref *nodeheader-0-types* high4))
944                                     ((= low4 x8664::fulltag-nodeheader-1)
945                                      (%svref *nodeheader-1-types* high4))
946                                     (t 'bogus))))
947                         (or (and (eq name 'lock)
948                                  (uvref x x8664::lock.kind-cell))
949                             name)))) ;13
950         (lambda (x) (declare (ignore x)) 'symbol) ;14
951         (lambda (thing)
952           (let ((bits (lfun-bits thing)))
953             (declare (fixnum bits))
954             (if (logbitp $lfbits-trampoline-bit bits)
955               (let ((inner-fn (closure-function thing)))
956                 (if (neq inner-fn thing)
957                   (let ((inner-bits (lfun-bits inner-fn)))
958                     (if (logbitp $lfbits-method-bit inner-bits)
959                       'compiled-lexical-closure
960                       (if (logbitp $lfbits-gfn-bit inner-bits)
961                         'standard-generic-function ; not precisely - see class-of
962                         (if (logbitp  $lfbits-cm-bit inner-bits)
963                           'combined-method
964                           'compiled-lexical-closure))))
965                   'compiled-lexical-closure))
966               (if (logbitp  $lfbits-method-bit bits)
967                 'method-function         
968                 'compiled-function))))))) ;15
969                                     
970       
971
972
973 
974(defun %type-of (thing)
975  (let* ((f (fulltag thing)))
976    (funcall (%svref *x8664-%type-of-functions* f) thing)))
977
978       
979
980);#+x8664-target
981     
982
983;;; real machine specific huh
984(defun consp (x)
985  "Return true if OBJECT is a CONS, and NIL otherwise."
986  (consp x))
987
988(defun characterp (arg)
989  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
990  (characterp arg))
991
992(defun base-char-p (c)
993  (base-char-p c))
994
995
996
997
998(defun structurep (form)
999  "True if the given object is a named structure, Nil otherwise."
1000  (= (the fixnum (typecode form)) target::subtag-struct))
1001
1002(defun istructp (form)
1003  (= (the fixnum (typecode form)) target::subtag-istruct))
1004
1005(defun structure-typep (thing type)
1006  (if (= (the fixnum (typecode thing)) target::subtag-struct)
1007    (if (memq type (%svref thing 0))
1008      t)))
1009
1010
1011(defun istruct-typep (thing type)
1012  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1013    (eq (%svref thing 0) type)))
1014
1015(defun symbolp (thing)
1016  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
1017  #+(or ppc32-target x8632-target)
1018  (if thing
1019    (= (the fixnum (typecode thing)) target::subtag-symbol)
1020    t)
1021  #+ppc64-target
1022  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
1023  #+x8664-target
1024  (if thing
1025    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
1026    t)
1027  )
1028     
1029(defun packagep (thing)
1030  (= (the fixnum (typecode thing)) target::subtag-package))
1031
1032;;; 1 if by land, 2 if by sea.
1033(defun sequence-type (x)
1034  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
1035    (or (listp x)
1036        (report-bad-arg x 'sequence))))
1037
1038(defun uvectorp (x)
1039  (= (the fixnum (fulltag x)) target::fulltag-misc))
1040
1041(setf (type-predicate 'uvector) 'uvectorp)
1042
1043(defun listp (x)
1044  (listp x))
Note: See TracBrowser for help on using the repository browser.