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

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

Fix parenthesization in HAIRY-EQUAL; fixes ticket:1054 in the trunk.

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