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

Last change on this file since 3838 was 3838, checked in by gb, 14 years ago

Do %TYPE-OF for x8664.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.2 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  (cons type nil))
31
32(defun builtin-typep (form cell)
33  (typep form (car cell)))
34
35(defun class-cell-typep (arg class-cell)
36  (typep arg (car 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 (cdr class-cell)))
42    (or class 
43        (if  (fboundp 'find-class)
44          (find-class (car 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::nbits-in-word)
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
221;;; Note that this is true of symbols and functions and many other
222;;; things that it wasn't true of on the 68K.
223(defun gvectorp (x)
224  #+ppc32-target
225  (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::fulltag-nodeheader)
226  #+ppc64-target
227  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader)
228  #+x8664-target
229  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
230    (declare (fixnum fulltag))
231    (or (= fulltag x8664::fulltag-nodeheader-0)
232        (= fulltag x8664::fulltag-nodeheader-1)))
233  )
234
235
236(setf (type-predicate 'gvector) 'gvectorp)
237
238(defun ivectorp (x)
239  #+ppc32-target
240    (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask))
241       ppc32::fulltag-immheader)
242  #+ppc64-target
243  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader)
244  #+x8664-target
245  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
246    (declare (fixnum fulltag))
247    (or (= fulltag x8664::fulltag-immheader-0)
248        (= fulltag x8664::fulltag-immheader-1)
249        (= fulltag x8664::fulltag-immheader-2)))
250  )
251
252(setf (type-predicate 'ivector) 'ivectorp)
253
254(defun miscobjp (x)
255  #+(or ppc32-target x8664-target)
256  (= (the fixnum (lisptag x)) target::tag-misc)
257  #+ppc64-target
258  (= (the fixnum (fulltag x)) ppc64::fulltag-misc)
259  )
260
261(defun simple-vector-p (x)
262  "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise."
263  (= (the fixnum (typecode x)) target::subtag-simple-vector))
264
265(defun base-string-p (thing)
266  (let* ((typecode (typecode thing)))
267    (declare (fixnum typecode))
268    (or (= typecode target::subtag-simple-base-string)
269        (and (= typecode target::subtag-vectorh)
270             (= (the fixnum 
271                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
272                target::subtag-simple-base-string)))))
273
274(defun simple-bit-vector-p (form)
275  "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise."
276  (= (the fixnum (typecode form)) target::subtag-bit-vector))
277
278(defun bit-vector-p (thing)
279  "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise."
280  (let* ((typecode (typecode thing)))
281    (declare (fixnum typecode))
282    (or (= typecode target::subtag-bit-vector)
283        (and (= typecode target::subtag-vectorh)
284             (= (the fixnum 
285                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
286                target::subtag-bit-vector)))))
287
288(defun displaced-array-p (array)
289  (if (%array-is-header array)
290    (do* ((disp (%svref array target::arrayH.displacement-cell)
291                (+ disp (the fixnum (%svref target target::arrayH.displacement-cell))))
292          (target (%svref array target::arrayH.data-vector-cell)
293                  (%svref target target::arrayH.data-vector-cell)))
294         ((not (%array-is-header target))
295          (values target disp)))
296    (values nil 0)))
297
298
299
300(defun eq (x y)
301  "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
302  (eq x y))
303
304
305(defun cons-equal (x y)
306  (declare (cons x y))
307  (if (equal (car x) (car y))
308    (equal (cdr x) (cdr y))))
309
310(defun hairy-equal (x y)
311  (declare (optimize (speed 3)))
312  ;; X and Y are not EQL, and are both of tag target::fulltag-misc.
313  (let* ((x-type (typecode x))
314         (y-type (typecode y)))
315    (declare (fixnum x-type y-type))
316    (if (and (>= x-type target::subtag-vectorH)
317             (>= y-type target::subtag-vectorH))
318        (let* ((x-simple (if (= x-type target::subtag-vectorH)
319                             (ldb target::arrayH.flags-cell-subtag-byte 
320                                  (the fixnum (%svref x target::arrayH.flags-cell)))
321                             x-type))
322               (y-simple (if (= y-type target::subtag-vectorH)
323                             (ldb target::arrayH.flags-cell-subtag-byte 
324                                  (the fixnum (%svref y target::arrayH.flags-cell)))
325                             y-type)))
326          (declare (fixnum x-simple y-simple))
327          (if (= x-simple target::subtag-simple-base-string)
328              (if (= y-simple target::subtag-simple-base-string)
329                  (locally
330                      (declare (optimize (speed 3) (safety 0)))
331                    (let* ((x-len (if (= x-type target::subtag-vectorH) 
332                                      (%svref x target::vectorH.logsize-cell)
333                                      (uvsize x)))
334                           (x-pos 0)
335                           (y-len (if (= y-type target::subtag-vectorH) 
336                                      (%svref y target::vectorH.logsize-cell)
337                                      (uvsize y)))
338                           (y-pos 0))
339                      (declare (fixnum x-len x-pos y-len y-pos))
340                      (when (= x-type target::subtag-vectorH)
341                        (multiple-value-setq (x x-pos) (array-data-and-offset x)))
342                      (when (= y-type target::subtag-vectorH)
343                        (multiple-value-setq (y y-pos) (array-data-and-offset y)))
344                      (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len))))))
345              ;;Bit-vector case or fail.
346              (and (= x-simple target::subtag-bit-vector)
347                   (= y-simple target::subtag-bit-vector)
348                   (locally
349                       (declare (optimize (speed 3) (safety 0)))
350                     (let* ((x-len (if (= x-type target::subtag-vectorH) 
351                                       (%svref x target::vectorH.logsize-cell)
352                                       (uvsize x)))
353                            (x-pos 0)
354                            (y-len (if (= y-type target::subtag-vectorH) 
355                                       (%svref y target::vectorH.logsize-cell)
356                                       (uvsize y)))
357                            (y-pos 0))
358                       (declare (fixnum x-len x-pos y-len y-pos))
359                       (when (= x-len y-len)
360                         (when (= x-type target::subtag-vectorH)
361                           (multiple-value-setq (x x-pos) (array-data-and-offset x)))
362                         (when (= y-type target::subtag-vectorH)
363                           (multiple-value-setq (y y-pos) (array-data-and-offset y)))
364                         (do* ((i 0 (1+ i)))
365                              ((= i x-len) t)
366                           (declare (fixnum i))
367                           (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos)))
368                             (return))
369                           (incf x-pos)
370                           (incf y-pos))))))))
371        (if (= x-type y-type)
372            (if (= x-type target::subtag-istruct)
373                (and (let* ((structname (%svref x 0)))
374                       (and (eq structname (%svref y 0))
375                            (or (eq structname 'pathname)
376                                (eq structname 'logical-pathname))))
377                     (locally
378                         (declare (optimize (speed 3) (safety 0)))
379                       (let* ((x-size (uvsize x)))
380                         (declare (fixnum x-size))
381                         (if (= x-size (the fixnum (uvsize y)))
382                             (do* ((i 1 (1+ i)))
383                                  ((= i x-size) t)
384                               (declare (fixnum i))
385                               (unless (equal (%svref x i) (%svref y i))
386                                 (return))))))))))))
387
388#+ppc32-target
389(progn
390(defparameter *nodeheader-types*
391  #(bogus                               ; 0
392    ratio                               ; 1
393    bogus                               ; 2
394    complex                             ; 3
395    catch-frame                         ; 4
396    function                            ; 5
397    lisp-thread                         ; 6
398    symbol                              ; 7
399    lock                                ; 8
400    hash-table-vector                   ; 9
401    pool                                ; 10
402    population                          ; 11
403    package                             ; 12
404    slot-vector                         ; 13
405    standard-instance                   ; 14
406    structure                           ; 15
407    internal-structure                  ; 16
408    value-cell                          ; 17
409    xfunction                           ; 18
410    bogus                               ; 19
411    array-header                        ; 20
412    vector-header                       ; 21
413    simple-vector                       ; 22
414    bogus                               ; 23
415    bogus                               ; 24
416    bogus                               ; 25
417    bogus                               ; 26
418    bogus                               ; 27
419    bogus                               ; 28
420    bogus                               ; 29
421    bogus                               ; 30
422    bogus                               ; 31
423    ))
424
425
426(defparameter *immheader-types*
427  #(bignum                              ; 0
428    short-float                         ; 1
429    double-float                        ; 2
430    macptr                              ; 3
431    dead-macptr                         ; 4
432    code-vector                         ; 5
433    creole-object                       ; 6
434    ;; 8-20 are unused
435    xcode-vector                        ; 7
436    bogus                               ; 8
437    bogus                               ; 9
438    bogus                               ; 10
439    bogus                               ; 11
440    bogus                               ; 12
441    bogus                               ; 13
442    bogus                               ; 14
443    bogus                               ; 15
444    bogus                               ; 16
445    bogus                               ; 17
446    bogus                               ; 18
447    bogus                               ; 19
448    bogus                               ; 20
449    simple-short-float-vector           ; 21
450    simple-unsigned-long-vector         ; 22
451    simple-signed-long-vector           ; 23
452    simple-unsigned-byte-vector         ; 24
453    simple-signed-byte-vector           ; 25
454    simple-base-string                  ; 26
455    bogus                               ; 27
456    simple-unsigned-word-vector         ; 28
457    simple-signed-word-vector           ; 29
458    simple-double-float-vector          ; 30
459    simple-bit-vector                   ; 31
460    ))
461
462(defun %type-of (thing)
463  (let* ((typecode (typecode thing)))
464    (declare (fixnum typecode))
465    (if (= typecode ppc32::tag-fixnum)
466      'fixnum
467      (if (= typecode ppc32::tag-list)
468        (if thing 'cons 'null)
469        (if (= typecode ppc32::tag-imm)
470          (if (base-char-p thing)
471            'base-char
472            'immediate)
473          (if (= typecode ppc32::subtag-macptr)
474            (if (classp thing)
475              (class-name thing)
476              'macptr)
477            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
478                   (tag-val (ash typecode (- ppc32::ntagbits))))
479              (declare (fixnum tag-type tag-val))
480              (if (/= tag-type ppc32::fulltag-nodeheader)
481                (%svref *immheader-types* tag-val)
482                (let ((type (%svref *nodeheader-types* tag-val)))
483                  (if (eq type 'function)
484                    (let ((bits (lfun-bits thing)))
485                      (declare (fixnum bits))
486                      (if (logbitp $lfbits-trampoline-bit bits)
487                        (if (logbitp $lfbits-evaluated-bit bits)
488                          'interpreted-lexical-closure
489                          (let ((inner-fn (closure-function thing)))
490                            (if (neq inner-fn thing)
491                              (let ((inner-bits (lfun-bits inner-fn)))
492                                (if (logbitp $lfbits-method-bit inner-bits)
493                                  'compiled-lexical-closure
494                                  (if (logbitp $lfbits-gfn-bit inner-bits)
495                                    'standard-generic-function ; not precisely - see class-of
496                                    (if (logbitp  $lfbits-cm-bit inner-bits)
497                                      'combined-method
498                                      'compiled-lexical-closure))))
499                              'compiled-lexical-closure)))
500                        (if (logbitp $lfbits-evaluated-bit bits)
501                          (if (logbitp $lfbits-method-bit bits)
502                            'interpreted-method-function
503                            'interpreted-function)
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    bogus
565    bogus
566    bogus
567    bogus
568    simple-double-float-vector
569    simple-base-string
570    bogus
571    bogus
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      lisp-thread
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                                     (if (logbitp $lfbits-evaluated-bit bits)
672                                       'interpreted-lexical-closure
673                                       (let ((inner-fn (closure-function thing)))
674                                         (if (neq inner-fn thing)
675                                           (let ((inner-bits (lfun-bits inner-fn)))
676                                             (if (logbitp $lfbits-method-bit inner-bits)
677                                               'compiled-lexical-closure
678                                               (if (logbitp $lfbits-gfn-bit inner-bits)
679                                                 'standard-generic-function ; not precisely - see class-of
680                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
681                                                   'combined-method
682                                                   'compiled-lexical-closure))))
683                                           'compiled-lexical-closure)))
684                                     (if (logbitp $lfbits-evaluated-bit bits)
685                                       (if (logbitp $lfbits-method-bit bits)
686                                         'interpreted-method-function
687                                         'interpreted-function)
688                                       (if (logbitp  $lfbits-method-bit bits)
689                                         'method-function         
690                                         'compiled-function)))))
691                                ((eq type 'lock)
692                                 (or (uvref thing ppc64::lock.kind-cell)
693                                     type))
694                                (t type))))
695                       (t 'immediate))))))))
696);#+ppc64-target
697
698
699
700#+x8664-target
701(progn
702(defparameter *nodeheader-0-types*
703  #(function-vector
704    symbol-vector
705    catch-frame
706    hash-vector
707    pool
708    population
709    package
710    slot-vector
711    lisp-thread                         ;8
712    vector-header
713    bogus
714    bogus
715    bogus
716    bogus
717    bogus
718    bogus
719    ))
720
721(defparameter *nodeheader-1-types*
722  #(ratio
723    complex
724    instance
725    struct
726    istruct
727    value-cell
728    xfunction
729    lock                                ;7
730    array-header
731    simple-vector
732    bogus
733    bogus
734    bogus
735    bogus
736    bogus
737    bogus
738    ))
739
740(defparameter *immheader-0-types*
741  #(bogus
742    bogus
743    bogus
744    bogus
745    bogus
746    bogus
747    bogus
748    bogus
749    bogus
750    bogus
751    simple-signed-word-vector
752    simple-unsigned-word-vector
753    simple-base-string
754    simple-signed-byte-vector
755    simple-unsigned-byte-vector
756    bit-vector))
757
758(defparameter *immheader-1-types*
759  #(bignum
760    double-float
761    xcode-vector
762    bogus
763    bogus
764    bogus
765    bogus
766    bogus
767    bogus
768    bogus
769    bogus
770    bogus
771    bogus
772    simple-signed-long-vector
773    simple-unsigned-long-vector
774    single-float-vector))
775
776(defparameter *immheader-2-types*
777  #(macptr
778    dead-macptr
779    bogus
780    bogus
781    bogus
782    bogus
783    bogus
784    bogus
785    bogus
786    bogus
787    bogus
788    bogus
789    bogus
790    simple-signed-doubleword-vector
791    simple-unsigned-doubleword-vector
792    double-float-vector))
793
794
795(defparameter *x8664-fulltag-types* ())
796(setq *x8664-fulltag-types*
797  (let* ((fixnums #16(fixnum))
798         (tra #16(tagged-return-address)))
799    (vector fixnums
800            #(single-float immediate immediate immediate
801              immediate immediate immediate immediate
802              immediate immediate immediate immediate
803              immediate immediate immediate immediate)
804            #(base-char immediate immediate immediate
805              immediate immediate immediate immediate
806              immediate immediate immediate immediate
807              immediate immediate immediate immediate)
808            #16(list)
809            tra
810            *nodeheader-0-types*
811            *nodeheader-1-types*
812            *immheader-0-types*
813            fixnums
814            *immheader-1-types*
815            *immheader-2-types*
816            #16(null)
817            tra
818            #16(bogus)
819            #16(symbol))))
820 
821(defun %type-of (thing)
822  (let* ((fulltag (fulltag thing))
823         (high4 (ash (the fixnum (%lisp-lowbyte-ref thing)) (- x8664::ntagbits))))
824    (declare (fixnum fulltag high4))
825    (if (= fulltag x8664::fulltag-function)
826      (let ((bits (lfun-bits thing)))
827        (declare (fixnum bits))
828        (if (logbitp $lfbits-trampoline-bit bits)
829          (if (logbitp $lfbits-evaluated-bit bits)
830            'interpreted-lexical-closure
831            (let ((inner-fn (closure-function thing)))
832              (if (neq inner-fn thing)
833                (let ((inner-bits (lfun-bits inner-fn)))
834                  (if (logbitp $lfbits-method-bit inner-bits)
835                    'compiled-lexical-closure
836                    (if (logbitp $lfbits-gfn-bit inner-bits)
837                      'standard-generic-function ; not precisely - see class-of
838                      (if (logbitp  $lfbits-cm-bit inner-bits)
839                        'combined-method
840                        'compiled-lexical-closure))))
841                'compiled-lexical-closure)))
842          (if (logbitp $lfbits-evaluated-bit bits)
843            (if (logbitp $lfbits-method-bit bits)
844              'interpreted-method-function
845              'interpreted-function)
846            (if (logbitp  $lfbits-method-bit bits)
847              'method-function         
848              'compiled-function))))
849      (%svref (%svref *x8664-fulltag-types* fulltag) high4))))
850
851);#+x8664-target
852     
853
854;;; real machine specific huh
855(defun consp (x)
856  "Return true if OBJECT is a CONS, and NIL otherwise."
857  (consp x))
858
859(defun characterp (arg)
860  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
861  (characterp arg))
862
863(defun base-char-p (c)
864  (base-char-p c))
865
866
867
868
869(defun structurep (form)
870  "True if the given object is a named structure, Nil otherwise."
871  (= (the fixnum (typecode form)) target::subtag-struct))
872
873(defun istructp (form)
874  (= (the fixnum (typecode form)) target::subtag-istruct))
875
876(defun structure-typep (thing type)
877  (if (= (the fixnum (typecode thing)) target::subtag-struct)
878    (if (memq type (%svref thing 0))
879      t)))
880
881
882(defun istruct-typep (thing type)
883  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
884    (eq (%svref thing 0) type)))
885
886(defun symbolp (thing)
887  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
888  #+ppc32-target
889  (if thing
890    (= (the fixnum (typecode thing)) ppc32::subtag-symbol)
891    t)
892  #+ppc64-target
893  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
894  #+x8664-target
895  (if thing
896    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
897    t)
898  )
899     
900(defun packagep (thing)
901  (= (the fixnum (typecode thing)) target::subtag-package))
902
903;;; 1 if by land, 2 if by sea.
904(defun sequence-type (x)
905  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
906    (or (listp x)
907        (report-bad-arg x 'sequence))))
908
909(defun uvectorp (x)
910  (= (the fixnum (fulltag x)) target::fulltag-misc))
911
912(setf (type-predicate 'uvector) 'uvectorp)
Note: See TracBrowser for help on using the repository browser.