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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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