25 |
|
|
26 |
(in-package 'system) |
(in-package 'system) |
27 |
|
|
28 |
(export '(lisp::upgraded-complex-part-type |
(export '(lisp::upgraded-complex-part-type lisp::type-of |
29 |
lisp::deftype lisp::typep lisp::subtypep |
lisp::deftype lisp::typep lisp::subtypep |
30 |
lisp::coerce lisp::upgraded-array-element-type) 'lisp) |
lisp::coerce lisp::upgraded-array-element-type) 'lisp) |
31 |
|
|
37 |
(eval-when (compile) |
(eval-when (compile) |
38 |
(proclaim '(optimize (safety 0) (space 3) (speed 3)))) |
(proclaim '(optimize (safety 0) (space 3) (speed 3)))) |
39 |
|
|
40 |
|
(defun type-of (object) |
41 |
|
(or (and (typep object 'standard-object) |
42 |
|
(let* ((c (class-of object)) |
43 |
|
(n (class-name c))) |
44 |
|
(if (and n (eq c (find-class n nil))) n c))) |
45 |
|
(let ((tp (type-of-c object))) |
46 |
|
(if (member tp '(vector array));FIXME |
47 |
|
`(,tp ,(upgraded-array-element-type (array-element-type object))) |
48 |
|
tp)))) |
49 |
|
|
50 |
(defun typep-int (object type &aux tp i tem) |
(defun typep-int (object type &aux tp i tem) |
51 |
(if (atom type) |
(if (atom type) |
52 |
(setq tp type i nil) |
(setq tp type i nil) |
53 |
(setq tp (car type) i (cdr type))) |
(setq tp (car type) i (cdr type))) |
54 |
|
(when (or (eq tp 'values) (and (eq tp 'function) i)) |
55 |
|
(error "Bad type to typep: ~S" type)) |
56 |
(if (eq tp 'structure-object) (setq tp 'structure)) |
(if (eq tp 'structure-object) (setq tp 'structure)) |
57 |
(when (and (eq tp 'structure) (typep-int object 'standard-object)) |
(when (and (member tp '(structure compiled-function)) (typep-int object 'standard-object)) |
58 |
(return-from typep-int nil)) |
(return-from typep-int nil)) |
59 |
(let ((f (and (not i) (symbolp tp) (get tp 'type-predicate)))) |
(let ((f (and (not i) (symbolp tp) (get tp 'type-predicate)))) |
60 |
(when f (return-from typep-int (let ((z (funcall f object))) z)))) |
(when f (return-from typep-int (let ((z (funcall f object))) z)))) |
61 |
(case tp |
(case tp |
62 |
(cons (and (consp object) |
(cons (and (consp object) |
63 |
(or (endp i) |
(or (not i) |
64 |
(and (typep-int (car object) (car i)) |
(and (typep-int (car object) (car i)) |
65 |
(or (endp (cdr i)) |
(or (endp (cdr i)) |
66 |
(typep-int (cdr object) (cadr i))))))) |
(typep-int (cdr object) (cadr i))))))) |
78 |
((t) t) |
((t) t) |
79 |
((nil) nil) |
((nil) nil) |
80 |
(boolean (or (eq object 't) (eq object 'nil))) |
(boolean (or (eq object 't) (eq object 'nil))) |
81 |
(fixnum (eq (type-of object) 'fixnum)) |
(bignum (member (type-of-c object) '(bignum non-negative-bignum negative-bignum))) |
82 |
(bignum (eq (type-of object) 'bignum)) |
(ratio (eq (type-of-c object) 'ratio)) |
|
(ratio (eq (type-of object) 'ratio)) |
|
|
(standard-char |
|
|
(and (characterp object) (standard-char-p object))) |
|
83 |
((base-char string-char) |
((base-char string-char) |
84 |
(and (characterp object) (string-char-p object))) |
(and (characterp object) (string-char-p object))) |
85 |
(integer |
(integer |
91 |
(float |
(float |
92 |
(and (floatp object) (in-interval-p object i))) |
(and (floatp object) (in-interval-p object i))) |
93 |
((short-float) |
((short-float) |
94 |
(and (eq (type-of object) 'short-float) (in-interval-p object i))) |
(and (eq (type-of-c object) 'short-float) (in-interval-p object i))) |
95 |
((single-float double-float long-float) |
((single-float double-float long-float) |
96 |
(and (eq (type-of object) 'long-float) (in-interval-p object i))) |
(and (eq (type-of-c object) 'long-float) (in-interval-p object i))) |
97 |
(complex |
(complex |
98 |
(and (complexp object) |
(and (complexp object) |
99 |
|
(or (null i) |
100 |
(or (null i) |
(and (typep-int (realpart object) (car i)) |
101 |
(and (typep-int (realpart object) (car i)) |
;;wfs--should only have to check one. |
102 |
;;wfs--should only have to check one. |
;;Illegal to mix real and imaginary types! |
103 |
;;Illegal to mix real and imaginary types! |
(typep-int (imagpart object) (car i)))))) |
|
(typep-int (imagpart object) (car i)))) |
|
|
)) |
|
104 |
(sequence (or (listp object) (vectorp object))) |
(sequence (or (listp object) (vectorp object))) |
105 |
((base-string string) ;FIXME |
((base-string string simple-base-string simple-string) ;FIXME |
106 |
(and (stringp object) |
(and (stringp object) |
107 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
108 |
(bit-vector |
((bit-vector simple-bit-vector) |
109 |
(and (bit-vector-p object) |
(and (bit-vector-p object) |
110 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
111 |
((simple-base-string simple-string) ;FIXME |
((vector simple-vector) |
|
(and (simple-string-p object) |
|
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
|
|
(simple-bit-vector |
|
|
(and (simple-bit-vector-p object) |
|
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
|
|
(simple-vector |
|
|
(and (simple-vector-p object) |
|
|
(or (endp i) (eq (car i) '*) |
|
|
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
|
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
|
|
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
|
|
(vector |
|
112 |
(and (vectorp object) |
(and (vectorp object) |
113 |
(or (endp i) (eq (car i) '*) |
(let ((at (upgraded-array-element-type (or (car i) (if (eq tp 'vector) '* t))))) |
114 |
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
(or (eq at '*) (eq at (upgraded-array-element-type (array-element-type object))))) |
115 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
(or (not (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
116 |
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
((array simple-array) |
|
(simple-array |
|
|
(and (simple-array-p object) |
|
|
(or (endp i) (eq (car i) '*) |
|
|
(equal (array-element-type object)(best-array-element-type (car i)))) |
|
|
(or (endp (cdr i)) (eq (cadr i) '*) |
|
|
(if (listp (cadr i)) |
|
|
(match-dimensions (array-dimensions object) (cadr i)) |
|
|
(eql (array-rank object) (cadr i)))))) |
|
|
(array |
|
117 |
(and (arrayp object) |
(and (arrayp object) |
118 |
(or (endp i) (eq (car i) '*) |
(let ((at (upgraded-array-element-type (or (car i) '*)))) |
119 |
;; Or the element type of object should be EQUAL to (car i). |
(or (eq at '*) (eq at (upgraded-array-element-type (array-element-type object))))) |
120 |
;; Is this too strict? |
(or (not (cdr i)) (eq (cadr i) '*) |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
|
|
(or (endp (cdr i)) (eq (cadr i) '*) |
|
121 |
(if (listp (cadr i)) |
(if (listp (cadr i)) |
122 |
(match-dimensions (array-dimensions object) (cadr i)) |
(match-dimensions (array-dimensions object) (cadr i)) |
123 |
(eql (array-rank object) (cadr i)))))) |
(eql (array-rank object) (cadr i)))))) |
124 |
(file-stream (eq (type-of object) 'file-stream)) |
((file-stream string-stream synonym-stream concatenated-stream |
125 |
(string-stream (eq (type-of object) 'string-stream)) |
broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp)) |
|
(synonym-stream (eq (type-of object) 'synonym-stream)) |
|
|
(concatenated-stream (eq (type-of object) 'concatenated-stream)) |
|
|
(two-way-stream (eq (type-of object) 'two-way-stream)) |
|
|
(echo-stream (eq (type-of object) 'echo-stream)) |
|
|
(logical-pathname |
|
|
(and (pathnamep object) |
|
|
(not (endp (si:pathname-lookup (pathname-host object) |
|
|
si:*pathname-logical*))))) |
|
126 |
(t (cond |
(t (cond |
127 |
((setq tem (when (symbolp tp) (get tp 'deftype-definition))) |
((setq tem (when (symbolp tp) (get tp 'deftype-definition))) |
128 |
(typep-int object (apply tem i))) |
(typep-int object (apply tem i))) |
129 |
((if (symbolp tp) (get tp 'si::s-data) (typep-int tp 's-data)) |
((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data)) |
130 |
(let ((z (structure-subtype-p object tp))) z)) |
(let ((z (structure-subtype-p object tp))) z)) |
131 |
((typep tp 'class) |
((classp tp) |
132 |
(values (subtypep (type-of object) tp))))))) |
(values (subtypep (class-of object) tp))))))) |
133 |
|
|
134 |
|
|
135 |
;;; TYPEP predicate. |
;;; TYPEP predicate. |
192 |
(declare (ignore env) (optimize (safety 1))) |
(declare (ignore env) (optimize (safety 1))) |
193 |
(if (or (not t1) (eq t2 t)) |
(if (or (not t1) (eq t2 t)) |
194 |
(values t t) |
(values t t) |
195 |
(values (not (resolve-type `(and ,t1 ,(negate t2)))) t))) |
(let ((rt (resolve-type `(and ,t1 ,(negate t2))))) |
196 |
|
(values (not (car rt)) (not (cadr rt)))))) |
197 |
|
|
198 |
(defun upgraded-complex-part-type (type &optional environment) |
(defun upgraded-complex-part-type (type &optional environment) |
199 |
(declare (ignore environment) (optimize (safety 1)) ) |
(declare (ignore environment) (optimize (safety 1)) ) |
216 |
(if (atom type) (setq type (list type))) |
(if (atom type) (setq type (list type))) |
217 |
(case (car type) |
(case (car type) |
218 |
(function |
(function |
219 |
(assert-type object 'symbol) |
(cond ((symbolp object) (symbol-function object)) |
220 |
(symbol-function object)) |
((and (consp object) (eq (car object) 'lambda)) (eval `(function ,object))) |
221 |
|
((function-identifierp object) (get (cadr object) 'setf-function))));FIXME |
222 |
(list |
(list |
223 |
(do ((l nil (cons (elt object i) l)) |
(do ((l nil (cons (elt object i) l)) |
224 |
(i (1- (length object)) (1- i))) |
(i (1- (length object)) (1- i))) |
225 |
((< i 0) l))) |
((< i 0) l))) |
226 |
((array simple-array vector simple-vector bit-vector string simple-string) |
((array simple-array vector simple-vector bit-vector simple-bit-vector string simple-string) |
227 |
(when (cdr type) ;;FIXME |
(when (cdr type) ;;FIXME |
228 |
(assert-type (cdr type) 'cons) |
(assert-type (cdr type) 'cons) |
229 |
(when (cddr type) |
(when (cddr type) |
247 |
(t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)))) |
(t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)))) |
248 |
|
|
249 |
;;; DEFTYPE macro. |
;;; DEFTYPE macro. |
250 |
(defmacro deftype (name lambda-list &rest body) |
(defmacro deftype (name lambda-list &rest body &aux decls) |
251 |
;; Replace undefaultized optional parameter X by (X '*). |
;; Replace undefaultized optional parameter X by (X '*). |
252 |
(declare (optimize (safety 1))) |
(declare (optimize (safety 1))) |
253 |
|
(do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls)) |
254 |
|
(let ((d (pop body))) |
255 |
|
(unless (member-if (lambda (x) (and (consp x) (eq (car x) 'special))) (cdr d)) ;FIXME |
256 |
|
(push d decls)))) |
257 |
(do ((l lambda-list (cdr l)) |
(do ((l lambda-list (cdr l)) |
258 |
(m nil (cons (car l) m))) |
(m nil (cons (car l) m))) |
259 |
((null l)) |
((null l)) |
260 |
(when (member (car l) lambda-list-keywords) |
(when (member (car l) lambda-list-keywords) |
261 |
(unless (eq (car l) '&optional) (return nil)) |
(unless (member (car l) '(&optional &key)) (return nil)) |
262 |
(setq m (cons '&optional m)) |
(setq m (cons (car l) m)) |
263 |
(setq l (cdr l)) |
(setq l (cdr l)) |
264 |
(do () |
(do () |
265 |
((or (null l) (member (car l) lambda-list-keywords))) |
((or (null l) (member (car l) lambda-list-keywords))) |
270 |
(setq lambda-list (nreconc m l)) |
(setq lambda-list (nreconc m l)) |
271 |
(return nil))) |
(return nil))) |
272 |
`(eval-when (compile eval load) |
`(eval-when (compile eval load) |
273 |
(si:putprop ',name |
(putprop ',name |
274 |
'(deftype ,name ,lambda-list ,@body) |
'(deftype ,name ,lambda-list ,@body) |
275 |
'deftype-form) |
'deftype-form) |
276 |
(si:putprop ',name |
(putprop ',name |
277 |
(if (null ',lambda-list) |
(if (null ',lambda-list) |
278 |
(let ((tem (progn ,@body))) |
(lambda nil ,@decls (block ,name ,`(progn ,@body))) |
279 |
(lambda ,lambda-list tem)) |
(lambda ,lambda-list ,@decls (block ,name ,@body))) |
|
(lambda ,lambda-list ,@body)) |
|
280 |
'deftype-definition) |
'deftype-definition) |
281 |
(si:putprop ',name |
(putprop ',name |
282 |
,(find-documentation body) |
,(find-documentation body) |
283 |
'type-documentation) |
'type-documentation) |
284 |
',name)) |
',name)) |
293 |
`(integer 0 ,(1- n))) |
`(integer 0 ,(1- n))) |
294 |
(deftype non-negative-byte (&optional s) |
(deftype non-negative-byte (&optional s) |
295 |
(if (eq s '*) |
(if (eq s '*) |
296 |
`(integer * *) |
`(integer 0 *) |
297 |
`(integer 0 ,(1- (expt 2 (1- s)))))) |
`(integer 0 ,(1- (expt 2 (1- s)))))) |
298 |
(deftype negative-byte (&optional s) |
(deftype negative-byte (&optional s) |
299 |
(if (eq s '*) |
(if (eq s '*) |
300 |
`(integer * *) |
`(integer * -1) |
301 |
`(integer ,(- (expt 2 (1- s))) -1))) |
`(integer ,(- (expt 2 (1- s))) -1))) |
302 |
(deftype signed-byte (&optional s) |
(deftype signed-byte (&optional s) |
303 |
(if (eq s '*) |
(if (eq s '*) |
336 |
(deftype vector (&optional element-type size) |
(deftype vector (&optional element-type size) |
337 |
`(array ,element-type (,size))) |
`(array ,element-type (,size))) |
338 |
(deftype string (&optional size) |
(deftype string (&optional size) |
339 |
`(vector string-char ,size)) |
`(array string-char (,size))) |
340 |
(deftype base-string (&optional size) |
(deftype base-string (&optional size) |
341 |
`(vector base-char ,size)) |
`(array base-char (,size))) |
342 |
(deftype bit-vector (&optional size) |
(deftype bit-vector (&optional size) |
343 |
`(vector bit ,size)) |
`(array bit (,size))) |
344 |
|
|
345 |
(deftype simple-vector (&optional size) |
(deftype simple-vector (&optional size) |
346 |
`(simple-array t (,size))) |
`(array t (,size))) |
347 |
(deftype simple-string (&optional size) |
(deftype simple-string (&optional size) |
348 |
`(simple-array string-char (,size))) |
`(array string-char (,size))) |
349 |
(deftype simple-base-string (&optional size) |
(deftype simple-base-string (&optional size) |
350 |
`(simple-array base-char (,size))) |
`(array base-char (,size))) |
351 |
(deftype simple-bit-vector (&optional size) |
(deftype simple-bit-vector (&optional size) |
352 |
`(simple-array bit (,size))) |
`(array bit (,size))) |
353 |
|
|
354 |
(deftype function-identifier () `(satisfies si::function-identifierp)) |
(deftype function-identifier () `(satisfies function-identifierp)) |
355 |
|
|
356 |
|
|
357 |
(deftype list () `(or cons null)) |
(deftype list () `(or cons null)) |
358 |
(deftype sequence () `(or list vector)) |
(deftype sequence () `(or list vector)) |
359 |
|
|
360 |
|
(defun non-standard-base-char-p (x) |
361 |
|
(and (characterp x) (not (standard-char-p x)))) |
362 |
|
|
363 |
|
(deftype extended-char () nil) |
364 |
|
(deftype base-char () `(or standard-char non-standard-base-char)) |
365 |
(deftype character () `(or base-char extended-char)) |
(deftype character () `(or base-char extended-char)) |
366 |
(deftype string-char () `(or base-char extended-char)) |
(deftype string-char () `character) |
367 |
|
|
368 |
(deftype stream () `(or broadcast-stream concatenated-stream echo-stream |
(deftype stream () `(or broadcast-stream concatenated-stream echo-stream |
369 |
file-stream string-stream synonym-stream two-way-stream)) |
file-stream string-stream synonym-stream two-way-stream)) |
370 |
|
|
371 |
(deftype bignum () `(and integer (not fixnum))) |
(deftype bignum () `(and integer (not fixnum))) |
372 |
|
(deftype non-negative-bignum () `(and non-negative-byte (not non-negative-fixnum))) |
373 |
|
(deftype negative-bignum () `(and negative-byte (not negative-fixnum))) |
374 |
;;FIXME adjust integer bounds here? |
;;FIXME adjust integer bounds here? |
375 |
(deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high))) |
(deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high))) |
376 |
(deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high))) |
(deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high))) |
379 |
(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high))) |
(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high))) |
380 |
(deftype number () `(or real complex)) |
(deftype number () `(or real complex)) |
381 |
(deftype atom () `(not cons)) |
(deftype atom () `(not cons)) |
382 |
(deftype function (&optional as vs) `(or interpreted-function compiled-function)) |
(deftype function (&optional as vs) `(or interpreted-function compiled-function generic-function)) |
|
(deftype base-char () `(or standard-char non-standard-base-char)) |
|
383 |
|
|
384 |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
385 |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
389 |
(deftype array (&optional (et '*) (dims '*)) |
(deftype array (&optional (et '*) (dims '*)) |
390 |
`(array ,et ,(if (not dims) 0 dims))) |
`(array ,et ,(if (not dims) 0 dims))) |
391 |
(deftype simple-array (&optional (et '*) (dims '*)) |
(deftype simple-array (&optional (et '*) (dims '*)) |
392 |
`(simple-array ,et ,(if (not dims) 0 dims))) |
`(array ,et ,(if (not dims) 0 dims))) |
393 |
|
|
394 |
(deftype eql (&optional (x nil xp)) (when xp `(member ,x))) |
(deftype eql (&optional (x nil xp)) (when xp `(member ,x))) |
395 |
|
|
403 |
(deftype complex (&optional (rp 'real)) `(complex ,(if (eq rp '*) 'real rp))) |
(deftype complex (&optional (rp 'real)) `(complex ,(if (eq rp '*) 'real rp))) |
404 |
(deftype cons (&optional (car t) (cdr t)) `(cons ,(if (eq car '*) t car) ,(if (eq cdr '*) t cdr))) |
(deftype cons (&optional (car t) (cdr t)) `(cons ,(if (eq car '*) t car) ,(if (eq cdr '*) t cdr))) |
405 |
(deftype structure-object () `(structure)) |
(deftype structure-object () `(structure)) |
406 |
|
(deftype pathname () `(or non-logical-pathname logical-pathname)) |
407 |
|
|
408 |
|
(defun non-logical-pathname-p (x) |
409 |
|
(and (pathnamep x) (not (logical-pathname-p x)))) |
410 |
|
|
411 |
(defun non-keyword-symbol-p (x) |
(defun non-keyword-symbol-p (x) |
412 |
(and (symbolp x) (not (keywordp x)))) |
(and (symbolp x) (not (keywordp x)))) |
413 |
|
|
414 |
(defun function-identifierp (tp) |
(defun function-identifierp (tp) |
415 |
(or (symbolp tp) |
(or (symbolp tp) |
416 |
|
(and (consp tp) (eq (car tp) 'lambda)) |
417 |
(and (consp tp) |
(and (consp tp) |
418 |
(eq (car tp) 'setf) |
(eq (car tp) 'setf) |
419 |
(consp (cdr tp)) |
(consp (cdr tp)) |
420 |
(symbolp (cadr tp)) |
(symbolp (cadr tp)) |
421 |
(not (cddr tp))))) |
(not (cddr tp))))) |
422 |
|
|
423 |
(defun simple-array-p (x) |
;(defun simple-array-p (x) |
424 |
(and (arrayp x) |
; (and (arrayp x) |
425 |
;; should be (not (expressly-adjustable-p x)) |
;; should be (not (expressly-adjustable-p x)) |
426 |
;; since the following will always return T |
;; since the following will always return T |
427 |
;; (not (adjustable-array-p x)) |
;; (not (adjustable-array-p x)) |
428 |
(not (array-has-fill-pointer-p x)) |
; (not (array-has-fill-pointer-p x)) |
429 |
(not (si:displaced-array-p x)))) |
; (not (displaced-array-p x)))) |
430 |
|
|
431 |
|
|
432 |
(defun non-standard-base-char-p (x) |
;(defun extended-char-p (x) (declare (ignore x)) nil) |
|
(and (characterp x) (not (standard-char-p x)))) |
|
|
|
|
|
(defun extended-char-p (x) (declare (ignore x)) nil) |
|
433 |
|
|
434 |
(defun interpreted-function-p (x) |
;(defun interpreted-function-p (x) |
435 |
(and (function-p x) (not (compiled-function-p x)))) |
; (and (function-p x) (not (compiled-function-p x)))) |
436 |
|
|
437 |
(defun function-p (x) |
;(defun function-p (x) |
438 |
(and (not (symbolp x)) (functionp x))) |
; (and (not (symbolp x)) (functionp x))) |
439 |
|
|
440 |
(do ((l '((null . null) |
(do ((l '((null . null) |
441 |
(symbol . symbolp) |
(symbol . symbolp) |
442 |
(keyword . keywordp) |
(keyword . keywordp) |
443 |
(is-t . is-t-p) |
(non-logical-pathname . non-logical-pathname-p) |
444 |
|
(logical-pathname . logical-pathname-p) |
445 |
(non-keyword-symbol . non-keyword-symbol-p) |
(non-keyword-symbol . non-keyword-symbol-p) |
446 |
(standard-char . standard-char-p) |
(standard-char . standard-char-p) |
447 |
(non-standard-base-char . non-standard-base-char-p) |
(non-standard-base-char . non-standard-base-char-p) |
|
(extended-char . extended-char-p) |
|
448 |
(string-char . string-char-p);;FIXME |
(string-char . string-char-p);;FIXME |
449 |
(interpreted-function . interpreted-function-p) |
(interpreted-function . interpreted-function-p) |
450 |
(atom . atom) |
(atom . atom) |
461 |
(readtable . readtablep) |
(readtable . readtablep) |
462 |
(hash-table . hash-table-p) |
(hash-table . hash-table-p) |
463 |
(random-state . random-state-p) |
(random-state . random-state-p) |
464 |
(structure . si:structurep) |
(structure . structurep) |
465 |
(function . function-p) |
(function . functionp) |
466 |
(compiled-function . compiled-function-p) |
(compiled-function . compiled-function-p) |
467 |
(common . commonp) |
(common . commonp) |
468 |
) |
) |
469 |
(cdr l))) |
(cdr l))) |
470 |
((endp l)) |
((endp l)) |
471 |
(si:putprop (caar l) (cdar l) 'type-predicate) |
(putprop (caar l) (cdar l) 'type-predicate) |
472 |
(when (symbolp (cdar l)) |
(when (symbolp (cdar l)) |
473 |
(si:putprop (cdar l) (caar l) 'predicate-type) |
(putprop (cdar l) (caar l) 'predicate-type) |
474 |
(proclaim `(ftype (function (t) t) ,(cdar l))))) |
(proclaim `(ftype (function (t) t) ,(cdar l))))) |
475 |
|
|
476 |
|
|
477 |
(defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char |
(defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char |
478 |
non-standard-base-char extended-char |
non-standard-base-char |
479 |
package cons-member |
package cons-member |
480 |
broadcast-stream concatenated-stream echo-stream file-stream string-stream |
broadcast-stream concatenated-stream echo-stream file-stream string-stream |
481 |
synonym-stream two-way-stream |
synonym-stream two-way-stream |
482 |
pathname readtable hash-table random-state standard-object structure |
non-logical-pathname logical-pathname |
483 |
|
readtable hash-table random-state standard-object structure |
484 |
interpreted-function |
interpreted-function |
485 |
compiled-function)) |
compiled-function)) |
486 |
|
|
487 |
|
|
488 |
(defconstant +range-types+ `(integer ratio short-float long-float)) |
(defconstant +range-types+ `(integer ratio short-float long-float)) |
489 |
(defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short |
(defconstant +array-types+ '(nil character bit ;FIXME try to live with unsigned alone if can work out the C casting |
490 |
fixnum short-float long-float t)) |
non-negative-char signed-char unsigned-char |
491 |
|
non-negative-short signed-short unsigned-short |
492 |
|
non-negative-fixnum fixnum |
493 |
|
short-float long-float t)) |
494 |
|
|
495 |
(defconstant +known-types+ (append +range-types+ |
(defconstant +known-types+ (append +range-types+ |
496 |
(mapcar (lambda (x) `(complex ,x)) +range-types+) |
(mapcar (lambda (x) `(complex ,x)) +range-types+) |
497 |
+singleton-types+ |
+singleton-types+ |
498 |
(mapcar (lambda (x) `(array ,x)) +array-types+))) |
(mapcar (lambda (x) `(array ,x)) +array-types+))) |
499 |
|
|
500 |
(defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "ARRAY-" (string x))))) |
(defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "ARRAY-" (string x))))) |
501 |
+array-types+)) |
+array-types+)) |
502 |
(defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "COMPLEX-" (string x))))) |
(defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "COMPLEX-" (string x))))) |
503 |
+range-types+)) |
+range-types+)) |
504 |
|
|
505 |
(defconstant +kindom-logic-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-op)) +range-types+) |
(defconstant +kindom-logic-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-op)) +range-types+) |
524 |
(standard-object . standard-load) |
(standard-object . standard-load) |
525 |
(structure . structure-load) |
(structure . structure-load) |
526 |
(array . array-load) |
(array . array-load) |
527 |
(simple-array . array-load) |
; (simple-array . array-load) |
528 |
,@(mapcar (lambda (x) `(,x . single-load)) +singleton-types+))) |
,@(mapcar (lambda (x) `(,x . single-load)) +singleton-types+))) |
529 |
|
|
530 |
|
|
607 |
(cond ((member (car zn) '(and or not)) (distribute-complex zn)) |
(cond ((member (car zn) '(and or not)) (distribute-complex zn)) |
608 |
((and (not (cddr type)) (eq z zn)) type) |
((and (not (cddr type)) (eq z zn)) type) |
609 |
(`(,(car type) ,zn))))) |
(`(,(car type) ,zn))))) |
610 |
((member (car type) '(array simple-array)) |
((eq (car type) 'array) |
611 |
(let* ((tp (cadr type)) |
(let* ((tp (cadr type)) |
612 |
(tpn (if (cdr type) (maybe-eval tp) '*)) |
(tpn (if (cdr type) (maybe-eval tp) '*)) |
613 |
(tpn (if ar (upgraded-array-element-type tpn) tpn)) |
(tpn (if ar (upgraded-array-element-type tpn) tpn)) |
616 |
(dmn (or dmn 0))) |
(dmn (or dmn 0))) |
617 |
(if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn)))) |
(if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn)))) |
618 |
((eq (car type) 'member) type) |
((eq (car type) 'member) type) |
|
((and (not (cdr type)) (member (car type) +singleton-types+)) type) |
|
619 |
((eq (car type) 'cons) |
((eq (car type) 'cons) |
620 |
(let* ((def '(t)) |
(let* ((def '(t)) |
621 |
(car (cadr type)) |
(car (cadr type)) |
629 |
(if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn)))) |
(if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn)))) |
630 |
((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type)))) |
((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type)))) |
631 |
((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar)) |
((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar)) |
632 |
|
((and (not (cdr type)) (member (car type) +singleton-types+)) type) |
633 |
((and (eq (car type) 'satisfies) |
((and (eq (car type) 'satisfies) |
634 |
(setq tem (get (cadr type) 'predicate-type))) |
(setq tem (get (cadr type) 'predicate-type))) |
635 |
(normalize-type-int tem ar)) |
(normalize-type-int tem ar)) |
639 |
(mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x)) |
(mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x)) |
640 |
(cdr type)) |
(cdr type)) |
641 |
(cdr type))) |
(cdr type))) |
642 |
(nt (and dt (apply dt rr)))) |
(nt (and dt (or (apply dt rr) '(nil))))) |
643 |
(when (and nt (not (equal type nt))) |
(when (and nt (not (equal type nt))) |
644 |
(normalize-type-int nt ar)))) |
(normalize-type-int nt ar)))) |
645 |
((member (car type) '(and or not)) |
((member (car type) '(and or not)) |
714 |
(funcall tem ntp type)) |
(funcall tem ntp type)) |
715 |
((setq tem (coerce-to-standard-class (car type))) |
((setq tem (coerce-to-standard-class (car type))) |
716 |
(ntp-ld ntp `(standard-object ,tem))) |
(ntp-ld ntp `(standard-object ,tem))) |
717 |
((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data))) |
((and (symbolp (car type)) (setq tem (get (car type) 's-data))) |
718 |
(ntp-ld ntp `(structure ,tem))) |
(ntp-ld ntp `(structure ,tem))) |
719 |
((eq (car type) 'member) |
((eq (car type) 'member) |
720 |
(let ((els (cdr type))) |
(let ((els (cdr type))) |
892 |
(defun array-load (ntp type) |
(defun array-load (ntp type) |
893 |
(let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME |
(let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME |
894 |
(z (if (eq z '*) z (car (member z +array-types+))))) |
(z (if (eq z '*) z (car (member z +array-types+))))) |
895 |
(unless z (error "Bad array type ~a~%" (cadr type))) |
(unless (or z (not (cadr type))) (error "Bad array type ~a~%" (cadr type))) |
896 |
(let* ((dim (caddr type)) |
(let* ((dim (caddr type)) |
897 |
(dim (cond ((eq dim '*) t) |
(dim (cond ((eq dim '*) t) |
898 |
((integerp dim) (if (= 0 dim) dim (make-list dim :initial-element t))) |
((integerp dim) (if (= 0 dim) dim (make-list dim :initial-element t))) |
899 |
((listp dim) (substitute t '* dim))))) ;FIXME consing |
((listp dim) (substitute t '* dim))))) ;FIXME consing |
900 |
(if (eq z '*) |
(if (eq z '*) |
901 |
(dolist (l +array-type-alist+) |
(dolist (l +array-type-alist+) |
902 |
(ntp-ld ntp `(,(cdr l) ,dim))) |
(ntp-ld ntp `(,(cdr l) ,(when z dim)))) |
903 |
(ntp-ld ntp `(,(cdr (assoc z +array-type-alist+)) ,dim)))))) |
(ntp-ld ntp `(,(cdr (assoc z +array-type-alist+)) ,dim)))))) |
904 |
|
|
905 |
(defun array-atm (x) |
(defun array-atm (x) |
906 |
(cond ((atom x)) |
(cond ((atom x)) |
907 |
((eq (car x) 'not) (array-atm (cadr x))) |
((eq (car x) 'not) (array-atm (cadr x))) |
959 |
((and or) (sigalg-op op (cadr x) (cadr y) 'structure^ 'structure-atm)) |
((and or) (sigalg-op op (cadr x) (cadr y) 'structure^ 'structure-atm)) |
960 |
(not (negate (cadr x)))))) |
(not (negate (cadr x)))))) |
961 |
|
|
962 |
(defun structure-recon (x) (single-recon x)) |
(defun structure-recon (x) (cadr x)) |
963 |
|
|
964 |
;; STANDARD-OBJECTS |
;; STANDARD-OBJECTS |
965 |
|
|
979 |
(when q `(member ,@q)))) |
(when q `(member ,@q)))) |
980 |
((and (consp y) (eq (car y) 'member)) (standard^ y x)) |
((and (consp y) (eq (car y) 'member)) (standard^ y x)) |
981 |
((member y (class-precedence-list x)) x) |
((member y (class-precedence-list x)) x) |
982 |
((member x (class-precedence-list y)) y))) |
((member x (class-precedence-list y)) y) |
983 |
|
((reduce (lambda (&rest xy) (when xy (standard^ (car xy) (cadr xy)))) |
984 |
|
(intersection (class-direct-subclasses x) (class-direct-subclasses y) :test 'eq))))) |
985 |
|
; ((reduce (lambda (&rest xy) (when xy (standard^ (car xy) (cadr xy)))) |
986 |
|
; (intersection (class-direct-subclasses x) (class-direct-subclasses y) |
987 |
|
; :test 'standard^))))) |
988 |
|
|
989 |
(defun standard-op (op x y) |
(defun standard-op (op x y) |
990 |
(setf (cadr x) |
(setf (cadr x) |
992 |
((and or) (sigalg-op op (cadr x) (cadr y) 'standard^ 'standard-atm)) |
((and or) (sigalg-op op (cadr x) (cadr y) 'standard^ 'standard-atm)) |
993 |
(not (negate (cadr x)))))) |
(not (negate (cadr x)))))) |
994 |
|
|
995 |
(defun standard-recon (x) (single-recon x)) |
(defun standard-recon (x) (cadr x)) |
996 |
|
|
997 |
;; CONS |
;; CONS |
998 |
|
|
1053 |
(cond ((eq t (cadr x)) `(cons t t)) |
(cond ((eq t (cadr x)) `(cons t t)) |
1054 |
((atom (cadr x)) nil) |
((atom (cadr x)) nil) |
1055 |
((cons-atm (cadr x)) |
((cons-atm (cadr x)) |
1056 |
(let ((car (nreconstruct-type (caadr x))) |
(let ((car (nreconstruct-type-int (caadr x))) |
1057 |
(cdr (nreconstruct-type (cdadr x)))) |
(cdr (nreconstruct-type-int (cdadr x)))) |
1058 |
(and car cdr `(cons ,car ,cdr)))) |
(and car cdr `(cons ,car ,cdr)))) |
1059 |
((eq (caadr x) 'or) |
((eq (caadr x) 'or) |
1060 |
(let ((z (lremove-if 'not (mapcar (lambda (x) (cons-recon `(cons ,x))) (cdadr x))))) |
(let ((z (lremove-if 'not (mapcar (lambda (x) (cons-recon `(cons ,x))) (cdadr x))))) |
1178 |
|
|
1179 |
|
|
1180 |
|
|
1181 |
(defun nreconstruct-type (x) |
(defun nreconstruct-type-int (x) |
1182 |
(if (ntp-ukn x) t |
(if (ntp-ukn x) t |
1183 |
(if (ntp-def x) |
(if (ntp-def x) |
1184 |
(let ((z (nreconstruct-type (ntp-not x)))) |
(let ((z (nreconstruct-type-int (ntp-not x)))) |
1185 |
(or (not z) `(not ,z))) |
(or (not z) `(not ,z))) |
1186 |
(let ((z (lremove-if |
(let ((z (lremove-if |
1187 |
'not |
'not |
1190 |
(funcall op x))) (ntp-tps x))))) |
(funcall op x))) (ntp-tps x))))) |
1191 |
(if (cdr z) `(or ,@z) (car z)))))) |
(if (cdr z) `(or ,@z) (car z)))))) |
1192 |
|
|
1193 |
|
(defun nreconstruct-type (x) |
1194 |
|
(list (nreconstruct-type-int x) (ntp-ukn x))) |
1195 |
|
|
1196 |
|
|
1197 |
;; CLASS HACKS |
;; CLASS HACKS |
1202 |
(defun class-precedence-list (object) (declare (ignore object)) nil) |
(defun class-precedence-list (object) (declare (ignore object)) nil) |
1203 |
(defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil) |
(defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil) |
1204 |
(defun class-name (class) (declare (ignore class)) nil) |
(defun class-name (class) (declare (ignore class)) nil) |
1205 |
|
(defun class-of (object) (declare (ignore object)) nil) |
1206 |
|
(defun class-direct-subclasses (object) (declare (ignore object)) nil) |
1207 |
|
|
1208 |
(defun is-standard-class-symbol (sym) |
(defun is-standard-class-symbol (sym) |
1209 |
(let* ((z (get sym 'deftype-definition)) |
(let* ((z (get sym 'deftype-definition)) |