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

Last change on this file since 15601 was 15601, checked in by gb, 6 years ago

Logical host names aren't case-sensitive in CCL; don't hash logical
pathnames (or compare them with EQUAL) as if they were.

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