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

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

%TYPE-OF for PPC64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.7 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
18;; Non-portable type-predicates & such.
19
20
21;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils
22
23(defun find-builtin-cell (type &optional create)
24  (declare (ignore create))
25  (cons type nil))
26
27(defun find-class-cell (type create?)
28  (declare (ignore create?))
29  (cons type nil))
30
31(defun builtin-typep (form cell)
32  (typep form (car cell)))
33
34(defun class-cell-typep (arg class-cell)
35  (typep arg (car class-cell)))
36
37(defun class-cell-find-class (class-cell errorp)
38  (declare (ignore errorp)) ; AARGH can't be right
39  ;(dbg-paws #x100)
40  (let ((class (cdr class-cell)))
41    (or class 
42        (if  (fboundp 'find-class)
43          (find-class (car class-cell) nil)))))
44
45(defun %require-type-builtin (form foo)
46  (declare (ignore foo))
47  form)
48
49(defun %require-type-class-cell (form cell)
50  (declare (ignore cell))
51  form)
52 
53(defun non-nil-symbol-p (x)
54  (if (symbolp x) x))
55
56(defun pathnamep (thing)
57  (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname)))
58
59(defun compiled-function-p (form)
60  "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise."
61  (and (functionp form)
62       (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form))))))
63
64;;; all characters are base-chars.
65(defun extended-char-p (c)
66  (declare (ignore c)))
67
68
69;;; Some of these things are probably open-coded.
70;;; The functions have to exist SOMEWHERE ...
71(defun fixnump (x)
72  (= (the fixnum (lisptag x)) target::tag-fixnum))
73
74(defun bignump (x)
75  (= (the fixnum (typecode x)) target::subtag-bignum))
76
77(defun integerp (x)
78  "Return true if OBJECT is an INTEGER, and NIL otherwise."
79  (let* ((typecode (typecode x)))
80    (declare (fixnum typecode))
81    (or (= typecode target::tag-fixnum)
82        (= typecode target::subtag-bignum))))
83
84(defun ratiop (x)
85  (= (the fixnum (typecode x)) target::subtag-ratio))
86
87
88(defun rationalp (x)
89  "Return true if OBJECT is a RATIONAL, and NIL otherwise."
90  (or (fixnump x)
91      (let* ((typecode (typecode x)))
92        (declare (fixnum typecode))
93        #+ppc32-target
94        (and (>= typecode ppc32::min-numeric-subtag)
95             (<= typecode ppc32::max-rational-subtag))
96        #+ppc64-target
97        (cond ((= typecode ppc64::subtag-bignum) t)
98              ((= typecode ppc64::subtag-ratio) t)))))
99
100(defun short-float-p (x)
101  (= (the fixnum (typecode x)) target::subtag-single-float))
102
103
104(defun double-float-p (x)
105  (= (the fixnum (typecode x)) target::subtag-double-float))
106
107(defun floatp (x)
108  "Return true if OBJECT is a FLOAT, and NIL otherwise."
109  (let* ((typecode (typecode x)))
110    (declare (fixnum typecode))
111    (or (= typecode target::subtag-single-float)
112        (= typecode target::subtag-double-float))))
113
114(defun realp (x)
115  "Return true if OBJECT is a REAL, and NIL otherwise."
116  (let* ((typecode (typecode x)))
117    (declare (fixnum typecode))
118    #+ppc32-target
119    (or (= typecode ppc32::tag-fixnum)
120        (and (>= typecode ppc32::min-numeric-subtag)
121             (<= typecode ppc32::max-real-subtag)))
122    #+ppc64-target
123    (cond ((= typecode ppc64::tag-fixnum) t)
124          ((= typecode ppc64::subtag-single-float) t)
125          ((= typecode ppc64::subtag-bignum) t)
126          ((= typecode ppc64::subtag-double-float) t)
127          ((= typecode ppc64::subtag-ratio) t))))
128
129(defun complexp (x)
130  "Return true if OBJECT is a COMPLEX, and NIL otherwise."
131  (= (the fixnum (typecode x)) target::subtag-complex))
132
133(defun numberp (x)
134  "Return true if OBJECT is a NUMBER, and NIL otherwise."
135  (let* ((typecode (typecode x)))
136    (declare (fixnum typecode))
137    #+ppc32-target
138    (or (= typecode ppc32::tag-fixnum)
139        (and (>= typecode ppc32::min-numeric-subtag)
140             (<= typecode ppc32::max-numeric-subtag)))
141    #+ppc64-target
142    (cond ((= typecode ppc64::tag-fixnum) t)
143          ((= typecode ppc64::subtag-single-float) t)
144          ((= typecode ppc64::subtag-bignum) t)
145          ((= typecode ppc64::subtag-double-float) t)
146          ((= typecode ppc64::subtag-ratio) t)
147          ((= typecode ppc64::subtag-complex t)))))
148
149(defun arrayp (x)
150  "Return true if OBJECT is an ARRAY, and NIL otherwise."
151  (>= (the fixnum (typecode x)) target::min-array-subtag))
152
153(defun vectorp (x)
154  "Return true if OBJECT is a VECTOR, and NIL otherwise."
155  (>= (the fixnum (typecode x)) target::min-vector-subtag))
156
157
158(defun stringp (x)
159  "Return true if OBJECT is a STRING, and NIL otherwise."
160  (let* ((typecode (typecode x)))
161    (declare (fixnum typecode))
162    (if (= typecode target::subtag-vectorH)
163      (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell)))))
164    (= typecode target::subtag-simple-base-string)))
165
166
167(defun simple-base-string-p (x)
168  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
169
170(defun simple-string-p (x)
171  "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise."
172  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
173
174(defun complex-array-p (x)
175  (let* ((typecode (typecode x)))
176    (declare (fixnum typecode))
177    (if (or (= typecode target::subtag-arrayH)
178            (= typecode target::subtag-vectorH))
179      (not (%array-header-simple-p x)))))
180
181(defun simple-array-p (thing)
182  "Returns T if the object is a simple array, else returns NIL.
183   That's why it's called SIMPLE-ARRAY-P.  Get it ?
184   A simple-array may have no fill-pointer, may not be displaced,
185   and may not be adjustable."
186  (let* ((typecode (typecode thing)))
187    (declare (fixnum typecode))
188    (if (or (= typecode target::subtag-arrayH)
189            (= typecode target::subtag-vectorH))
190      (%array-header-simple-p thing)
191      (> typecode target::subtag-vectorH))))
192
193(defun macptrp (x)
194  (= (the fixnum (typecode x)) target::subtag-macptr))
195
196
197;;; Note that this is true of symbols and functions and many other
198;;; things that it wasn't true of on the 68K.
199(defun gvectorp (x)
200  #+ppc32-target
201  (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::fulltag-nodeheader)
202  #+ppc64-target
203  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader))
204
205
206(setf (type-predicate 'gvector) 'gvectorp)
207
208(defun ivectorp (x)
209  #+ppc32-target
210    (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask))
211       ppc32::fulltag-immheader)
212  #+ppc64-target
213  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader))
214
215(setf (type-predicate 'ivector) 'ivectorp)
216
217(defun miscobjp (x)
218  #+ppc32-target
219  (= (the fixnum (lisptag x)) ppc32::tag-misc)
220  #+ppc64-target
221  (= (the fixnum (fulltag x)) ppc64::fulltag-misc)
222  )
223
224(defun simple-vector-p (x)
225  "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise."
226  (= (the fixnum (typecode x)) target::subtag-simple-vector))
227
228(defun base-string-p (thing)
229  (let* ((typecode (typecode thing)))
230    (declare (fixnum typecode))
231    (or (= typecode target::subtag-simple-base-string)
232        (and (= typecode target::subtag-vectorh)
233             (= (the fixnum 
234                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
235                target::subtag-simple-base-string)))))
236
237(defun simple-bit-vector-p (form)
238  "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise."
239  (= (the fixnum (typecode form)) target::subtag-bit-vector))
240
241(defun bit-vector-p (thing)
242  "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise."
243  (let* ((typecode (typecode thing)))
244    (declare (fixnum typecode))
245    (or (= typecode target::subtag-bit-vector)
246        (and (= typecode target::subtag-vectorh)
247             (= (the fixnum 
248                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
249                target::subtag-bit-vector)))))
250
251(defun displaced-array-p (array)
252  (if (%array-is-header array)
253    (do* ((disp (%svref array target::arrayH.displacement-cell)
254                (+ disp (the fixnum (%svref target target::arrayH.displacement-cell))))
255          (target (%svref array target::arrayH.data-vector-cell)
256                  (%svref target target::arrayH.data-vector-cell)))
257         ((not (%array-is-header target))
258          (values target disp)))
259    (values nil 0)))
260
261
262
263(defun eq (x y)
264  "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
265  (eq x y))
266
267
268(defun cons-equal (x y)
269  (declare (cons x y))
270  (if (equal (car x) (car y))
271    (equal (cdr x) (cdr y))))
272
273(defun hairy-equal (x y)
274  (declare (optimize (speed 3)))
275  ;; X and Y are not EQL, and are both of tag target::fulltag-misc.
276  (let* ((x-type (typecode x))
277         (y-type (typecode y)))
278    (declare (fixnum x-type y-type))
279    (if (and (>= x-type target::subtag-vectorH)
280             (>= y-type target::subtag-vectorH))
281        (let* ((x-simple (if (= x-type target::subtag-vectorH)
282                             (ldb target::arrayH.flags-cell-subtag-byte 
283                                  (the fixnum (%svref x target::arrayH.flags-cell)))
284                             x-type))
285               (y-simple (if (= y-type target::subtag-vectorH)
286                             (ldb target::arrayH.flags-cell-subtag-byte 
287                                  (the fixnum (%svref y target::arrayH.flags-cell)))
288                             y-type)))
289          (declare (fixnum x-simple y-simple))
290          (if (= x-simple target::subtag-simple-base-string)
291              (if (= y-simple target::subtag-simple-base-string)
292                  (locally
293                      (declare (optimize (speed 3) (safety 0)))
294                    (let* ((x-len (if (= x-type target::subtag-vectorH) 
295                                      (%svref x target::vectorH.logsize-cell)
296                                      (uvsize x)))
297                           (x-pos 0)
298                           (y-len (if (= y-type target::subtag-vectorH) 
299                                      (%svref y target::vectorH.logsize-cell)
300                                      (uvsize y)))
301                           (y-pos 0))
302                      (declare (fixnum x-len x-pos y-len y-pos))
303                      (when (= x-type target::subtag-vectorH)
304                        (multiple-value-setq (x x-pos) (array-data-and-offset x)))
305                      (when (= y-type target::subtag-vectorH)
306                        (multiple-value-setq (y y-pos) (array-data-and-offset y)))
307                      (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len))))))
308              ;;Bit-vector case or fail.
309              (and (= x-simple target::subtag-bit-vector)
310                   (= y-simple target::subtag-bit-vector)
311                   (locally
312                       (declare (optimize (speed 3) (safety 0)))
313                     (let* ((x-len (if (= x-type target::subtag-vectorH) 
314                                       (%svref x target::vectorH.logsize-cell)
315                                       (uvsize x)))
316                            (x-pos 0)
317                            (y-len (if (= y-type target::subtag-vectorH) 
318                                       (%svref y target::vectorH.logsize-cell)
319                                       (uvsize y)))
320                            (y-pos 0))
321                       (declare (fixnum x-len x-pos y-len y-pos))
322                       (when (= x-len y-len)
323                         (when (= x-type target::subtag-vectorH)
324                           (multiple-value-setq (x x-pos) (array-data-and-offset x)))
325                         (when (= y-type target::subtag-vectorH)
326                           (multiple-value-setq (y y-pos) (array-data-and-offset y)))
327                         (do* ((i 0 (1+ i)))
328                              ((= i x-len) t)
329                           (declare (fixnum i))
330                           (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos)))
331                             (return))
332                           (incf x-pos)
333                           (incf y-pos))))))))
334        (if (= x-type y-type)
335            (if (= x-type target::subtag-istruct)
336                (and (let* ((structname (%svref x 0)))
337                       (and (eq structname (%svref y 0))
338                            (or (eq structname 'pathname)
339                                (eq structname 'logical-pathname))))
340                     (locally
341                         (declare (optimize (speed 3) (safety 0)))
342                       (let* ((x-size (uvsize x)))
343                         (declare (fixnum x-size))
344                         (if (= x-size (the fixnum (uvsize y)))
345                             (do* ((i 1 (1+ i)))
346                                  ((= i x-size) t)
347                               (declare (fixnum i))
348                               (unless (equal (%svref x i) (%svref y i))
349                                 (return))))))))))))
350
351#+ppc32-target
352(defparameter *nodeheader-types*
353  #(bogus                               ; 0
354    ratio                               ; 1
355    bogus                               ; 2
356    complex                             ; 3
357    catch-frame                         ; 4
358    function                            ; 5
359    lisp-thread                         ; 6
360    symbol                              ; 7
361    lock                                ; 8
362    hash-table-vector                   ; 9
363    pool                                ; 10
364    population                          ; 11
365    package                             ; 12
366    slot-vector                         ; 13
367    standard-instance                   ; 14
368    structure                           ; 15
369    internal-structure                  ; 16
370    value-cell                          ; 17
371    xfunction                           ; 18
372    svar                                ; 19
373    array-header                        ; 20
374    vector-header                       ; 21
375    simple-vector                       ; 22
376    bogus                               ; 23
377    bogus                               ; 24
378    bogus                               ; 25
379    bogus                               ; 26
380    bogus                               ; 27
381    bogus                               ; 28
382    bogus                               ; 29
383    bogus                               ; 30
384    bogus                               ; 31
385    ))
386
387#+ppc32-target
388(defparameter *immheader-types*
389  #(bignum                              ; 0
390    short-float                         ; 1
391    double-float                        ; 2
392    macptr                              ; 3
393    dead-macptr                         ; 4
394    code-vector                         ; 5
395    creole-object                       ; 6
396    ;; 8-20 are unused
397    xcode-vector                        ; 7
398    bogus                               ; 8
399    bogus                               ; 9
400    bogus                               ; 10
401    bogus                               ; 11
402    bogus                               ; 12
403    bogus                               ; 13
404    bogus                               ; 14
405    bogus                               ; 15
406    bogus                               ; 16
407    bogus                               ; 17
408    bogus                               ; 18
409    bogus                               ; 19
410    bogus                               ; 20
411    simple-short-float-vector           ; 21
412    simple-unsigned-long-vector         ; 22
413    simple-signed-long-vector           ; 23
414    simple-unsigned-byte-vector         ; 24
415    simple-signed-byte-vector           ; 25
416    simple-base-string                  ; 26
417    bogus                               ; 27
418    simple-unsigned-word-vector         ; 28
419    simple-signed-word-vector           ; 29
420    simple-double-float-vector          ; 30
421    simple-bit-vector                   ; 31
422    ))
423
424
425
426
427#+ppc32-target
428(defun %type-of (thing)
429  (let* ((typecode (typecode thing)))
430    (declare (fixnum typecode))
431    (if (= typecode ppc32::tag-fixnum)
432      'fixnum
433      (if (= typecode ppc32::tag-list)
434        (if thing 'cons 'null)
435        (if (= typecode ppc32::tag-imm)
436          (if (base-char-p thing)
437            'base-char
438            'immediate)
439          (if (= typecode ppc32::subtag-macptr)
440            (if (classp thing)
441              (class-name thing)
442              'macptr)
443            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
444                   (tag-val (ash typecode (- ppc32::ntagbits))))
445              (declare (fixnum tag-type tag-val))
446              (if (/= tag-type ppc32::fulltag-nodeheader)
447                (%svref *immheader-types* tag-val)
448                (let ((type (%svref *nodeheader-types* tag-val)))
449                  (if (eq type 'function)
450                    (let ((bits (lfun-bits thing)))
451                      (declare (fixnum bits))
452                      (if (logbitp $lfbits-trampoline-bit bits)
453                        (if (logbitp $lfbits-evaluated-bit bits)
454                          'interpreted-lexical-closure
455                          (let ((inner-fn (closure-function thing)))
456                            (if (neq inner-fn thing)
457                              (let ((inner-bits (lfun-bits inner-fn)))
458                                (if (logbitp $lfbits-method-bit inner-bits)
459                                  'compiled-lexical-closure
460                                  (if (logbitp $lfbits-gfn-bit inner-bits)
461                                    'standard-generic-function ; not precisely - see class-of
462                                    (if (logbitp  $lfbits-cm-bit inner-bits)
463                                      'combined-method
464                                      'compiled-lexical-closure))))
465                              'compiled-lexical-closure)))
466                        (if (logbitp $lfbits-evaluated-bit bits)
467                          (if (logbitp $lfbits-method-bit bits)
468                            'interpreted-method-function
469                            'interpreted-function)
470                          (if (logbitp  $lfbits-method-bit bits)
471                            'method-function         
472                            'compiled-function))))
473                    (if (eq type 'lock)
474                      (or (uvref thing ppc32::lock.kind-cell)
475                          type)
476                      type)))))))))))
477
478#+ppc64-target
479(defparameter *immheader-types*
480  #(bogus
481    bogus
482    code-vector
483    bogus
484    bogus
485    bogus
486    xcode-vector
487    macptr
488    bogus
489    bogus
490    bignum
491    dead-macptr
492    bogus
493    bogus
494    double-float
495    bogus
496    bogus
497    bogus
498    bogus
499    bogus
500    bogus
501    bogus
502    bogus
503    bogus
504    bogus
505    bogus
506    bogus
507    bogus
508    bogus
509    bogus
510    bogus
511    bogus
512    bogus
513    bogus
514    bogus
515    bogus
516    simple-signed-byte-vector
517    simple-signed-word-vector
518    simple-signed-long-vector
519    simple-signed-doubleword-vector
520    simple-unsigned-byte-vector
521    simple-unsigned-word-vector
522    simple-unsigned-long-vector
523    simple-unsigned-doubleword-vector
524    bogus
525    bogus
526    simple-short-float-vector
527    bogus
528    bogus
529    bogus
530    bogus
531    simple-double-float-vector
532    simple-base-string
533    bogus
534    bogus
535    bogus
536    bogus
537    bogus
538    bogus
539    bogus
540    bogus
541    simple-bit-vector
542    bogus
543    bogus))
544
545#+ppc64-target
546(defparameter *nodeheader-types*
547    #(function
548      catch-frame
549      slot-vector
550      bogus
551      symbol
552      lisp-thread
553      standard-instance
554      bogus
555      bogus
556      lock
557      structure
558      bogus
559      bogus
560      hash-vector
561      internal-structure
562      bogus
563      bogus
564      pool
565      value-cell
566      bogus
567      bogus
568      population
569      xfunction
570      bogus
571      bogus
572      package
573      ratio
574      bogus
575      bogus
576      svar
577      complex
578      bogus
579      bogus
580      array-header
581      vector-header
582      simple-vector
583      bogus
584      bogus
585      bogus
586      bogus
587      bogus
588      bogus
589      bogus
590      bogus
591      bogus
592      bogus
593      bogus
594      bogus
595      bogus
596      bogus
597      bogus
598      bogus
599      bogus
600      bogus
601      bogus
602      bogus
603      bogus
604      bogus
605      bogus
606      bogus
607      bogus
608      bogus
609      bogus
610      bogus
611      )
612  )
613
614#+ppc64-target
615(defun %type-of (thing)
616  (let* ((typecode (typecode thing)))
617    (declare (fixnum typecode))
618    (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
619          ((= typecode ppc64::fulltag-cons) 'cons)
620          ((= typecode ppc64::subtag-character) 'character)
621          ((= typecode ppc64::subtag-single-float) 'short-float)
622          (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
623               (declare (fixnum lowtag))
624               (cond ((= lowtag ppc64::lowtag-immheader)
625                       (%svref *immheader-types* (ash typecode -2)))
626                      ((= lowtag ppc64::lowtag-nodeheader)
627                       (let* ((type (%svref *nodeheader-types*
628                                            (ash typecode -2))))
629                         (cond ((eq type 'function)
630                                (let ((bits (lfun-bits thing)))
631                                  (declare (fixnum bits))
632                                  (if (logbitp $lfbits-trampoline-bit bits)
633                                    (if (logbitp $lfbits-evaluated-bit bits)
634                                      'interpreted-lexical-closure
635                                      (let ((inner-fn (closure-function thing)))
636                                        (if (neq inner-fn thing)
637                                          (let ((inner-bits (lfun-bits inner-fn)))
638                                            (if (logbitp $lfbits-method-bit inner-bits)
639                                              'compiled-lexical-closure
640                                              (if (logbitp $lfbits-gfn-bit inner-bits)
641                                                'standard-generic-function ; not precisely - see class-of
642                                                (if (logbitp  $lfbits-cm-bit inner-bits)
643                                                  'combined-method
644                                                  'compiled-lexical-closure))))
645                                          'compiled-lexical-closure)))
646                                    (if (logbitp $lfbits-evaluated-bit bits)
647                                      (if (logbitp $lfbits-method-bit bits)
648                                        'interpreted-method-function
649                                        'interpreted-function)
650                                      (if (logbitp  $lfbits-method-bit bits)
651                                        'method-function         
652                                        'compiled-function)))))
653                               ((eq type 'lock)
654                                (or (uvref thing ppc64::lock.kind-cell)
655                                    type))
656                               (t type))))
657                      (t 'immediate)))))))
658
659
660;;; real machine specific huh
661(defun consp (x)
662  "Return true if OBJECT is a CONS, and NIL otherwise."
663  (consp x))
664
665(defun characterp (arg)
666  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
667  (characterp arg))
668
669(defun base-char-p (c)
670  (base-char-p c))
671
672
673
674
675(defun structurep (form)
676  "True if the given object is a named structure, Nil otherwise."
677  (= (the fixnum (typecode form)) target::subtag-struct))
678
679(defun istructp (form)
680  (= (the fixnum (typecode form)) target::subtag-istruct))
681
682(defun structure-typep (thing type)
683  (if (= (the fixnum (typecode thing)) target::subtag-struct)
684    (if (memq type (%svref thing 0))
685      t)))
686
687
688(defun istruct-typep (thing type)
689  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
690    (eq (%svref thing 0) type)))
691
692(defun symbolp (thing)
693  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
694  #+ppc32-target
695  (if thing
696    (= (the fixnum (typecode thing)) ppc32::subtag-symbol)
697    t)
698  #+ppc64-target
699  (= (the fixnum (typecode thing)) ppc64::subtag-symbol))
700     
701(defun packagep (thing)
702  (= (the fixnum (typecode thing)) target::subtag-package))
703
704;;; 1 if by land, 2 if by sea.
705(defun sequence-type (x)
706  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
707    (or (listp x)
708        (report-bad-arg x 'sequence))))
709
710(defun uvectorp (x)
711  (= (the fixnum (fulltag x)) target::fulltag-misc))
712
713(setf (type-predicate 'uvector) 'uvectorp)
Note: See TracBrowser for help on using the repository browser.