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

Last change on this file since 10406 was 10406, checked in by gb, 11 years ago

Move %FIND-CLASSES% and accessor to level-0.

Start to bootstrap structure-type changes by making STRUCTURE-TYPEP
handle legacy/new cases.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.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
29(defun builtin-typep (form cell)
30  (typep form (class-cell-name cell)))
31
32(defun class-cell-typep (arg class-cell)
33  (typep arg (class-cell-name class-cell)))
34
35(defun class-cell-find-class (class-cell errorp)
36  (declare (ignore errorp)) ; AARGH can't be right
37  ;(dbg-paws #x100)
38  (let ((class (and class-cell (class-cell-class class-cell))))
39    (or class 
40        (if  (fboundp 'find-class)
41          (find-class (class-cell-name class-cell) nil)))))
42
43(defun %require-type-builtin (form foo)
44  (declare (ignore foo))
45  form)
46
47(defun %require-type-class-cell (form cell)
48  (declare (ignore cell))
49  form)
50 
51(defun non-nil-symbol-p (x)
52  (if (symbolp x) x))
53
54(defun pathnamep (thing)
55  (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname)))
56
57(defun compiled-function-p (form)
58  "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise."
59  (and (functionp form)
60       (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form))))))
61
62;;; all characters are base-chars.
63(defun extended-char-p (c)
64  (declare (ignore c)))
65
66
67;;; Some of these things are probably open-coded.
68;;; The functions have to exist SOMEWHERE ...
69(defun fixnump (x)
70  (= (the fixnum (lisptag x)) target::tag-fixnum))
71
72(defun bignump (x)
73  (= (the fixnum (typecode x)) target::subtag-bignum))
74
75(defun integerp (x)
76  "Return true if OBJECT is an INTEGER, and NIL otherwise."
77  (let* ((typecode (typecode x)))
78    (declare (fixnum typecode))
79    (or (= typecode target::tag-fixnum)
80        (= typecode target::subtag-bignum))))
81
82(defun ratiop (x)
83  (= (the fixnum (typecode x)) target::subtag-ratio))
84
85
86(defun rationalp (x)
87  "Return true if OBJECT is a RATIONAL, and NIL otherwise."
88  (or (fixnump x)
89      (let* ((typecode (typecode x)))
90        (declare (fixnum typecode))
91        #+(or ppc32-target x8632-target)
92        (and (>= typecode target::min-numeric-subtag)
93             (<= typecode target::max-rational-subtag))
94        #+(or ppc64-target x8664-target)
95        (cond ((= typecode target::subtag-bignum) t)
96              ((= typecode target::subtag-ratio) t)))))
97
98(defun short-float-p (x)
99  (= (the fixnum (typecode x)) target::subtag-single-float))
100
101
102(defun double-float-p (x)
103  (= (the fixnum (typecode x)) target::subtag-double-float))
104
105(defun floatp (x)
106  "Return true if OBJECT is a FLOAT, and NIL otherwise."
107  (let* ((typecode (typecode x)))
108    (declare (fixnum typecode))
109    (or (= typecode target::subtag-single-float)
110        (= typecode target::subtag-double-float))))
111
112(defun realp (x)
113  "Return true if OBJECT is a REAL, and NIL otherwise."
114  (let* ((typecode (typecode x)))
115    (declare (fixnum typecode))
116    #+(or ppc32-target x8632-target)
117    (or (= typecode target::tag-fixnum)
118        (and (>= typecode target::min-numeric-subtag)
119             (<= typecode target::max-real-subtag)))
120    #+ppc64-target
121    (if (<= typecode ppc64::subtag-double-float)
122      (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
123               (logior (ash 1 ppc64::tag-fixnum)
124                       (ash 1 ppc64::subtag-single-float)
125                       (ash 1 ppc64::subtag-double-float)
126                       (ash 1 ppc64::subtag-bignum)
127                       (ash 1 ppc64::subtag-ratio))))
128    #+x8664-target
129    (if (<= typecode x8664::subtag-double-float)
130      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
131               (logior (ash 1 x8664::tag-fixnum)
132                       (ash 1 x8664::subtag-bignum)
133                       (ash 1 x8664::tag-single-float)
134                       (ash 1 x8664::subtag-double-float)
135                       (ash 1 x8664::subtag-ratio))))))
136
137(defun complexp (x)
138  "Return true if OBJECT is a COMPLEX, and NIL otherwise."
139  (= (the fixnum (typecode x)) target::subtag-complex))
140
141(defun numberp (x)
142  "Return true if OBJECT is a NUMBER, and NIL otherwise."
143  (let* ((typecode (typecode x)))
144    (declare (fixnum typecode))
145    #+(or ppc32-target x8632-target)
146    (or (= typecode target::tag-fixnum)
147        (and (>= typecode target::min-numeric-subtag)
148             (<= typecode target::max-numeric-subtag)))
149    #+ppc64-target
150    (if (<= typecode ppc64::subtag-double-float)
151      (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
152               (logior (ash 1 ppc64::tag-fixnum)
153                       (ash 1 ppc64::subtag-bignum)
154                       (ash 1 ppc64::subtag-single-float)
155                       (ash 1 ppc64::subtag-double-float)
156                       (ash 1 ppc64::subtag-ratio)
157                       (ash 1 ppc64::subtag-complex))))
158    #+x8664-target
159    (if (< typecode x8664::nbits-in-word)
160      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
161               (logior (ash 1 x8664::tag-fixnum)
162                       (ash 1 x8664::subtag-bignum)
163                       (ash 1 x8664::tag-single-float)
164                       (ash 1 x8664::subtag-double-float)
165                       (ash 1 x8664::subtag-ratio)
166                       (ash 1 x8664::subtag-complex))))
167   
168    ))
169
170(defun arrayp (x)
171  "Return true if OBJECT is an ARRAY, and NIL otherwise."
172  (>= (the fixnum (typecode x)) target::min-array-subtag))
173
174(defun vectorp (x)
175  "Return true if OBJECT is a VECTOR, and NIL otherwise."
176  (>= (the fixnum (typecode x)) target::min-vector-subtag))
177
178
179(defun stringp (x)
180  "Return true if OBJECT is a STRING, and NIL otherwise."
181  (let* ((typecode (typecode x)))
182    (declare (fixnum typecode))
183    (if (= typecode target::subtag-vectorH)
184      (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell)))))
185    (= typecode target::subtag-simple-base-string)))
186
187
188(defun simple-base-string-p (x)
189  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
190
191(defun simple-string-p (x)
192  "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise."
193  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
194
195(defun complex-array-p (x)
196  (let* ((typecode (typecode x)))
197    (declare (fixnum typecode))
198    (if (or (= typecode target::subtag-arrayH)
199            (= typecode target::subtag-vectorH))
200      (not (%array-header-simple-p x)))))
201
202(defun simple-array-p (thing)
203  "Returns T if the object is a simple array, else returns NIL.
204   That's why it's called SIMPLE-ARRAY-P.  Get it ?
205   A simple-array may have no fill-pointer, may not be displaced,
206   and may not be adjustable."
207  (let* ((typecode (typecode thing)))
208    (declare (fixnum typecode))
209    (if (or (= typecode target::subtag-arrayH)
210            (= typecode target::subtag-vectorH))
211      (%array-header-simple-p thing)
212      (> typecode target::subtag-vectorH))))
213
214(defun macptrp (x)
215  (= (the fixnum (typecode x)) target::subtag-macptr))
216
217(defun dead-macptr-p (x)
218  (= (the fixnum (typecode x)) target::subtag-dead-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  #+(or ppc32-target x8632-target)
225  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::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  #+(or ppc32-target x8632-target)
240  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask))
241     target::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 x8632-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 (istruct-cell-name (%svref x 0))))
374                       (and (eq structname (istruct-cell-name (%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                           (when (= x-size (the fixnum (uvsize y)))
382                             ;; Ignore last (version) slot in physical pathnames.
383                             (when (eq structname 'pathname)
384                               (decf x-size))
385                             (do* ((i 1 (1+ i)))
386                                  ((= i x-size) t)
387                               (declare (fixnum i))
388                               (unless (equal (%svref x i) (%svref y i))
389                                 (return)))))))))))))
390
391#+ppc32-target
392(progn
393(defparameter *nodeheader-types*
394  #(bogus                               ; 0
395    ratio                               ; 1
396    bogus                               ; 2
397    complex                             ; 3
398    catch-frame                         ; 4
399    function                            ; 5
400    basic-stream                         ; 6
401    symbol                              ; 7
402    lock                                ; 8
403    hash-table-vector                   ; 9
404    pool                                ; 10
405    population                          ; 11
406    package                             ; 12
407    slot-vector                         ; 13
408    standard-instance                   ; 14
409    structure                           ; 15
410    internal-structure                  ; 16
411    value-cell                          ; 17
412    xfunction                           ; 18
413    array-header                        ; 19
414    vector-header                       ; 20
415    simple-vector                       ; 21
416    bogus                               ; 22
417    bogus                               ; 23
418    bogus                               ; 24
419    bogus                               ; 25
420    bogus                               ; 26
421    bogus                               ; 27
422    bogus                               ; 28
423    bogus                               ; 29
424    bogus                               ; 30
425    bogus                               ; 31
426    ))
427
428
429(defparameter *immheader-types*
430  #(bignum                              ; 0
431    short-float                         ; 1
432    double-float                        ; 2
433    macptr                              ; 3
434    dead-macptr                         ; 4
435    code-vector                         ; 5
436    creole-object                       ; 6
437    ;; 8-19 are unused
438    xcode-vector                        ; 7
439    bogus                               ; 8
440    bogus                               ; 9
441    bogus                               ; 10
442    bogus                               ; 11
443    bogus                               ; 12
444    bogus                               ; 13
445    bogus                               ; 14
446    bogus                               ; 15
447    bogus                               ; 16
448    bogus                               ; 17
449    bogus                               ; 18
450    bogus                               ; 19
451    simple-short-float-vector           ; 20
452    simple-unsigned-long-vector         ; 21
453    simple-signed-long-vector           ; 22
454    simple-fixnum-vector                ; 23
455    simple-base-string                  ; 24
456    simple-unsigned-byte-vector         ; 25
457    simple-signed-byte-vector           ; 26
458    bogus                               ; 27
459    simple-unsigned-word-vector         ; 28
460    simple-signed-word-vector           ; 29
461    simple-double-float-vector          ; 30
462    simple-bit-vector                   ; 31
463    ))
464
465(defun %type-of (thing)
466  (let* ((typecode (typecode thing)))
467    (declare (fixnum typecode))
468    (if (= typecode ppc32::tag-fixnum)
469      'fixnum
470      (if (= typecode ppc32::tag-list)
471        (if thing 'cons 'null)
472        (if (= typecode ppc32::tag-imm)
473          (if (base-char-p thing)
474            'base-char
475            'immediate)
476          (if (= typecode ppc32::subtag-macptr)
477            (if (classp thing)
478              (class-name thing)
479              'macptr)
480            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
481                   (tag-val (ash typecode (- ppc32::ntagbits))))
482              (declare (fixnum tag-type tag-val))
483              (if (/= tag-type ppc32::fulltag-nodeheader)
484                (%svref *immheader-types* tag-val)
485                (let ((type (%svref *nodeheader-types* tag-val)))
486                  (if (eq type 'function)
487                    (let ((bits (lfun-bits thing)))
488                      (declare (fixnum bits))
489                      (if (logbitp $lfbits-trampoline-bit bits)
490                        (let ((inner-fn (closure-function thing)))
491                          (if (neq inner-fn thing)
492                            (let ((inner-bits (lfun-bits inner-fn)))
493                              (if (logbitp $lfbits-method-bit inner-bits)
494                                'compiled-lexical-closure
495                                (if (logbitp $lfbits-gfn-bit inner-bits)
496                                  'standard-generic-function ; not precisely - see class-of
497                                  (if (logbitp  $lfbits-cm-bit inner-bits)
498                                    'combined-method
499                                    'compiled-lexical-closure))))
500                            'compiled-lexical-closure))
501                        (if (logbitp  $lfbits-method-bit bits)
502                          'method-function         
503                          'compiled-function)))
504                    (if (eq type 'lock)
505                      (or (uvref thing ppc32::lock.kind-cell)
506                          type)
507                      type)))))))))))
508
509);#+ppc32-target
510
511#+ppc64-target
512(progn
513(defparameter *immheader-types*
514  #(bogus
515    bogus
516    code-vector
517    bogus
518    bogus
519    bogus
520    xcode-vector
521    macptr
522    bogus
523    bogus
524    bignum
525    dead-macptr
526    bogus
527    bogus
528    double-float
529    bogus
530    bogus
531    bogus
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    simple-signed-byte-vector
551    simple-signed-word-vector
552    simple-signed-long-vector
553    simple-signed-doubleword-vector
554    simple-unsigned-byte-vector
555    simple-unsigned-word-vector
556    simple-unsigned-long-vector
557    simple-unsigned-doubleword-vector
558    bogus
559    bogus
560    simple-short-float-vector
561    simple-fixnum-vector
562    bogus
563    bogus
564    bogus
565    simple-double-float-vector
566    bogus
567    bogus
568    simple-base-string
569    bogus
570    bogus
571    bogus
572    bogus
573    bogus
574    bogus
575    simple-bit-vector
576    bogus
577    bogus))
578
579(defparameter *nodeheader-types*
580    #(function
581      catch-frame
582      slot-vector
583      ratio
584      symbol
585      basic-stream
586      standard-instance
587      complex
588      bogus
589      lock
590      structure
591      bogus
592      bogus
593      hash-vector
594      internal-structure
595      bogus
596      bogus
597      pool
598      value-cell
599      bogus
600      bogus
601      population
602      xfunction
603      bogus
604      bogus
605      package
606      bogus
607      bogus
608      bogus
609      bogus
610      bogus
611      bogus
612      bogus
613      array-header
614      vector-header
615      simple-vector
616      bogus
617      bogus
618      bogus
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      )
645  )
646
647
648(defun %type-of (thing)
649  (if (null thing)
650    'null
651    (let* ((typecode (typecode thing)))
652      (declare (fixnum typecode))
653      (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
654            ((= typecode ppc64::fulltag-cons) 'cons)
655            ((= typecode ppc64::subtag-character) 'character)
656            ((= typecode ppc64::subtag-single-float) 'short-float)
657            (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
658                 (declare (fixnum lowtag))
659                 (cond ((= lowtag ppc64::lowtag-immheader)
660                        (%svref *immheader-types* (ash typecode -2)))
661                       ((= lowtag ppc64::lowtag-nodeheader)
662                        (let* ((type (%svref *nodeheader-types*
663                                             (ash typecode -2))))
664                          (cond ((eq type 'function)
665                                 (let ((bits (lfun-bits thing)))
666                                   (declare (fixnum bits))
667                                   (if (logbitp $lfbits-trampoline-bit bits)
668                                     (let ((inner-fn (closure-function thing)))
669                                         (if (neq inner-fn thing)
670                                           (let ((inner-bits (lfun-bits inner-fn)))
671                                             (if (logbitp $lfbits-method-bit inner-bits)
672                                               'compiled-lexical-closure
673                                               (if (logbitp $lfbits-gfn-bit inner-bits)
674                                                 'standard-generic-function ; not precisely - see class-of
675                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
676                                                   'combined-method
677                                                   'compiled-lexical-closure))))
678                                           'compiled-lexical-closure))
679                                     (if (logbitp  $lfbits-method-bit bits)
680                                       'method-function         
681                                       'compiled-function))))
682                                ((eq type 'lock)
683                                 (or (uvref thing ppc64::lock.kind-cell)
684                                     type))
685                                (t type))))
686                       (t 'immediate))))))))
687);#+ppc64-target
688
689
690#+x8632-target
691(progn
692(defparameter *nodeheader-types*
693  #(bogus                               ; 0
694    ratio                               ; 1
695    bogus                               ; 2
696    complex                             ; 3
697    catch-frame                         ; 4
698    function                            ; 5
699    basic-stream                        ; 6
700    symbol                              ; 7
701    lock                                ; 8
702    hash-table-vector                   ; 9
703    pool                                ; 10
704    population                          ; 11 (weak?)
705    package                             ; 12
706    slot-vector                         ; 13
707    standard-instance                   ; 14
708    structure                           ; 15
709    internal-structure                  ; 16
710    value-cell                          ; 17
711    xfunction                           ; 18
712    array-header                        ; 19
713    vector-header                       ; 20
714    simple-vector                       ; 21
715    bogus                               ; 22
716    bogus                               ; 23
717    bogus                               ; 24
718    bogus                               ; 25
719    bogus                               ; 26
720    bogus                               ; 27
721    bogus                               ; 28
722    bogus                               ; 29
723    bogus                               ; 30
724    bogus                               ; 31
725    ))
726
727
728(defparameter *immheader-types*
729  #(bignum                              ; 0
730    short-float                         ; 1
731    double-float                        ; 2
732    macptr                              ; 3
733    dead-macptr                         ; 4
734    code-vector                         ; 5
735    creole-object                       ; 6
736    xcode-vector                        ; 7
737    bogus                               ; 8
738    bogus                               ; 9
739    bogus                               ; 10
740    bogus                               ; 11
741    bogus                               ; 12
742    bogus                               ; 13
743    bogus                               ; 14
744    bogus                               ; 15
745    bogus                               ; 16
746    bogus                               ; 17
747    bogus                               ; 18
748    bogus                               ; 19
749    simple-short-float-vector           ; 20
750    simple-unsigned-long-vector         ; 21
751    simple-signed-long-vector           ; 22
752    simple-fixnum-vector                ; 23
753    simple-base-string                  ; 24
754    simple-unsigned-byte-vector         ; 25
755    simple-signed-byte-vector           ; 26
756    bogus                               ; 27
757    simple-unsigned-word-vector         ; 28
758    simple-signed-word-vector           ; 29
759    simple-double-float-vector          ; 30
760    simple-bit-vector                   ; 31
761    ))
762
763(defun %type-of (thing)
764  (let* ((typecode (typecode thing)))
765    (declare (fixnum typecode))
766    (if (= typecode x8632::tag-fixnum)
767      'fixnum
768      (if (= typecode x8632::tag-list)  ;a misnomer on x8632...
769        (if (= typecode x8632::fulltag-cons)
770          (if thing 'cons 'null)
771          'tagged-return-address)
772        (if (= typecode x8632::tag-imm)
773          (if (base-char-p thing)
774            'base-char
775            'immediate)
776          (if (= typecode x8632::subtag-macptr)
777            (if (classp thing)
778              (class-name thing)
779              'macptr)
780            (let* ((tag-type (logand typecode x8632::fulltagmask))
781                   (tag-val (ash typecode (- x8632::ntagbits))))
782              (declare (fixnum tag-type tag-val))
783              (if (/= tag-type x8632::fulltag-nodeheader)
784                (%svref *immheader-types* tag-val)
785                (let ((type (%svref *nodeheader-types* tag-val)))
786                  (if (eq type 'function)
787                    (let ((bits (lfun-bits thing)))
788                      (declare (fixnum bits))
789                      (if (logbitp $lfbits-trampoline-bit bits)
790                        (let ((inner-fn (closure-function thing)))
791                          (if (neq inner-fn thing)
792                            (let ((inner-bits (lfun-bits inner-fn)))
793                              (if (logbitp $lfbits-method-bit inner-bits)
794                                'compiled-lexical-closure
795                                (if (logbitp $lfbits-gfn-bit inner-bits)
796                                  'standard-generic-function ; not precisely - see class-of
797                                  (if (logbitp  $lfbits-cm-bit inner-bits)
798                                    'combined-method
799                                    'compiled-lexical-closure))))
800                            'compiled-lexical-closure))
801                        (if (logbitp  $lfbits-method-bit bits)
802                          'method-function         
803                          'compiled-function)))
804                    (if (eq type 'lock)
805                      (or (uvref thing x8632::lock.kind-cell)
806                          type)
807                      type)))))))))))
808
809) ;x8632-target
810
811#+x8664-target
812(progn
813(defparameter *nodeheader-0-types*
814  #(bogus
815    symbol-vector
816    catch-frame
817    hash-vector
818    pool
819    population
820    package
821    slot-vector
822    basic-stream
823    function-vector                                        ;8
824    array-header
825    bogus
826    bogus
827    bogus
828    bogus
829    bogus
830    ))
831
832(defparameter *nodeheader-1-types*
833  #(bogus
834    ratio
835    complex
836    structure
837    internal-structure
838    value-cell
839    xfunction
840    lock
841    instance
842    bogus
843    vector-header
844    simple-vector
845    bogus
846    bogus
847    bogus
848    bogus
849    ))
850
851(defparameter *immheader-0-types*
852  #(bogus
853    bogus
854    bogus
855    bogus
856    bogus
857    bogus
858    bogus
859    bogus
860    bogus
861    bogus
862    simple-signed-word-vector
863    simple-unsigned-word-vector
864    bogus
865    simple-signed-byte-vector
866    simple-unsigned-byte-vector
867    bit-vector))
868
869(defparameter *immheader-1-types*
870  #(bogus
871    bignum
872    double-float
873    xcode-vector
874    bogus
875    bogus
876    bogus
877    bogus
878    bogus
879    bogus
880    bogus
881    bogus
882    simple-base-string
883    simple-signed-long-vector
884    simple-unsigned-long-vector
885    single-float-vector))
886
887(defparameter *immheader-2-types*
888  #(bogus
889    macptr
890    dead-macptr
891    bogus
892    bogus
893    bogus
894    bogus
895    bogus
896    bogus
897    bogus
898    bogus
899    bogus
900    simple-fixnum-vector
901    simple-signed-doubleword-vector
902    simple-unsigned-doubleword-vector
903    double-float-vector))
904
905
906(defparameter *x8664-%type-of-functions* nil)
907
908(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum))
909       (tra (lambda (x) (declare (ignore x)) 'tagged-return-address))
910       (bogus (lambda (x) (declare (ignore x)) 'bogus)))
911  (setq *x8664-%type-of-functions*
912        (vector
913         fixnum                         ;0
914         (lambda (x) (declare (ignore x)) 'short-float) ;1
915         (lambda (x) (if (characterp x) 'character 'immediate)) ;2
916         (lambda (x) (declare (ignore x)) 'cons) ;3
917         tra                            ;4
918         bogus                          ;5
919         bogus                          ;6
920         bogus                          ;7
921         fixnum                         ;8
922         bogus                          ;9
923         bogus                          ;10
924         (lambda (x) (declare (ignore x)) 'null) ;11
925         tra                            ;12
926         (lambda (x) (let* ((typecode (typecode x)) 
927                            (low4 (logand typecode x8664::fulltagmask))
928                            (high4 (ash typecode (- x8664::ntagbits))))
929                       (declare (type (unsigned-byte 8) typecode)
930                                (type (unsigned-byte 4) low4 high4))
931                       (let* ((name
932                               (cond ((= low4 x8664::fulltag-immheader-0)
933                                      (%svref *immheader-0-types* high4))
934                                     ((= low4 x8664::fulltag-immheader-1)
935                                      (%svref *immheader-1-types* high4))
936                                     ((= low4 x8664::fulltag-immheader-2)
937                                      (%svref *immheader-2-types* high4))
938                                     ((= low4 x8664::fulltag-nodeheader-0)
939                                      (%svref *nodeheader-0-types* high4))
940                                     ((= low4 x8664::fulltag-nodeheader-1)
941                                      (%svref *nodeheader-1-types* high4))
942                                     (t 'bogus))))
943                         (or (and (eq name 'lock)
944                                  (uvref x x8664::lock.kind-cell))
945                             name)))) ;13
946         (lambda (x) (declare (ignore x)) 'symbol) ;14
947         (lambda (thing)
948           (let ((bits (lfun-bits thing)))
949             (declare (fixnum bits))
950             (if (logbitp $lfbits-trampoline-bit bits)
951               (let ((inner-fn (closure-function thing)))
952                 (if (neq inner-fn thing)
953                   (let ((inner-bits (lfun-bits inner-fn)))
954                     (if (logbitp $lfbits-method-bit inner-bits)
955                       'compiled-lexical-closure
956                       (if (logbitp $lfbits-gfn-bit inner-bits)
957                         'standard-generic-function ; not precisely - see class-of
958                         (if (logbitp  $lfbits-cm-bit inner-bits)
959                           'combined-method
960                           'compiled-lexical-closure))))
961                   'compiled-lexical-closure))
962               (if (logbitp  $lfbits-method-bit bits)
963                 'method-function         
964                 'compiled-function))))))) ;15
965                                     
966       
967
968
969 
970(defun %type-of (thing)
971  (let* ((f (fulltag thing)))
972    (funcall (%svref *x8664-%type-of-functions* f) thing)))
973
974       
975
976);#+x8664-target
977     
978
979;;; real machine specific huh
980(defun consp (x)
981  "Return true if OBJECT is a CONS, and NIL otherwise."
982  (consp x))
983
984(defun characterp (arg)
985  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
986  (characterp arg))
987
988(defun base-char-p (c)
989  (base-char-p c))
990
991
992
993
994(defun structurep (form)
995  "True if the given object is a named structure, Nil otherwise."
996  (= (the fixnum (typecode form)) target::subtag-struct))
997
998(defun istructp (form)
999  (= (the fixnum (typecode form)) target::subtag-istruct))
1000
1001
1002;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp.
1003;;; (If you've ever been "conused", I'm sure you know just how painful
1004;;; that can be.)
1005
1006;;; In the short term (bootstrapping), expect TYPE to be a a SYMBOL.
1007;;; If THING is a structure instance (has typecode subtag-struct),
1008;;; its 0th element is either a list of symbols (traditional, legacy
1009;;; case) or a list of CLASS-CELLs.
1010(defun structure-typep (thing type)
1011  (if (= (the fixnum (typecode thing)) target::subtag-struct)
1012    (dolist (i (%svref thing 0))
1013      (if (or (eq i type)
1014              (and (not (symbolp i))
1015                   (eq (class-cell-name i) type)))
1016        (return t)))))
1017
1018
1019
1020(defun istruct-typep (thing type)
1021  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1022    (eq (istruct-cell-name (%svref thing 0)) type)))
1023
1024(defun istruct-type-name (thing)
1025  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1026    (istruct-cell-name (%svref thing 0))))
1027
1028
1029;;; This is actually set to an alist in the xloader.
1030(defparameter *istruct-cells* nil)
1031
1032;;; This should only ever push anything on the list in the cold
1033;;; load (e.g., when running single-threaded.)
1034(defun register-istruct-cell (name)
1035  (or (assq name *istruct-cells*)
1036      (let* ((pair (cons name nil)))
1037        (push pair *istruct-cells*)
1038        pair)))
1039
1040(defun set-istruct-cell-info (cell info)
1041  (etypecase cell
1042    (cons (%rplacd cell info)))
1043  info)
1044
1045
1046(defun symbolp (thing)
1047  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
1048  #+(or ppc32-target x8632-target)
1049  (if thing
1050    (= (the fixnum (typecode thing)) target::subtag-symbol)
1051    t)
1052  #+ppc64-target
1053  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
1054  #+x8664-target
1055  (if thing
1056    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
1057    t)
1058  )
1059     
1060(defun packagep (thing)
1061  (= (the fixnum (typecode thing)) target::subtag-package))
1062
1063;;; 1 if by land, 2 if by sea.
1064(defun sequence-type (x)
1065  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
1066    (or (listp x)
1067        (report-bad-arg x 'sequence))))
1068
1069(defun uvectorp (x)
1070  (= (the fixnum (fulltag x)) target::fulltag-misc))
1071
1072(setf (type-predicate 'uvector) 'uvectorp)
1073
1074(defun listp (x)
1075  (listp x))
1076
1077(defparameter *type-cells* nil)
1078
1079
1080
1081(defparameter *type-cells-lock* nil)
1082
1083
1084;;; The weird handling to the special variables here has to do with
1085;;; xload issues.
1086(defun register-type-cell (specifier)
1087  (with-lock-grabbed ((or *type-cells-lock*
1088                         (setq *type-cells-lock* (make-lock))))
1089    (unless *type-cells*
1090      (setq *type-cells* (make-hash-table :test 'equal)))
1091    (or (values (gethash specifier *type-cells*))
1092        (setf (gethash specifier *type-cells*)
1093              (make-type-cell specifier)))))
1094
1095
1096(defvar %find-classes% nil)
1097
1098(setq %find-classes% (make-hash-table :test 'eq))
1099
1100
1101(defun find-class-cell (name create?)
1102  (unless %find-classes%
1103    (dbg name))
1104  (let ((cell (gethash name %find-classes%)))
1105    (or cell
1106        (and create?
1107             (setf (gethash name %find-classes%) (make-class-cell name))))))
1108
Note: See TracBrowser for help on using the repository browser.