source: branches/arm/level-0/l0-pred.lisp @ 14062

Last change on this file since 14062 was 14062, checked in by gb, 9 years ago

Fix runtime versions of REALP, NUMBERP, too.

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