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

Last change on this file since 309 was 309, checked in by gb, 16 years ago

DISPLACED-ARRAY-P didn't handle transitive displacement.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;; Non-portable type-predicates & such.
19
20
21;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils
22
23(defun find-builtin-cell (type &optional create)
24  (declare (ignore create))
25  (cons type nil))
26
27(defun find-class-cell (type create?)
28  (declare (ignore create?))
29  (cons type nil))
30
31(defun builtin-typep (form cell)
32  (typep form (car cell)))
33
34(defun class-cell-typep (arg class-cell)
35  (typep arg (car class-cell)))
36
37(defun class-cell-find-class (class-cell errorp)
38  (declare (ignore errorp)) ; AARGH can't be right
39  ;(dbg-paws #x100)
40  (let ((class (cdr class-cell)))
41    (or class 
42        (if  (fboundp 'find-class)
43          (find-class (car class-cell) nil)))))
44
45(defun %require-type-builtin (form foo)
46  (declare (ignore foo))
47  form)
48
49(defun %require-type-class-cell (form cell)
50  (declare (ignore cell))
51  form)
52 
53(defun non-nil-symbol-p (x)
54  (if (symbolp x) x))
55
56(defun pathnamep (thing)
57  (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname)))
58
59(defun compiled-function-p (form)
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)) ppc32::tag-fixnum))
72
73(defun bignump (x)
74  (= (the fixnum (typecode x)) ppc32::subtag-bignum))
75
76(defun integerp (x)
77  (let* ((typecode (typecode x)))
78    (declare (fixnum typecode))
79    (or (= typecode ppc32::tag-fixnum)
80        (= typecode ppc32::subtag-bignum))))
81
82(defun ratiop (x)
83  (= (the fixnum (typecode x)) ppc32::subtag-ratio))
84
85
86(defun rationalp (x)
87  (or (fixnump x)
88      (let* ((typecode (typecode x)))
89        (declare (fixnum typecode))
90        (and (>= typecode ppc32::min-numeric-subtag)
91             (<= typecode ppc32::max-rational-subtag)))))
92
93
94
95(defun short-float-p (x)
96  (= (the fixnum (typecode x)) ppc32::subtag-single-float))
97
98
99(defun double-float-p (x)
100  (= (the fixnum (typecode x)) ppc32::subtag-double-float))
101
102(defun floatp (x)
103  (let* ((typecode (typecode x)))
104    (declare (fixnum typecode))
105    (and (>= typecode ppc32::min-float-subtag)
106         (<= typecode ppc32::max-float-subtag))))
107
108(defun realp (x)
109  (let* ((typecode (typecode x)))
110    (declare (fixnum typecode))
111    (or (= typecode ppc32::tag-fixnum)
112        (and (>= typecode ppc32::min-numeric-subtag)
113             (<= typecode ppc32::max-real-subtag)))))
114
115(defun complexp (x)
116  (= (the fixnum (typecode x)) ppc32::subtag-complex))
117
118(defun numberp (x)
119  (let* ((typecode (typecode x)))
120    (declare (fixnum typecode))
121    (or (= typecode ppc32::tag-fixnum)
122        (and (>= typecode ppc32::min-numeric-subtag)
123             (<= typecode ppc32::max-numeric-subtag)))))
124
125(defun arrayp (x)
126  (>= (the fixnum (typecode x)) ppc32::min-array-subtag))
127
128(defun vectorp (x)
129  (>= (the fixnum (typecode x)) ppc32::min-vector-subtag))
130
131
132(defun stringp (x)
133  (let* ((typecode (typecode x)))
134    (declare (fixnum typecode))
135    (if (= typecode ppc32::subtag-vectorH)
136      (setq typecode (ldb ppc32::arrayH.flags-cell-subtag-byte (the fixnum (%svref x ppc32::arrayH.flags-cell)))))
137    (= typecode ppc32::subtag-simple-base-string)))
138
139
140(defun simple-base-string-p (x)
141  (= (the fixnum (typecode x)) ppc32::subtag-simple-base-string))
142
143(defun simple-string-p (x)
144  (= (the fixnum (typecode x)) ppc32::subtag-simple-base-string))
145
146(defun complex-array-p (x)
147  (let* ((typecode (typecode x)))
148    (declare (fixnum typecode))
149    (if (or (= typecode ppc32::subtag-arrayH)
150            (= typecode ppc32::subtag-vectorH))
151      (not (%array-header-simple-p x)))))
152
153(defun simple-array-p (thing)
154  "Returns T if the object is a simple array, else returns NIL.
155   That's why it's called SIMPLE-ARRAY-P.  Get it ?
156   A simple-array may have no fill-pointer, may not be displaced,
157   and may not be adjustable."
158  (let* ((typecode (typecode thing)))
159    (declare (fixnum typecode))
160    (if (or (= typecode ppc32::subtag-arrayH)
161            (= typecode ppc32::subtag-vectorH))
162      (%array-header-simple-p thing)
163      (> typecode ppc32::subtag-vectorH))))
164
165(defun macptrp (x)
166  (= (the fixnum (typecode x)) ppc32::subtag-macptr))
167
168
169; Note that this is true of symbols and functions and many other
170; things that it wasn't true of on the 68K.
171(defun gvectorp (x)
172  (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::fulltag-nodeheader))
173
174(setf (type-predicate 'gvector) 'gvectorp)
175
176(defun miscobjp (x)
177  (= (the fixnum (lisptag x)) ppc32::tag-misc))
178
179(defun simple-vector-p (x)
180  (= (the fixnum (typecode x)) ppc32::subtag-simple-vector))
181
182(defun base-string-p (thing)
183  (let* ((typecode (typecode thing)))
184    (declare (fixnum typecode))
185    (or (= typecode ppc32::subtag-simple-base-string)
186        (and (= typecode ppc32::subtag-vectorh)
187             (= (the fixnum 
188                  (ldb ppc32::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing ppc32::arrayH.flags-cell))))
189                ppc32::subtag-simple-base-string)))))
190
191(defun simple-bit-vector-p (form)
192  (= (the fixnum (typecode form)) ppc32::subtag-bit-vector))
193
194(defun bit-vector-p (thing)
195  (let* ((typecode (typecode thing)))
196    (declare (fixnum typecode))
197    (or (= typecode ppc32::subtag-bit-vector)
198        (and (= typecode ppc32::subtag-vectorh)
199             (= (the fixnum 
200                  (ldb ppc32::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing ppc32::arrayH.flags-cell))))
201                ppc32::subtag-bit-vector)))))
202
203(defun displaced-array-p (array)
204  (if (%array-is-header array)
205    (do* ((disp (%svref array ppc32::arrayH.displacement-cell)
206                (+ disp (the fixnum (%svref target ppc32::arrayH.displacement-cell))))
207          (target (%svref array ppc32::arrayH.data-vector-cell)
208                  (%svref target ppc32::arrayH.data-vector-cell)))
209         ((not (%array-is-header target))
210          (values target disp)))
211    (values nil 0)))
212
213
214
215(defun eq (x y) (eq x y))
216
217
218(defun cons-equal (x y)
219  (declare (cons x y))
220  (if (equal (car x) (car y))
221    (equal (cdr x) (cdr y))))
222
223(defun hairy-equal (x y)
224  (declare (optimize (speed 3)))
225  ; X and Y are not EQL, and are both of tag ppc32::fulltag-misc.
226  (let* ((x-type (typecode x))
227         (y-type (typecode y)))
228    (declare (fixnum x-type y-type))
229    (if (and (>= x-type ppc32::subtag-vectorH)
230             (>= y-type ppc32::subtag-vectorH))
231        (let* ((x-simple (if (= x-type ppc32::subtag-vectorH)
232                             (ldb ppc32::arrayH.flags-cell-subtag-byte 
233                                  (the fixnum (%svref x ppc32::arrayH.flags-cell)))
234                             x-type))
235               (y-simple (if (= y-type ppc32::subtag-vectorH)
236                             (ldb ppc32::arrayH.flags-cell-subtag-byte 
237                                  (the fixnum (%svref y ppc32::arrayH.flags-cell)))
238                             y-type)))
239          (declare (fixnum x-simple y-simple))
240          (if (= x-simple ppc32::subtag-simple-base-string)
241              (if (= y-simple ppc32::subtag-simple-base-string)
242                  (locally
243                      (declare (optimize (speed 3) (safety 0)))
244                    (let* ((x-len (if (= x-type ppc32::subtag-vectorH) 
245                                      (%svref x ppc32::vectorH.logsize-cell)
246                                      (uvsize x)))
247                           (x-pos 0)
248                           (y-len (if (= y-type ppc32::subtag-vectorH) 
249                                      (%svref y ppc32::vectorH.logsize-cell)
250                                      (uvsize y)))
251                           (y-pos 0))
252                      (declare (fixnum x-len x-pos y-len y-pos))
253                      (when (= x-type ppc32::subtag-vectorH)
254                        (multiple-value-setq (x x-pos) (array-data-and-offset x)))
255                      (when (= y-type ppc32::subtag-vectorH)
256                        (multiple-value-setq (y y-pos) (array-data-and-offset y)))
257                      (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len))))))
258              ;;Bit-vector case or fail.
259              (and (= x-simple ppc32::subtag-bit-vector)
260                   (= y-simple ppc32::subtag-bit-vector)
261                   (locally
262                       (declare (optimize (speed 3) (safety 0)))
263                     (let* ((x-len (if (= x-type ppc32::subtag-vectorH) 
264                                       (%svref x ppc32::vectorH.logsize-cell)
265                                       (uvsize x)))
266                            (x-pos 0)
267                            (y-len (if (= y-type ppc32::subtag-vectorH) 
268                                       (%svref y ppc32::vectorH.logsize-cell)
269                                       (uvsize y)))
270                            (y-pos 0))
271                       (declare (fixnum x-len x-pos y-len y-pos))
272                       (when (= x-len y-len)
273                         (when (= x-type ppc32::subtag-vectorH)
274                           (multiple-value-setq (x x-pos) (array-data-and-offset x)))
275                         (when (= y-type ppc32::subtag-vectorH)
276                           (multiple-value-setq (y y-pos) (array-data-and-offset y)))
277                         (do* ((i 0 (1+ i)))
278                              ((= i x-len) t)
279                           (declare (fixnum i))
280                           (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos)))
281                             (return))
282                           (incf x-pos)
283                           (incf y-pos))))))))
284        (if (= x-type y-type)
285            (if (= x-type ppc32::subtag-istruct)
286                (and (let* ((structname (%svref x 0)))
287                       (and (eq structname (%svref y 0))
288                            (or (eq structname 'pathname)
289                                (eq structname 'logical-pathname))))
290                     (locally
291                         (declare (optimize (speed 3) (safety 0)))
292                       (let* ((x-size (uvsize x)))
293                         (declare (fixnum x-size))
294                         (if (= x-size (the fixnum (uvsize y)))
295                             (do* ((i 1 (1+ i)))
296                                  ((= i x-size) t)
297                               (declare (fixnum i))
298                               (unless (equal (%svref x i) (%svref y i))
299                                 (return))))))))))))
300
301(defparameter *nodeheader-types*
302  #(bogus                               ; 0
303    ratio                               ; 1
304    bogus                               ; 2
305    complex                             ; 3
306    catch-frame                         ; 4
307    function                            ; 5
308    lisp-thread                         ; 6
309    symbol                              ; 7
310    lock                                ; 8
311    hash-table-vector                   ; 9
312    pool                                ; 10
313    population                          ; 11
314    package                             ; 12
315    slot-vector                         ; 13
316    standard-instance                   ; 14
317    structure                           ; 15
318    internal-structure                  ; 16
319    value-cell                          ; 17
320    xfunction                           ; 18
321    svar                                ; 19
322    array-header                        ; 20
323    vector-header                       ; 21
324    simple-vector                       ; 22
325    bogus                               ; 23
326    bogus                               ; 24
327    bogus                               ; 25
328    bogus                               ; 26
329    bogus                               ; 27
330    bogus                               ; 28
331    bogus                               ; 29
332    bogus                               ; 30
333    bogus                               ; 31
334    ))
335
336(defparameter *immheader-types*
337  #(bignum                              ; 0
338    short-float                         ; 1
339    double-float                        ; 2
340    macptr                              ; 3
341    dead-macptr                         ; 4
342    code-vector                         ; 5
343    creole-object                       ; 6
344    ;; 8-20 are unused
345    xcode-vecor                         ; 7
346    bogus                               ; 8
347    bogus                               ; 9
348    bogus                               ; 10
349    bogus                               ; 11
350    bogus                               ; 12
351    bogus                               ; 13
352    bogus                               ; 14
353    bogus                               ; 15
354    bogus                               ; 16
355    bogus                               ; 17
356    bogus                               ; 18
357    bogus                               ; 19
358    bogus                               ; 20
359    simple-short-float-vector           ; 21
360    simple-unsigned-long-vector         ; 22
361    simple-signed-long-vector           ; 23
362    simple-unsigned-byte-vector         ; 24
363    simple-signed-byte-vector           ; 25
364    simple-base-string                  ; 26
365    *unused*                            ; 27
366    simple-unsigned-word-vector         ; 28
367    simple-signed-word-vector           ; 29
368    simple-double-float-vector          ; 30
369    simple-bit-vector                   ; 31
370    ))
371
372
373
374
375
376(defun %type-of (thing)
377  (let* ((typecode (typecode thing)))
378    (declare (fixnum typecode))
379    (if (= typecode ppc32::tag-fixnum)
380      'fixnum
381      (if (= typecode ppc32::tag-list)
382        (if thing 'cons 'null)
383        (if (= typecode ppc32::tag-imm)
384          (if (base-char-p thing)
385            'base-char
386            'immediate)
387          (if (= typecode ppc32::subtag-macptr)
388            (if (classp thing)
389              (class-name thing)
390              'macptr)
391            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
392                   (tag-val (ash typecode (- ppc32::ntagbits))))
393              (declare (fixnum tag-type tag-val))
394              (if (/= tag-type ppc32::fulltag-nodeheader)
395                (%svref *immheader-types* tag-val)
396                (let ((type (%svref *nodeheader-types* tag-val)))
397                  (if (eq type 'function)
398                    (let ((bits (lfun-bits thing)))
399                      (declare (fixnum bits))
400                      (if (logbitp $lfbits-trampoline-bit bits)
401                        (if (logbitp $lfbits-evaluated-bit bits)
402                          'interpreted-lexical-closure
403                          (let ((inner-fn (closure-function thing)))
404                            (if (neq inner-fn thing)
405                              (let ((inner-bits (lfun-bits inner-fn)))
406                                (if (logbitp $lfbits-method-bit inner-bits)
407                                  'compiled-lexical-closure
408                                  (if (logbitp $lfbits-gfn-bit inner-bits)
409                                    'standard-generic-function ; not precisely - see class-of
410                                    (if (logbitp  $lfbits-cm-bit inner-bits)
411                                      'combined-method
412                                      'compiled-lexical-closure))))
413                              'compiled-lexical-closure)))
414                        (if (logbitp $lfbits-evaluated-bit bits)
415                          (if (logbitp $lfbits-method-bit bits)
416                            'interpreted-method-function
417                            'interpreted-function)
418                          (if (logbitp  $lfbits-method-bit bits)
419                            'method-function         
420                            'compiled-function))))
421                    (if (eq type 'lock)
422                      (or (uvref thing ppc32::lock.kind-cell)
423                          type)
424                      type)))))))))))
425
426
427; real machine specific huh
428(defun consp (x) (consp x))
429
430(defun characterp (arg)
431  (characterp arg))
432
433(defun base-char-p (c)
434  (base-char-p c))
435
436
437
438
439(defun structurep (form)
440  "True if the given object is a named structure, Nil otherwise."
441  (= (the fixnum (typecode form)) ppc32::subtag-struct))
442
443(defun istructp (form)
444  (= (the fixnum (typecode form)) ppc32::subtag-istruct))
445
446(defun structure-typep (thing type)
447  (if (= (the fixnum (typecode thing)) ppc32::subtag-struct)
448    (if (memq type (%svref thing 0))
449      t)))
450
451
452(defun istruct-typep (thing type)
453  (if (= (the fixnum (typecode thing)) ppc32::subtag-istruct)
454    (eq (%svref thing 0) type)))
455
456(defun symbolp (thing)
457  (if thing
458    (= (the fixnum (typecode thing)) ppc32::subtag-symbol)
459    t))
460
461(defun packagep (thing)
462  (= (the fixnum (typecode thing)) ppc32::subtag-package))
463
464; 1 if by land, 2 if by sea.
465(defun sequence-type (x)
466  (unless (>= (the fixnum (typecode x)) ppc32::min-vector-subtag)
467    (or (listp x)
468        (report-bad-arg x 'sequence))))
469
470;; I'm really skeptical about anything that calls UVECTORP
471;; (in that I'm afraid that it thinks that it knows what's
472;; a "uvector" and what isn't.
473(defun uvectorp (x)
474  (= (the fixnum (lisptag x)) ppc32::tag-misc))
Note: See TracBrowser for help on using the repository browser.