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

Last change on this file since 929 was 929, checked in by bryan, 15 years ago

add docstrings to the majority of common-lisp-user symbols starting
with a snapshot of those found in SBCL 0.8.18.

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