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

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

Define *CASE-SENSITIVE-FILESYSTEM*, default it to T.
Usee it to determine whether EQUAL and CCL::PATH-STR-MATCH-P (at least) do
case-sensitive comparisons of pathname components.
Of course, whehter or not a filesystem is case-sensitive is an attribute
of the filesystem and not of the value of a lisp variable; this variable
really controls nothing more than whether or not the implementation assumes
that the filesystems it encounters are case-sensitive or not, and therefore
whether or not comparisons of pathname components should fold case or not.

This is a hack, which might disappear if a better way of solving the problem
it's trying to solve becomes apparent.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.5 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                                (skip (if (eq structname 'pathname)
381                                        %physical-pathname-version
382                                        -1)))
383                           (declare (fixnum x-size skip))
384                           (when (= x-size (the fixnum (uvsize y)))
385                             (if *case-sensitive-filesystem*
386                               (do* ((i 1 (1+ i)))
387                                    ((= i x-size) t)
388                                 (declare (fixnum i))
389                                 (unless (or (= i skip)
390                                             (equal (%svref x i) (%svref y i)))
391                                   (return)))
392                                                              (do* ((i 1 (1+ i)))
393                                    ((= i x-size) t)
394                                 (declare (fixnum i))
395                                 (unless (or (= i skip)
396                                             (equalp (%svref x i) (%svref y i)))
397                                   (return))))))))))))))
398
399#+ppc32-target
400(progn
401(defparameter *nodeheader-types*
402  #(bogus                               ; 0
403    ratio                               ; 1
404    bogus                               ; 2
405    complex                             ; 3
406    catch-frame                         ; 4
407    function                            ; 5
408    basic-stream                         ; 6
409    symbol                              ; 7
410    lock                                ; 8
411    hash-table-vector                   ; 9
412    pool                                ; 10
413    population                          ; 11
414    package                             ; 12
415    slot-vector                         ; 13
416    standard-instance                   ; 14
417    structure                           ; 15
418    internal-structure                  ; 16
419    value-cell                          ; 17
420    xfunction                           ; 18
421    array-header                        ; 19
422    vector-header                       ; 20
423    simple-vector                       ; 21
424    bogus                               ; 22
425    bogus                               ; 23
426    bogus                               ; 24
427    bogus                               ; 25
428    bogus                               ; 26
429    bogus                               ; 27
430    bogus                               ; 28
431    bogus                               ; 29
432    bogus                               ; 30
433    bogus                               ; 31
434    ))
435
436
437(defparameter *immheader-types*
438  #(bignum                              ; 0
439    short-float                         ; 1
440    double-float                        ; 2
441    macptr                              ; 3
442    dead-macptr                         ; 4
443    code-vector                         ; 5
444    creole-object                       ; 6
445    ;; 8-19 are unused
446    xcode-vector                        ; 7
447    bogus                               ; 8
448    bogus                               ; 9
449    bogus                               ; 10
450    bogus                               ; 11
451    bogus                               ; 12
452    bogus                               ; 13
453    bogus                               ; 14
454    bogus                               ; 15
455    bogus                               ; 16
456    bogus                               ; 17
457    bogus                               ; 18
458    bogus                               ; 19
459    simple-short-float-vector           ; 20
460    simple-unsigned-long-vector         ; 21
461    simple-signed-long-vector           ; 22
462    simple-fixnum-vector                ; 23
463    simple-base-string                  ; 24
464    simple-unsigned-byte-vector         ; 25
465    simple-signed-byte-vector           ; 26
466    bogus                               ; 27
467    simple-unsigned-word-vector         ; 28
468    simple-signed-word-vector           ; 29
469    simple-double-float-vector          ; 30
470    simple-bit-vector                   ; 31
471    ))
472
473(defun %type-of (thing)
474  (let* ((typecode (typecode thing)))
475    (declare (fixnum typecode))
476    (if (= typecode ppc32::tag-fixnum)
477      'fixnum
478      (if (= typecode ppc32::tag-list)
479        (if thing 'cons 'null)
480        (if (= typecode ppc32::tag-imm)
481          (if (base-char-p thing)
482            'base-char
483            'immediate)
484          (if (= typecode ppc32::subtag-macptr)
485            (if (classp thing)
486              (class-name thing)
487              'macptr)
488            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
489                   (tag-val (ash typecode (- ppc32::ntagbits))))
490              (declare (fixnum tag-type tag-val))
491              (if (/= tag-type ppc32::fulltag-nodeheader)
492                (%svref *immheader-types* tag-val)
493                (let ((type (%svref *nodeheader-types* tag-val)))
494                  (if (eq type 'function)
495                    (let ((bits (lfun-bits thing)))
496                      (declare (fixnum bits))
497                      (if (logbitp $lfbits-trampoline-bit bits)
498                        (let ((inner-fn (closure-function thing)))
499                          (if (neq inner-fn thing)
500                            (let ((inner-bits (lfun-bits inner-fn)))
501                              (if (logbitp $lfbits-method-bit inner-bits)
502                                'compiled-lexical-closure
503                                (if (logbitp $lfbits-gfn-bit inner-bits)
504                                  'standard-generic-function ; not precisely - see class-of
505                                  (if (logbitp  $lfbits-cm-bit inner-bits)
506                                    'combined-method
507                                    'compiled-lexical-closure))))
508                            'compiled-lexical-closure))
509                        (if (logbitp  $lfbits-method-bit bits)
510                          'method-function         
511                          'compiled-function)))
512                    (if (eq type 'lock)
513                      (or (uvref thing ppc32::lock.kind-cell)
514                          type)
515                      type)))))))))))
516
517);#+ppc32-target
518
519#+ppc64-target
520(progn
521(defparameter *immheader-types*
522  #(bogus
523    bogus
524    code-vector
525    bogus
526    bogus
527    bogus
528    xcode-vector
529    macptr
530    bogus
531    bogus
532    bignum
533    dead-macptr
534    bogus
535    bogus
536    double-float
537    bogus
538    bogus
539    bogus
540    bogus
541    bogus
542    bogus
543    bogus
544    bogus
545    bogus
546    bogus
547    bogus
548    bogus
549    bogus
550    bogus
551    bogus
552    bogus
553    bogus
554    bogus
555    bogus
556    bogus
557    bogus
558    simple-signed-byte-vector
559    simple-signed-word-vector
560    simple-signed-long-vector
561    simple-signed-doubleword-vector
562    simple-unsigned-byte-vector
563    simple-unsigned-word-vector
564    simple-unsigned-long-vector
565    simple-unsigned-doubleword-vector
566    bogus
567    bogus
568    simple-short-float-vector
569    simple-fixnum-vector
570    bogus
571    bogus
572    bogus
573    simple-double-float-vector
574    bogus
575    bogus
576    simple-base-string
577    bogus
578    bogus
579    bogus
580    bogus
581    bogus
582    bogus
583    simple-bit-vector
584    bogus
585    bogus))
586
587(defparameter *nodeheader-types*
588    #(function
589      catch-frame
590      slot-vector
591      ratio
592      symbol
593      basic-stream
594      standard-instance
595      complex
596      bogus
597      lock
598      structure
599      bogus
600      bogus
601      hash-vector
602      internal-structure
603      bogus
604      bogus
605      pool
606      value-cell
607      bogus
608      bogus
609      population
610      xfunction
611      bogus
612      bogus
613      package
614      bogus
615      bogus
616      bogus
617      bogus
618      bogus
619      bogus
620      bogus
621      array-header
622      vector-header
623      simple-vector
624      bogus
625      bogus
626      bogus
627      bogus
628      bogus
629      bogus
630      bogus
631      bogus
632      bogus
633      bogus
634      bogus
635      bogus
636      bogus
637      bogus
638      bogus
639      bogus
640      bogus
641      bogus
642      bogus
643      bogus
644      bogus
645      bogus
646      bogus
647      bogus
648      bogus
649      bogus
650      bogus
651      bogus
652      )
653  )
654
655
656(defun %type-of (thing)
657  (if (null thing)
658    'null
659    (let* ((typecode (typecode thing)))
660      (declare (fixnum typecode))
661      (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
662            ((= typecode ppc64::fulltag-cons) 'cons)
663            ((= typecode ppc64::subtag-character) 'character)
664            ((= typecode ppc64::subtag-single-float) 'short-float)
665            (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
666                 (declare (fixnum lowtag))
667                 (cond ((= lowtag ppc64::lowtag-immheader)
668                        (%svref *immheader-types* (ash typecode -2)))
669                       ((= lowtag ppc64::lowtag-nodeheader)
670                        (let* ((type (%svref *nodeheader-types*
671                                             (ash typecode -2))))
672                          (cond ((eq type 'function)
673                                 (let ((bits (lfun-bits thing)))
674                                   (declare (fixnum bits))
675                                   (if (logbitp $lfbits-trampoline-bit bits)
676                                     (let ((inner-fn (closure-function thing)))
677                                         (if (neq inner-fn thing)
678                                           (let ((inner-bits (lfun-bits inner-fn)))
679                                             (if (logbitp $lfbits-method-bit inner-bits)
680                                               'compiled-lexical-closure
681                                               (if (logbitp $lfbits-gfn-bit inner-bits)
682                                                 'standard-generic-function ; not precisely - see class-of
683                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
684                                                   'combined-method
685                                                   'compiled-lexical-closure))))
686                                           'compiled-lexical-closure))
687                                     (if (logbitp  $lfbits-method-bit bits)
688                                       'method-function         
689                                       'compiled-function))))
690                                ((eq type 'lock)
691                                 (or (uvref thing ppc64::lock.kind-cell)
692                                     type))
693                                (t type))))
694                       (t 'immediate))))))))
695);#+ppc64-target
696
697
698#+x8632-target
699(progn
700(defparameter *nodeheader-types*
701  #(bogus                               ; 0
702    ratio                               ; 1
703    bogus                               ; 2
704    complex                             ; 3
705    catch-frame                         ; 4
706    function                            ; 5
707    basic-stream                        ; 6
708    symbol                              ; 7
709    lock                                ; 8
710    hash-table-vector                   ; 9
711    pool                                ; 10
712    population                          ; 11 (weak?)
713    package                             ; 12
714    slot-vector                         ; 13
715    standard-instance                   ; 14
716    structure                           ; 15
717    internal-structure                  ; 16
718    value-cell                          ; 17
719    xfunction                           ; 18
720    array-header                        ; 19
721    vector-header                       ; 20
722    simple-vector                       ; 21
723    bogus                               ; 22
724    bogus                               ; 23
725    bogus                               ; 24
726    bogus                               ; 25
727    bogus                               ; 26
728    bogus                               ; 27
729    bogus                               ; 28
730    bogus                               ; 29
731    bogus                               ; 30
732    bogus                               ; 31
733    ))
734
735
736(defparameter *immheader-types*
737  #(bignum                              ; 0
738    short-float                         ; 1
739    double-float                        ; 2
740    macptr                              ; 3
741    dead-macptr                         ; 4
742    code-vector                         ; 5
743    creole-object                       ; 6
744    xcode-vector                        ; 7
745    bogus                               ; 8
746    bogus                               ; 9
747    bogus                               ; 10
748    bogus                               ; 11
749    bogus                               ; 12
750    bogus                               ; 13
751    bogus                               ; 14
752    bogus                               ; 15
753    bogus                               ; 16
754    bogus                               ; 17
755    bogus                               ; 18
756    bogus                               ; 19
757    simple-short-float-vector           ; 20
758    simple-unsigned-long-vector         ; 21
759    simple-signed-long-vector           ; 22
760    simple-fixnum-vector                ; 23
761    simple-base-string                  ; 24
762    simple-unsigned-byte-vector         ; 25
763    simple-signed-byte-vector           ; 26
764    bogus                               ; 27
765    simple-unsigned-word-vector         ; 28
766    simple-signed-word-vector           ; 29
767    simple-double-float-vector          ; 30
768    simple-bit-vector                   ; 31
769    ))
770
771(defun %type-of (thing)
772  (let* ((typecode (typecode thing)))
773    (declare (fixnum typecode))
774    (if (= typecode x8632::tag-fixnum)
775      'fixnum
776      (if (= typecode x8632::tag-list)  ;a misnomer on x8632...
777        (if (= (fulltag thing) x8632::fulltag-cons)
778          (if thing 'cons 'null)
779          'tagged-return-address)
780        (if (= typecode x8632::tag-imm)
781          (if (base-char-p thing)
782            'base-char
783            'immediate)
784          (if (= typecode x8632::subtag-macptr)
785            (if (classp thing)
786              (class-name thing)
787              'macptr)
788            (let* ((tag-type (logand typecode x8632::fulltagmask))
789                   (tag-val (ash typecode (- x8632::ntagbits))))
790              (declare (fixnum tag-type tag-val))
791              (if (/= tag-type x8632::fulltag-nodeheader)
792                (%svref *immheader-types* tag-val)
793                (let ((type (%svref *nodeheader-types* tag-val)))
794                  (if (eq type 'function)
795                    (let ((bits (lfun-bits thing)))
796                      (declare (fixnum bits))
797                      (if (logbitp $lfbits-trampoline-bit bits)
798                        (let ((inner-fn (closure-function thing)))
799                          (if (neq inner-fn thing)
800                            (let ((inner-bits (lfun-bits inner-fn)))
801                              (if (logbitp $lfbits-method-bit inner-bits)
802                                'compiled-lexical-closure
803                                (if (logbitp $lfbits-gfn-bit inner-bits)
804                                  'standard-generic-function ; not precisely - see class-of
805                                  (if (logbitp  $lfbits-cm-bit inner-bits)
806                                    'combined-method
807                                    'compiled-lexical-closure))))
808                            'compiled-lexical-closure))
809                        (if (logbitp  $lfbits-method-bit bits)
810                          'method-function         
811                          'compiled-function)))
812                    (if (eq type 'lock)
813                      (or (uvref thing x8632::lock.kind-cell)
814                          type)
815                      type)))))))))))
816
817) ;x8632-target
818
819#+x8664-target
820(progn
821(defparameter *nodeheader-0-types*
822  #(bogus
823    symbol-vector
824    catch-frame
825    hash-vector
826    pool
827    population
828    package
829    slot-vector
830    basic-stream
831    function-vector                                        ;8
832    array-header
833    bogus
834    bogus
835    bogus
836    bogus
837    bogus
838    ))
839
840(defparameter *nodeheader-1-types*
841  #(bogus
842    ratio
843    complex
844    structure
845    internal-structure
846    value-cell
847    xfunction
848    lock
849    instance
850    bogus
851    vector-header
852    simple-vector
853    bogus
854    bogus
855    bogus
856    bogus
857    ))
858
859(defparameter *immheader-0-types*
860  #(bogus
861    bogus
862    bogus
863    bogus
864    bogus
865    bogus
866    bogus
867    bogus
868    bogus
869    bogus
870    simple-signed-word-vector
871    simple-unsigned-word-vector
872    bogus
873    simple-signed-byte-vector
874    simple-unsigned-byte-vector
875    bit-vector))
876
877(defparameter *immheader-1-types*
878  #(bogus
879    bignum
880    double-float
881    xcode-vector
882    bogus
883    bogus
884    bogus
885    bogus
886    bogus
887    bogus
888    bogus
889    bogus
890    simple-base-string
891    simple-signed-long-vector
892    simple-unsigned-long-vector
893    single-float-vector))
894
895(defparameter *immheader-2-types*
896  #(bogus
897    macptr
898    dead-macptr
899    bogus
900    bogus
901    bogus
902    bogus
903    bogus
904    bogus
905    bogus
906    bogus
907    bogus
908    simple-fixnum-vector
909    simple-signed-doubleword-vector
910    simple-unsigned-doubleword-vector
911    double-float-vector))
912
913
914(defparameter *x8664-%type-of-functions* nil)
915
916(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum))
917       (tra (lambda (x) (declare (ignore x)) 'tagged-return-address))
918       (bogus (lambda (x) (declare (ignore x)) 'bogus)))
919  (setq *x8664-%type-of-functions*
920        (vector
921         fixnum                         ;0
922         (lambda (x) (declare (ignore x)) 'short-float) ;1
923         (lambda (x) (if (characterp x) 'character 'immediate)) ;2
924         (lambda (x) (declare (ignore x)) 'cons) ;3
925         tra                            ;4
926         bogus                          ;5
927         bogus                          ;6
928         bogus                          ;7
929         fixnum                         ;8
930         bogus                          ;9
931         bogus                          ;10
932         (lambda (x) (declare (ignore x)) 'null) ;11
933         tra                            ;12
934         (lambda (x) (let* ((typecode (typecode x)) 
935                            (low4 (logand typecode x8664::fulltagmask))
936                            (high4 (ash typecode (- x8664::ntagbits))))
937                       (declare (type (unsigned-byte 8) typecode)
938                                (type (unsigned-byte 4) low4 high4))
939                       (let* ((name
940                               (cond ((= low4 x8664::fulltag-immheader-0)
941                                      (%svref *immheader-0-types* high4))
942                                     ((= low4 x8664::fulltag-immheader-1)
943                                      (%svref *immheader-1-types* high4))
944                                     ((= low4 x8664::fulltag-immheader-2)
945                                      (%svref *immheader-2-types* high4))
946                                     ((= low4 x8664::fulltag-nodeheader-0)
947                                      (%svref *nodeheader-0-types* high4))
948                                     ((= low4 x8664::fulltag-nodeheader-1)
949                                      (%svref *nodeheader-1-types* high4))
950                                     (t 'bogus))))
951                         (or (and (eq name 'lock)
952                                  (uvref x x8664::lock.kind-cell))
953                             name)))) ;13
954         (lambda (x) (declare (ignore x)) 'symbol) ;14
955         (lambda (thing)
956           (let ((bits (lfun-bits thing)))
957             (declare (fixnum bits))
958             (if (logbitp $lfbits-trampoline-bit bits)
959               (let ((inner-fn (closure-function thing)))
960                 (if (neq inner-fn thing)
961                   (let ((inner-bits (lfun-bits inner-fn)))
962                     (if (logbitp $lfbits-method-bit inner-bits)
963                       'compiled-lexical-closure
964                       (if (logbitp $lfbits-gfn-bit inner-bits)
965                         'standard-generic-function ; not precisely - see class-of
966                         (if (logbitp  $lfbits-cm-bit inner-bits)
967                           'combined-method
968                           'compiled-lexical-closure))))
969                   'compiled-lexical-closure))
970               (if (logbitp  $lfbits-method-bit bits)
971                 'method-function         
972                 'compiled-function))))))) ;15
973                                     
974       
975
976
977 
978(defun %type-of (thing)
979  (let* ((f (fulltag thing)))
980    (funcall (%svref *x8664-%type-of-functions* f) thing)))
981
982       
983
984);#+x8664-target
985     
986
987;;; real machine specific huh
988(defun consp (x)
989  "Return true if OBJECT is a CONS, and NIL otherwise."
990  (consp x))
991
992(defun characterp (arg)
993  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
994  (characterp arg))
995
996(defun base-char-p (c)
997  (base-char-p c))
998
999
1000
1001
1002(defun structurep (form)
1003  "True if the given object is a named structure, Nil otherwise."
1004  (= (the fixnum (typecode form)) target::subtag-struct))
1005
1006(defun istructp (form)
1007  (= (the fixnum (typecode form)) target::subtag-istruct))
1008
1009
1010;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp.
1011;;; (If you've ever been "conused", I'm sure you know just how painful
1012;;; that can be.)
1013(defun structure-typep (thing type)
1014  (if (= (the fixnum (typecode thing)) target::subtag-struct)
1015
1016
1017    (let* ((types (%svref thing 0)))
1018      (if (typep type 'symbol)
1019        (dolist (x types)
1020          (when (eq (class-cell-name x) type)
1021            (return t)))
1022        (dolist (x types)
1023          (when (eq x type)
1024            (return t)))))))
1025
1026
1027
1028(defun istruct-typep (thing type)
1029  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1030    (eq (istruct-cell-name (%svref thing 0)) type)))
1031
1032(defun istruct-type-name (thing)
1033  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1034    (istruct-cell-name (%svref thing 0))))
1035
1036
1037;;; This is actually set to an alist in the xloader.
1038(defparameter *istruct-cells* nil)
1039
1040;;; This should only ever push anything on the list in the cold
1041;;; load (e.g., when running single-threaded.)
1042(defun register-istruct-cell (name)
1043  (or (assq name *istruct-cells*)
1044      (let* ((pair (cons name nil)))
1045        (push pair *istruct-cells*)
1046        pair)))
1047
1048(defun set-istruct-cell-info (cell info)
1049  (etypecase cell
1050    (cons (%rplacd cell info)))
1051  info)
1052
1053
1054(defun symbolp (thing)
1055  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
1056  #+(or ppc32-target x8632-target)
1057  (if thing
1058    (= (the fixnum (typecode thing)) target::subtag-symbol)
1059    t)
1060  #+ppc64-target
1061  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
1062  #+x8664-target
1063  (if thing
1064    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
1065    t)
1066  )
1067     
1068(defun packagep (thing)
1069  (= (the fixnum (typecode thing)) target::subtag-package))
1070
1071;;; 1 if by land, 2 if by sea.
1072(defun sequence-type (x)
1073  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
1074    (or (listp x)
1075        (report-bad-arg x 'sequence))))
1076
1077(defun uvectorp (x)
1078  (= (the fixnum (fulltag x)) target::fulltag-misc))
1079
1080(setf (type-predicate 'uvector) 'uvectorp)
1081
1082(defun listp (x)
1083  (listp x))
1084
1085(defparameter *type-cells* nil)
1086
1087
1088
1089(defparameter *type-cells-lock* nil)
1090
1091
1092;;; The weird handling to the special variables here has to do with
1093;;; xload issues.
1094(defun register-type-cell (specifier)
1095  (with-lock-grabbed ((or *type-cells-lock*
1096                         (setq *type-cells-lock* (make-lock))))
1097    (unless *type-cells*
1098      (setq *type-cells* (make-hash-table :test 'equal)))
1099    (or (values (gethash specifier *type-cells*))
1100        (setf (gethash specifier *type-cells*)
1101              (make-type-cell specifier)))))
1102
1103
1104(defvar %find-classes% nil)
1105
1106(setq %find-classes% (make-hash-table :test 'eq))
1107
1108
1109(defun find-class-cell (name create?)
1110  (unless %find-classes%
1111    (dbg name))
1112  (let ((cell (gethash name %find-classes%)))
1113    (or cell
1114        (and create?
1115             (setf (gethash name %find-classes%) (make-class-cell name))))))
1116
Note: See TracBrowser for help on using the repository browser.