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 |
|
|
32 |
|
;;Exported functions need to be compiled with some safety to ensure |
33 |
|
;;that user-supplied arguments are checked. They should therefore |
34 |
|
;;primarily be wrappers around computationally intensive internal |
35 |
|
;;functions compiled with more aggressive settings. 20050718 CM |
36 |
|
|
37 |
(eval-when (compile) |
(eval-when (compile) |
38 |
(proclaim '(optimize (safety 2) (space 3))) |
(proclaim '(optimize (safety 0) (space 3) (speed 3)))) |
39 |
) |
|
40 |
|
(defun typep-int (object type &aux tp i tem) |
41 |
|
(if (atom type) |
42 |
|
(setq tp type i nil) |
43 |
|
(setq tp (car type) i (cdr type))) |
44 |
|
(if (eq tp 'structure-object) (setq tp 'structure)) |
45 |
|
(when (and (eq tp 'structure) (typep-int object 'standard-object)) |
46 |
|
(return-from typep-int nil)) |
47 |
|
(let ((f (and (not i) (symbolp tp) (get tp 'type-predicate)))) |
48 |
|
(when f (return-from typep-int (let ((z (funcall f object))) z)))) |
49 |
|
(case tp |
50 |
|
(cons (and (consp object) (typep-int (car object) (car i)) (typep-int (cdr object) (cadr i)))) |
51 |
|
(member (member object i)) |
52 |
|
(not (not (typep-int object (car i)))) |
53 |
|
(or |
54 |
|
(do ((l i (cdr l))) |
55 |
|
((null l) nil) |
56 |
|
(when (typep-int object (car l)) (return t)))) |
57 |
|
(and |
58 |
|
(do ((l i (cdr l))) |
59 |
|
((null l) t) |
60 |
|
(unless (typep-int object (car l)) (return nil)))) |
61 |
|
(satisfies (let ((z (funcall (car i) object))) z)) |
62 |
|
((t) t) |
63 |
|
((nil) (not object)) |
64 |
|
(boolean (or (eq object 't) (eq object 'nil))) |
65 |
|
(fixnum (eq (type-of object) 'fixnum)) |
66 |
|
(bignum (eq (type-of object) 'bignum)) |
67 |
|
(ratio (eq (type-of object) 'ratio)) |
68 |
|
(standard-char |
69 |
|
(and (characterp object) (standard-char-p object))) |
70 |
|
((base-char string-char) |
71 |
|
(and (characterp object) (string-char-p object))) |
72 |
|
(integer |
73 |
|
(and (integerp object) (in-interval-p object i))) |
74 |
|
(rational |
75 |
|
(and (rationalp object) (in-interval-p object i))) |
76 |
|
(real |
77 |
|
(and (realp object) (in-interval-p object i))) |
78 |
|
(float |
79 |
|
(and (floatp object) (in-interval-p object i))) |
80 |
|
((short-float) |
81 |
|
(and (eq (type-of object) 'short-float) (in-interval-p object i))) |
82 |
|
((single-float double-float long-float) |
83 |
|
(and (eq (type-of object) 'long-float) (in-interval-p object i))) |
84 |
|
(complex |
85 |
|
(and (complexp object) |
86 |
|
|
87 |
|
(or (null i) |
88 |
|
(and (typep-int (realpart object) (car i)) |
89 |
|
;;wfs--should only have to check one. |
90 |
|
;;Illegal to mix real and imaginary types! |
91 |
|
(typep-int (imagpart object) (car i)))) |
92 |
|
)) |
93 |
|
(sequence (or (listp object) (vectorp object))) |
94 |
|
((base-string string) ;FIXME |
95 |
|
(and (stringp object) |
96 |
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
97 |
|
(bit-vector |
98 |
|
(and (bit-vector-p object) |
99 |
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
100 |
|
((simple-base-string simple-string) ;FIXME |
101 |
|
(and (simple-string-p object) |
102 |
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
103 |
|
(simple-bit-vector |
104 |
|
(and (simple-bit-vector-p object) |
105 |
|
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
106 |
|
(simple-vector |
107 |
|
(and (simple-vector-p object) |
108 |
|
(or (endp i) (eq (car i) '*) |
109 |
|
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
110 |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
111 |
|
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
112 |
|
(vector |
113 |
|
(and (vectorp object) |
114 |
|
(or (endp i) (eq (car i) '*) |
115 |
|
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
116 |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
117 |
|
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
118 |
|
(simple-array |
119 |
|
(and (simple-array-p object) |
120 |
|
(or (endp i) (eq (car i) '*) |
121 |
|
(equal (array-element-type object)(best-array-element-type (car i)))) |
122 |
|
(or (endp (cdr i)) (eq (cadr i) '*) |
123 |
|
(if (listp (cadr i)) |
124 |
|
(match-dimensions (array-dimensions object) (cadr i)) |
125 |
|
(eql (array-rank object) (cadr i)))))) |
126 |
|
(array |
127 |
|
(and (arrayp object) |
128 |
|
(or (endp i) (eq (car i) '*) |
129 |
|
;; Or the element type of object should be EQUAL to (car i). |
130 |
|
;; Is this too strict? |
131 |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
132 |
|
(or (endp (cdr i)) (eq (cadr i) '*) |
133 |
|
(if (listp (cadr i)) |
134 |
|
(match-dimensions (array-dimensions object) (cadr i)) |
135 |
|
(eql (array-rank object) (cadr i)))))) |
136 |
|
(file-stream (eq (type-of object) 'file-stream)) |
137 |
|
(string-stream (eq (type-of object) 'string-stream)) |
138 |
|
(synonym-stream (eq (type-of object) 'synonym-stream)) |
139 |
|
(concatenated-stream (eq (type-of object) 'concatenated-stream)) |
140 |
|
(two-way-stream (eq (type-of object) 'two-way-stream)) |
141 |
|
(echo-stream (eq (type-of object) 'echo-stream)) |
142 |
|
(logical-pathname |
143 |
|
(and (pathnamep object) |
144 |
|
(not (endp (si:pathname-lookup (pathname-host object) |
145 |
|
si:*pathname-logical*))))) |
146 |
|
(t (cond ((setq tem (when (symbolp tp) (get tp 'deftype-definition))) |
147 |
|
(typep-int object (apply tem i))) |
148 |
|
((if (symbolp tp) (get tp 'si::s-data) (typep-int tp 's-data)) |
149 |
|
(let ((z (structure-subtype-p object tp))) z)))))) |
150 |
|
|
151 |
|
;;; TYPEP predicate. |
152 |
|
;;; FIXME --optimize with most likely cases first |
153 |
|
(defun typep (object type &optional env) |
154 |
|
(declare (ignore env) (optimize (safety 1))) |
155 |
|
(typep-int object type)) |
156 |
|
|
157 |
|
|
158 |
|
;;FIXME -- globalize |
159 |
|
(defun assert-type (obj tp) |
160 |
|
(unless (typep obj tp) |
161 |
|
(specific-error :wrong-type-argument "~S is not of type ~S." obj tp))) |
162 |
|
|
163 |
|
|
164 |
|
(defun in-interval-p (x interval) |
165 |
|
(let ((low '*) (high '*)) |
166 |
|
(when interval |
167 |
|
(assert-type interval 'cons) |
168 |
|
(or (eq (car interval) '*) (assert-type (car interval) 'real)) |
169 |
|
(setq low (car interval)) |
170 |
|
(when (cdr interval) |
171 |
|
(assert-type (cdr interval) 'cons) |
172 |
|
(or (eq (cadr interval) '*) (assert-type (cadr interval) 'real)) |
173 |
|
(setq high (cadr interval)))) |
174 |
|
(if (not interval) |
175 |
|
(setq low '* high '*) |
176 |
|
(if (not (cdr interval)) |
177 |
|
(setq low (car interval) high '*) |
178 |
|
(setq low (car interval) high (cadr interval)))) |
179 |
|
(cond ((eq low '*)) |
180 |
|
((consp low) |
181 |
|
(when (<= x (car low)) (return-from in-interval-p nil))) |
182 |
|
((when (< x low) (return-from in-interval-p nil)))) |
183 |
|
(cond ((eq high '*)) |
184 |
|
((consp high) |
185 |
|
(when (>= x (car high)) (return-from in-interval-p nil))) |
186 |
|
((when (> x high) (return-from in-interval-p nil)))) |
187 |
|
(return-from in-interval-p t))) |
188 |
|
|
189 |
|
(defun match-dimensions (dim pat) |
190 |
|
(cond ((null dim) |
191 |
|
(null pat)) |
192 |
|
((integerp dim) |
193 |
|
(eql dim pat)) |
194 |
|
((integerp pat) |
195 |
|
(eql (length dim) pat)) |
196 |
|
(t |
197 |
|
(and (or (eq (car pat) '*) |
198 |
|
(eql (car dim) (car pat))) |
199 |
|
(match-dimensions (cdr dim) (cdr pat)))))) |
200 |
|
|
201 |
|
|
202 |
|
|
203 |
|
|
204 |
|
|
205 |
|
(defun subtypep (t1 t2 &optional env) |
206 |
|
(declare (ignore env) (optimize (safety 1))) |
207 |
|
(if (or (not t1) (eq t2 t)) |
208 |
|
(values t t) |
209 |
|
(values (not (resolve-type `(and ,t1 ,(negate t2)))) t))) |
210 |
|
|
211 |
|
(defun upgraded-complex-part-type (type &optional environment) |
212 |
|
(declare (ignore environment) (optimize (safety 1)) ) |
213 |
|
type) |
214 |
|
|
215 |
|
(defun upgraded-array-element-type (type &optional environment) |
216 |
|
(declare (ignore environment) (optimize (safety 1))) |
217 |
|
(best-array-element-type type)) |
218 |
|
|
219 |
|
|
220 |
|
;;FIXME -- needs a rewrite |
221 |
|
;;; COERCE function. |
222 |
|
(defun coerce (object type) |
223 |
|
(declare (optimize (safety 1))) |
224 |
|
(when (classp type) |
225 |
|
(setq type (or (class-name type) |
226 |
|
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)))) |
227 |
|
(when (typep-int object (normalize-type type)) |
228 |
|
(return-from coerce object)) |
229 |
|
(if (atom type) (setq type (list type))) |
230 |
|
(case (car type) |
231 |
|
(function |
232 |
|
(assert-type object 'symbol) |
233 |
|
(symbol-function object)) |
234 |
|
(list |
235 |
|
(do ((l nil (cons (elt object i) l)) |
236 |
|
(i (1- (length object)) (1- i))) |
237 |
|
((< i 0) l))) |
238 |
|
((array simple-array vector simple-vector bit-vector string simple-string) |
239 |
|
(when (cdr type) ;;FIXME |
240 |
|
(assert-type (cdr type) 'cons) |
241 |
|
(when (cddr type) |
242 |
|
(assert-type (cddr type) 'cons) |
243 |
|
(or (eq (caddr type) '*) (integerp (caddr type)) |
244 |
|
(and (assert-type (caddr type) 'cons) (assert-type (cdr (caddr type)) 'null))))) |
245 |
|
(do ((seq (make-sequence type (length object))) |
246 |
|
(i 0 (1+ i)) |
247 |
|
(l (length object))) |
248 |
|
((>= i l) seq) |
249 |
|
(setf (elt seq i) (elt object i)))) |
250 |
|
(character (character object)) |
251 |
|
(float (float object)) |
252 |
|
((short-float) (float object 0.0S0)) |
253 |
|
((single-float double-float long-float) (float object 0.0L0)) |
254 |
|
(complex |
255 |
|
(if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*)) |
256 |
|
(complex (realpart object) (imagpart object)) |
257 |
|
(complex (coerce (realpart object) (cadr type)) |
258 |
|
(coerce (imagpart object) (cadr type))))) |
259 |
|
(t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)))) |
260 |
|
|
261 |
;;; DEFTYPE macro. |
;;; DEFTYPE macro. |
262 |
(defmacro deftype (name lambda-list &rest body) |
(defmacro deftype (name lambda-list &rest body) |
263 |
;; Replace undefaultized optional parameter X by (X '*). |
;; Replace undefaultized optional parameter X by (X '*). |
264 |
|
(declare (optimize (safety 1))) |
265 |
(do ((l lambda-list (cdr l)) |
(do ((l lambda-list (cdr l)) |
266 |
(m nil (cons (car l) m))) |
(m nil (cons (car l) m))) |
267 |
((null l)) |
((null l)) |
292 |
'type-documentation) |
'type-documentation) |
293 |
',name)) |
',name)) |
294 |
|
|
|
|
|
295 |
;;; Some DEFTYPE definitions. |
;;; Some DEFTYPE definitions. |
|
;(deftype fixnum () |
|
|
; `(integer ,most-negative-fixnum ,most-positive-fixnum)) |
|
296 |
(deftype seqind () |
(deftype seqind () |
297 |
`(integer 0 ,array-dimension-limit)) |
`(integer 0 ,array-dimension-limit)) |
298 |
(deftype rnkind () |
(deftype rnkind () |
299 |
`(integer 0 ,array-rank-limit)) |
`(integer 0 ,array-rank-limit)) |
|
;(deftype non-negative-fixnum () |
|
|
; `(integer 0 ,most-positive-fixnum)) |
|
|
;(deftype negative-fixnum () |
|
|
; `(integer ,most-negative-fixnum -1)) |
|
|
;(deftype fixnum () |
|
|
; `(integer ,most-negative-fixnum ,most-positive-fixnum)) |
|
300 |
(deftype bit () '(integer 0 1)) |
(deftype bit () '(integer 0 1)) |
301 |
(deftype mod (n) |
(deftype mod (n) |
302 |
`(integer 0 ,(1- n))) |
`(integer 0 ,(1- n))) |
361 |
`(simple-array bit (,size))) |
`(simple-array bit (,size))) |
362 |
|
|
363 |
(deftype function-identifier () `(satisfies si::function-identifierp)) |
(deftype function-identifier () `(satisfies si::function-identifierp)) |
|
(defun function-identifierp (tp) |
|
|
(or (symbolp tp) |
|
|
(and (consp tp) |
|
|
(eq (car tp) 'setf) |
|
|
(consp (cdr tp)) |
|
|
(symbolp (cadr tp)) |
|
|
(not (cddr tp))))) |
|
364 |
|
|
|
(defun simple-array-p (x) |
|
|
(and (arrayp x) |
|
|
;; should be (not (expressly-adjustable-p x)) |
|
|
;; since the following will always return T |
|
|
;; (not (adjustable-array-p x)) |
|
|
(not (array-has-fill-pointer-p x)) |
|
|
(not (si:displaced-array-p x)))) |
|
365 |
|
|
366 |
(deftype list () `(or cons nil)) |
(deftype list () `(or cons null)) |
367 |
(deftype sequence () `(or list vector)) |
(deftype sequence () `(or list vector)) |
368 |
(deftype character () `(or base-char extended-char)) |
(deftype character () `(or base-char extended-char)) |
369 |
(deftype string-char () `(or base-char extended-char)) |
(deftype string-char () `(or base-char extended-char)) |
371 |
file-stream string-stream synonym-stream two-way-stream)) |
file-stream string-stream synonym-stream two-way-stream)) |
372 |
|
|
373 |
(deftype bignum () `(and integer (not fixnum))) |
(deftype bignum () `(and integer (not fixnum))) |
374 |
|
;;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))) |
377 |
(deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
(deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
378 |
(deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
(deftype double-float (&optional (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)) |
|
;(deftype boolean () `(member t nil)) ;FIXME member types |
|
381 |
(deftype atom () `(not cons)) |
(deftype atom () `(not cons)) |
382 |
(deftype function () `(or interpreted-function compiled-function)) |
(deftype function (&optional as vs) `(or interpreted-function compiled-function)) |
|
(deftype symbol () `(or non-keyword-boolean-symbol null is-t keyword)) |
|
383 |
(deftype base-char () `(or standard-char non-standard-base-char)) |
(deftype base-char () `(or standard-char non-standard-base-char)) |
|
;(deftype t () `(or atom cons)) |
|
384 |
|
|
385 |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
386 |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
388 |
(deftype long-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
(deftype long-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
389 |
|
|
390 |
(deftype array (&optional (et '*) (dims '*)) |
(deftype array (&optional (et '*) (dims '*)) |
391 |
`(array ,et ,(if (integerp dims) (make-list dims :initial-element '*) dims))) |
`(array ,et ,(if (not dims) 0 dims))) |
392 |
(deftype simple-array (&optional (et '*) (dims '*)) |
(deftype simple-array (&optional (et '*) (dims '*)) |
393 |
`(simple-array ,et ,(if (integerp dims) (make-list dims :initial-element '*) dims))) |
`(simple-array ,et ,(if (not dims) 0 dims))) |
394 |
|
|
395 |
(defun upgraded-complex-part-type (type &optional environment) (declare (ignore environment)) type) |
(deftype eql (&optional (x nil xp)) (when xp `(member ,x))) |
396 |
|
|
397 |
(deftype complex (&optional (ts 'real)) `(complex ,(if (eq ts '*) 'real ts))) |
(deftype cons-member () `(cons)) |
|
(deftype eql (x) `(member ,x)) |
|
398 |
|
|
399 |
|
(deftype boolean () `(member t nil)) |
400 |
|
(deftype null () `(member nil)) |
401 |
|
|
402 |
(defconstant +singleton-types+ '(cons non-keyword-boolean-symbol is-t null keyword standard-char |
(deftype symbol () `(or non-keyword-symbol keyword)) |
|
non-standard-base-char extended-char |
|
|
package |
|
|
broadcast-stream concatenated-stream echo-stream file-stream string-stream |
|
|
synonym-stream two-way-stream |
|
|
pathname readtable hash-table random-state structure |
|
|
interpreted-function compiled-function)) |
|
403 |
|
|
404 |
(defvar *singleton-types* '#.(reverse (let ((i -1)) (mapcar (lambda (x) `(,x . ,(ash 1 (incf i)))) +singleton-types+)))) |
(deftype complex (&optional (rp 'real)) `(complex ,(if (eq rp '*) 'real rp))) |
405 |
|
(deftype cons (&optional (car t) (cdr t)) `(cons ,(if (eq car '*) t car) ,(if (eq cdr '*) t cdr))) |
406 |
|
|
|
(defmacro mbtp (x) `(and (consp ,x) (eq (car ,x) 'member))) |
|
407 |
|
|
408 |
(defun singleton-tp-from-int (x) |
(defun non-keyword-symbol-p (x) |
409 |
(let ((z (mapcar 'car (remove-if (lambda (z) (= 0 (logand x z))) *singleton-types* :key 'cdr)))) |
(and (symbolp x) (not (keywordp x)))) |
|
(if (cdr z) |
|
|
`(or ,@z) |
|
|
z))) |
|
|
|
|
|
(defun singleton-op (op x &optional y) |
|
|
(let ((x (if (integerp x) x (or (cdr (assoc x *singleton-types*)) (if x -1 0)))) |
|
|
(y (if (integerp y) y (or (cdr (assoc y *singleton-types*)) (if y -1 0))))) |
|
|
(case op |
|
|
(and (logand x y)) |
|
|
(or (logior x y)) |
|
|
(not (lognot x))))) |
|
|
|
|
|
|
|
|
;(defstruct tp |
|
|
; (nums (make-list 8) :type list) |
|
|
; single |
|
|
; array |
|
|
; struct |
|
|
; class) |
|
|
|
|
|
(defconstant +range-types+ `(integer ratio short-float long-float)) |
|
|
(defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short |
|
|
fixnum short-float long-float t)) |
|
|
|
|
|
(defmacro make-tp () `(list (make-list ,#.(* 2 (length +range-types+))) |
|
|
nil |
|
|
(make-list ,#.(length +array-types+)) |
|
|
nil nil)) |
|
|
(defmacro tp-nums (tp) `(first ,tp)) |
|
|
(defmacro tp-single (tp) `(second ,tp)) |
|
|
(defmacro tp-array (tp) `(third ,tp)) |
|
|
(defmacro tp-struct (tp) `(fourth ,tp)) |
|
|
(defmacro tp-class (tp) `(fifth ,tp)) |
|
|
|
|
|
(defun class< (x y) |
|
|
(cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x))) |
|
|
((and (consp y) (eq (car y) 'member)) nil) |
|
|
((let ((x (if (symbolp x) (find-class x nil) x)) |
|
|
(y (if (symbolp y) (find-class y nil) y))) |
|
|
(or (not x) (and y (member y (class-precedence-list x)))))))) |
|
|
|
|
|
(defun struct< (x y) |
|
|
(cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x))) |
|
|
((and (consp y) (eq (car y) 'member)) nil) |
|
|
((or (not x) (eq y t))) |
|
|
((let ((x (and (symbolp x) (get x 's-data))) |
|
|
(y (and (symbolp y) (get y 's-data)))) |
|
|
(and x y (do ((x x (s-data-includes x))) ((or (not x) (eq x y)) (eq x y)))))))) |
|
|
|
|
|
|
|
|
(defun op-from-inclusion (op ox oy < atm) |
|
|
(let* ((cx (and (consp ox) (eq (car ox) 'not))) |
|
|
(x (if cx (cadr ox) ox)) |
|
|
(cy (and (consp oy) (eq (car oy) 'not))) |
|
|
(y (if cy (cadr oy) oy)) |
|
|
(<xy (funcall < x y)) |
|
|
(<yx (funcall < y x)) |
|
|
(opor (case op (or t) (and nil) (otherwise (error "Bad op~%"))))) |
|
|
(cond ((not (or cx cy)) |
|
|
(cond (<xy (if opor y x)) |
|
|
(<yx (if opor x y)) |
|
|
((when opor (clean-or atm `(or ,x ,y)))))) |
|
|
((and cx cy) |
|
|
(cond (<xy `(not ,(if opor x y))) |
|
|
(<yx `(not ,(if opor y x))) |
|
|
((if opor t (clean-and atm `(and (not ,x) (not ,y))))))) |
|
|
(cx (op-from-inclusion op oy ox < atm)) |
|
|
((cond ((and <xy <yx) opor) |
|
|
(<xy (when opor (clean-or atm `(or ,x (not ,y))))) |
|
|
(<yx (if opor t (clean-and atm `(and ,x (not ,y))))) |
|
|
((if opor `(not ,y) x))))))) |
|
|
|
|
|
;(defun compound (x) |
|
|
; (cond ((atom x) nil) |
|
|
; ((eq (car x) 'not) (compound (cadr x))) |
|
|
; ((consp (car x))) |
|
|
; ((member (car x) '(and or t nil))))) |
|
|
; |
|
|
;(defmacro atomic-tp (x) `(not (compound ,x))) |
|
|
|
|
|
(defun classatm (x) |
|
|
(cond ((atom x)) |
|
|
((eq (car x) 'not) (classatm (cadr x))) |
|
|
((eq (car x) 'member)))) |
|
|
|
|
|
(defun structatm (x) (classatm x)) |
|
|
(defun dimatm (x) |
|
|
(cond ((atom x)) |
|
|
((eq (car x) 'not) (dimatm (cadr x))) |
|
|
((integerp (car x))) |
|
|
((eq (car x) t)))) |
|
410 |
|
|
411 |
(defun clean-or (atm lst) |
(defun function-identifierp (tp) |
412 |
(if (funcall atm lst) lst |
(or (symbolp tp) |
413 |
(or |
(and (consp tp) |
414 |
(car (member t lst)) |
(eq (car tp) 'setf) |
415 |
(let ((nl (remove-if 'not (remove-duplicates (cdr lst) :test 'equal)))) |
(consp (cdr tp)) |
416 |
(if (cdr nl) `(or ,@nl) (car nl)))))) |
(symbolp (cadr tp)) |
417 |
|
(not (cddr tp))))) |
|
(defun clean-and (atm lst) |
|
|
(if (funcall atm lst) lst |
|
|
(unless (member nil lst) |
|
|
(let ((nl (remove-if (lambda (z) (eq z t)) (remove-duplicates (cdr lst) :test 'equal)))) |
|
|
(if (cdr nl) `(and ,@nl) (or (car nl) t)))))) |
|
|
|
|
|
(defun repl-op (op x y < atm) |
|
|
(let ((z (inclusion-op op x y < atm))) |
|
|
(if (funcall atm z) z y))) |
|
|
|
|
|
(defun clean-tp (op atm x &optional y) |
|
|
(let ((cf (case op (or 'clean-or) (and 'clean-and) (otherwise (error "Bad op~%")))) |
|
|
(x (if (funcall atm x) (list x) x)) |
|
|
(y (if (funcall atm y) (list y) y))) |
|
|
(cond ((not (car y)) (funcall cf atm `(,op ,@x))) |
|
|
((eq (car y) op) (funcall cf atm `(,op ,@x ,@(cdr y)))) |
|
|
((member (car y) '(and not or)) `(,op ,@x ,y)) |
|
|
((funcall cf atm `(,op ,@x ,@y)))))) |
|
|
|
|
|
(defun clean-not (atm lst) |
|
|
(cond ((atom lst) lst) |
|
|
((and (eq (car lst) 'not) (consp (cadr lst)) (eq (caadr lst) 'not)) |
|
|
(clean-not atm (cadadr lst))) |
|
|
((eq (cadr lst) t) nil) |
|
|
((and (cdr lst) (not (cadr lst)))) |
|
|
(lst))) |
|
|
|
|
|
(defun inclusion-op (op x y < atm) |
|
|
(cond ((and (not (funcall atm x)) (eq op (car x))) |
|
|
(inclusion-op op (cadr x) (clean-tp op atm (cddr x) y) < atm)) |
|
|
((and (not (funcall atm x)) (eq 'not (car x))) |
|
|
(clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm)))) |
|
|
((not (funcall atm x)) |
|
|
(clean-tp (if (eq op 'or) 'and 'or) atm (mapcar (lambda (w) (inclusion-op op w y < atm)) (cdr x)))) |
|
|
((funcall atm y) (op-from-inclusion op x y < atm)) |
|
|
((eq op (car y)) |
|
|
(let ((z (clean-tp op atm (if (some (lambda (z) (equal z (inclusion-op op x z < atm))) (cdr y)) |
|
|
(eq op 'and) x) |
|
|
(mapcar (lambda (z) (repl-op op x z < atm)) (cdr y))))) |
|
|
(if (funcall atm z) z |
|
|
(let ((ny (clean-tp op atm (cddr z)))) |
|
|
(if (and (equal x (cadr z)) (equal ny y)) |
|
|
z |
|
|
(inclusion-op op (cadr z) ny < atm)))))) |
|
|
((eq 'not (car y)) |
|
|
(clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm)))) |
|
|
((clean-tp (if (eq op 'or) 'and 'or) atm (mapcar (lambda (w) (inclusion-op op x w < atm)) (cdr y)))))) |
|
|
|
|
|
; ((inclusion-op op y x <))))); |
|
|
|
|
|
(defun andf (&rest args) |
|
|
(or (not args) (and (car args) (cadr args)))) |
|
|
|
|
|
(defun dim< (x y) |
|
|
(cond ((or (eq y t) (not x))) |
|
|
((or (eq x t) (not y)) nil) |
|
|
((integerp x) (if (integerp y) (= x y) (and (consp y) (= x (length y)) (every (lambda (z) (eq z t)) y)))) |
|
|
((integerp y) (dim< x (make-list y :initial-element t))) |
|
|
((/= (length x) (length y)) nil) |
|
|
((every (lambda (z) (eq z t)) (mapcar 'dim< x y))))) |
|
|
|
|
|
(defun array-op (op x &optional y) ;(declare (ignore op x y)) nil) |
|
|
(case op |
|
|
(not (mapcar (lambda (z) (clean-not 'dimatm `(not ,z))) x)) |
|
|
(otherwise (mapcar (lambda (x y) (inclusion-op op x y 'dim< 'dimatm)) x y)))) |
|
|
|
|
|
(defun tp-and (&rest xy) |
|
|
(when xy |
|
|
(let ((x (car xy)) (y (cadr xy))) |
|
|
(when x |
|
|
(setf (tp-nums x) (mapcar 'range-and (tp-nums x) (tp-nums y))) |
|
|
(setf (tp-single x) (singleton-op 'and (tp-single x) (tp-single y))) |
|
|
(setf (tp-array x) (array-op 'and (tp-array x) (tp-array y))) |
|
|
(setf (tp-struct x) (inclusion-op 'and (tp-struct x) (tp-struct y) 'struct< 'structatm)) |
|
|
(setf (tp-class x) (inclusion-op 'and (tp-class x) (tp-class y) 'class< 'classatm))) |
|
|
x))) |
|
|
|
|
|
(defun tp-or (&rest xy) |
|
|
(when xy |
|
|
(let ((x (car xy)) (y (cadr xy))) |
|
|
(when x |
|
|
(setf (tp-nums x) (mapcar 'range-or (tp-nums x) (tp-nums y))) |
|
|
(setf (tp-single x) (singleton-op 'or (tp-single x) (tp-single y))) |
|
|
(setf (tp-array x) (array-op 'or (tp-array x) (tp-array y))) |
|
|
(setf (tp-struct x) (inclusion-op 'or (tp-struct x) (tp-struct y) 'struct< 'structatm)) |
|
|
(setf (tp-class x) (inclusion-op 'or (tp-class x) (tp-class y) 'class< 'classatm))) |
|
|
x))) |
|
|
|
|
|
(defun tp-not (x) |
|
|
(when x |
|
|
(setf (tp-nums x) (mapcar 'range-not (tp-nums x))) |
|
|
(setf (tp-single x) (singleton-op 'not (tp-single x))) |
|
|
(setf (tp-array x) (array-op 'not (tp-array x))) |
|
|
(setf (tp-struct x) (clean-not 'structatm `(not ,(tp-struct x))));FIXME |
|
|
(setf (tp-class x) (clean-not 'classatm `(not ,(tp-class x))))) |
|
|
x) |
|
|
|
|
|
(defun tp-load (type shift &aux tem) |
|
|
(let ((tp (make-tp))) |
|
|
(cond ((eq (car type) t) (tp-not tp)) |
|
|
((setq tem (position (car type) +range-types+)) |
|
|
(setf (nth (+ shift tem) (tp-nums tp)) |
|
|
(let ((z `((,(cadr type) . ,(caddr type))))) |
|
|
(number-range-fixup z (nth tem +range-types+))))) |
|
|
((member (car type) +singleton-types+) |
|
|
(setf (tp-single tp) (car type))) |
|
|
((member (car type) '(array simple-array)) |
|
|
(let ((z (position (if (eq (cadr type) 'string-char) 'character (cadr type)) +array-types+)));FIXME |
|
|
(unless (or z (eq (cadr type) '*)) (error "Bad array type ~a~%" (cadr type))) |
|
|
(let* ((dim (caddr type)) |
|
|
(dim (if (eq dim '*) t dim)) |
|
|
(dim (if (listp dim) (mapcar (lambda (z) (or (eq '* z) z)) dim) dim))) |
|
|
(if z |
|
|
(setf (nth z (tp-array tp)) dim) |
|
|
(setf (tp-array tp) (mapcar (lambda (z) (declare (ignore z)) dim) (tp-array tp))))))) |
|
|
((setq tem (or (and (symbolp (car type)) (find-class (car type) nil)) (when (classp (car type)) (car type)))) |
|
|
(setf (tp-class tp) tem)) |
|
|
((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data))) |
|
|
; (setf (tp-struct tp) tem))FIXME |
|
|
(setf (tp-struct tp) (car type))) |
|
|
((eq (car type) 'member) |
|
|
(dolist (l (cdr type)) |
|
|
(cond ((setq tem (position-if (lambda (x) (typep l x)) +range-types+)) |
|
|
(setf (nth tem (tp-nums tp)) |
|
|
(range-or (let ((z `((,l . ,l)))) |
|
|
(number-range-fixup z (nth tem +range-types+))) |
|
|
(nth tem (tp-nums tp))))) |
|
|
((setq tem (position-if (lambda (x) (typep l x)) +singleton-types+)) |
|
|
(setf (tp-single tp) (if (consp (tp-single tp)) `(,@(tp-single tp) ,l) `(member ,l)))) |
|
|
((setq tem (position-if (lambda (x) (typep l `(complex ,x))) +range-types+)) ;;FIXME |
|
|
(setf (nth (+ (length +range-types+) tem) (tp-nums tp)) |
|
|
(range-or (let ((z `((,(realpart l) . ,(realpart l))))) |
|
|
(number-range-fixup z (nth tem +range-types+))) |
|
|
(range-or (let ((z `((,(imagpart l) . ,(imagpart l))))) |
|
|
(number-range-fixup z (nth tem +range-types+))) |
|
|
(nth (+ (length +range-types+) tem) (tp-nums tp))))))))) |
|
|
((car type) (setq tp (tp-not tp)))) ;(format t "not processing type ~a~%" type) |
|
|
tp)) |
|
|
|
|
|
(defun reconstruct-type (tp) |
|
|
(if (and (consp tp) (eq (car tp) 'cons) (cdr tp)) |
|
|
(let ((a (reconstruct-type (cadr tp))) |
|
|
(d (reconstruct-type (caddr tp)))) |
|
|
(and a d `(cons ,(reconstruct-type (cadr tp)) ,(reconstruct-type (caddr tp))))) |
|
|
(let* ((res (when (some 'identity (tp-nums tp)) |
|
|
(remove-if |
|
|
'not |
|
|
(append |
|
|
(mapcan (lambda (x y) |
|
|
(mapcar (lambda (y) |
|
|
(let ((y (car (number-range-fixup (list y) x)))) |
|
|
(when y `(,x ,(car y) ,(cdr y))))) y)) |
|
|
+range-types+ (tp-nums tp)) |
|
|
(mapcan (lambda (x y) |
|
|
(mapcar (lambda (y) |
|
|
(let ((y (car (number-range-fixup (list y) x)))) |
|
|
(when y `(complex (,x ,(car y) ,(cdr y)))))) y)) |
|
|
+range-types+ (nthcdr 4 (tp-nums tp))))))) |
|
|
(res (if (some 'identity (tp-array tp)) |
|
|
`(,@res ,@(remove-if |
|
|
'not |
|
|
(mapcan (lambda (x y) (mapcar (lambda (y) (when y `(array ,x ,y))) (if (atom y) (list y) y))) |
|
|
+array-types+ (tp-array tp)))) res)) |
|
|
(res (if (tp-single tp) |
|
|
`(,@res ,@(remove-if |
|
|
'not |
|
|
(mapcar (lambda (z) |
|
|
(when (/= 0 (logand (cdr z) (tp-single tp))) |
|
|
(car z))) *singleton-types*))) res)) |
|
|
(res (if (tp-struct tp) `(,@res ,(tp-struct tp)) res)) |
|
|
(res (if (tp-class tp) `(,@res ,(tp-class tp)) res))) |
|
|
(when res |
|
|
(if (cdr res) |
|
|
(clean-tp 'or 'null res) |
|
|
(car res)))))) |
|
|
|
|
|
|
|
|
(defun resolve-type (type) |
|
|
; (format t "norm~%") |
|
|
; (setq type (time (normalize-type type t))) |
|
|
; (format t "proc~%") |
|
|
; (setq type (time (process-type type))) |
|
|
; (format t "recon~%") |
|
|
; (setq type (time (reconstruct-type type)))) |
|
|
; (let* ((type (time (normalize-type type t))) |
|
|
; (type (time (process-type type))) |
|
|
; (type (time (reconstruct-type type)))) |
|
|
; type)) |
|
|
(reconstruct-type (process-type (normalize-type type t)))) |
|
|
|
|
|
|
|
|
(defun tp-and1 (&rest xy) |
|
|
(when xy |
|
|
`(and ,@xy))) |
|
|
|
|
|
(defun tp-or1 (&rest xy) |
|
|
(when xy |
|
|
`(or ,@xy))) |
|
|
|
|
|
(defun tp-not1 (&rest xy) |
|
|
(when xy |
|
|
`(not ,@xy))) |
|
|
|
|
|
|
|
|
|
|
|
(defun process-type (type &optional (shift 0)) |
|
|
(cond ((not type) type) |
|
|
; ((and (setq tem (normalize-type type)) (not (equal type tem)) (not (eq (car tem) 'satisfies))) |
|
|
; (process-type tem shift)) |
|
|
((eq (car type) 'and) (reduce 'tp-and (mapcar (lambda (x) (process-type x shift)) (cdr type)))) |
|
|
((eq (car type) 'or) (reduce 'tp-or (mapcar (lambda (x) (process-type x shift)) (cdr type)))) |
|
|
((eq (car type) 'not) (tp-not (process-type (cadr type) shift))) |
|
|
((eq (car type) 'complex) (process-type (cadr type) 4)) |
|
|
; ((and (eq (car type) 'cons) (cdr type)) `(cons ,(process-type (cadr type)) ,(process-type (caddr type)))) |
|
|
((tp-load type shift)))) |
|
|
|
|
|
(deftype boolean () `(or null is-t)) |
|
|
(defun is-t-p (x) (eq x t));FIXME member types |
|
418 |
|
|
419 |
(defun non-keyword-boolean-symbol-p (x) |
(defun simple-array-p (x) |
420 |
(and (symbolp x) (not (keywordp x)) (not (null x)) (not (is-t-p x)))) |
(and (arrayp x) |
421 |
|
;; should be (not (expressly-adjustable-p x)) |
422 |
|
;; since the following will always return T |
423 |
|
;; (not (adjustable-array-p x)) |
424 |
|
(not (array-has-fill-pointer-p x)) |
425 |
|
(not (si:displaced-array-p x)))) |
426 |
|
|
|
(defun base-char-p (x) |
|
|
(characterp x)) |
|
427 |
|
|
428 |
(defun non-standard-base-char-p (x) |
(defun non-standard-base-char-p (x) |
429 |
(and (base-char-p x) (not (standard-char-p x)))) |
(and (characterp x) (not (standard-char-p x)))) |
430 |
|
|
431 |
(defun extended-char-p (x) (declare (ignore x)) nil) |
(defun extended-char-p (x) (declare (ignore x)) nil) |
432 |
|
|
433 |
(defun interpreted-function-p (x) |
(defun interpreted-function-p (x) |
434 |
(and (functionp x) (not (compiled-function-p x)))) |
(and (function-p x) (not (compiled-function-p x)))) |
435 |
|
|
436 |
|
(defun function-p (x) |
437 |
|
(and (not (symbolp x)) (functionp x))) |
438 |
|
|
439 |
(do ((l '((null . null) |
(do ((l '((null . null) |
440 |
(symbol . symbolp) |
(symbol . symbolp) |
441 |
(keyword . keywordp) |
(keyword . keywordp) |
442 |
(is-t . is-t-p) |
(is-t . is-t-p) |
443 |
(non-keyword-boolean-symbol . non-keyword-boolean-symbol-p) |
(non-keyword-symbol . non-keyword-symbol-p) |
444 |
(standard-char . standard-char-p) |
(standard-char . standard-char-p) |
445 |
(base-char . base-char-p) |
(non-standard-base-char . non-standard-base-char-p) |
446 |
(extended-char . extended-char-p) |
(extended-char . extended-char-p) |
447 |
(string-char . string-char-p);;FIXME |
(string-char . string-char-p);;FIXME |
448 |
(interpreted-function . interpreted-function-p) |
(interpreted-function . interpreted-function-p) |
461 |
(hash-table . hash-table-p) |
(hash-table . hash-table-p) |
462 |
(random-state . random-state-p) |
(random-state . random-state-p) |
463 |
(structure . si:structurep) |
(structure . si:structurep) |
464 |
(function . functionp) |
(function . function-p) |
465 |
(compiled-function . compiled-function-p) |
(compiled-function . compiled-function-p) |
466 |
(common . commonp) |
(common . commonp) |
467 |
) |
) |
468 |
(cdr l))) |
(cdr l))) |
469 |
((endp l)) |
((endp l)) |
470 |
(si:putprop (caar l) (cdar l) 'type-predicate) |
(si:putprop (caar l) (cdar l) 'type-predicate) |
471 |
(when (symbolp (cdar l)) (si:putprop (cdar l) (caar l) 'predicate-type))) |
(when (symbolp (cdar l)) |
472 |
|
(si:putprop (cdar l) (caar l) 'predicate-type) |
473 |
|
(proclaim `(ftype (function (t) t) ,(cdar l))))) |
474 |
|
|
475 |
|
|
476 |
(defun classp (object) (declare (ignore object)) nil) |
(defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char |
477 |
(defun class-precedence-list (object) (declare (ignore object)) nil) |
non-standard-base-char extended-char |
478 |
(defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil) |
package cons-member |
479 |
|
broadcast-stream concatenated-stream echo-stream file-stream string-stream |
480 |
|
synonym-stream two-way-stream |
481 |
|
pathname readtable hash-table random-state standard-object structure |
482 |
|
interpreted-function |
483 |
|
compiled-function)) |
484 |
|
|
485 |
|
|
486 |
|
(defconstant +range-types+ `(integer ratio short-float long-float)) |
487 |
|
(defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short |
488 |
|
fixnum short-float long-float t)) |
489 |
|
|
490 |
|
(defconstant +known-types+ (append +range-types+ |
491 |
|
(mapcar (lambda (x) `(complex ,x)) +range-types+) |
492 |
|
+singleton-types+ |
493 |
|
(mapcar (lambda (x) `(array ,x)) +array-types+))) |
494 |
|
|
495 |
|
(defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "ARRAY-" (string x))))) |
496 |
|
+array-types+)) |
497 |
|
(defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "COMPLEX-" (string x))))) |
498 |
|
+range-types+)) |
499 |
|
|
500 |
|
(defconstant +kindom-logic-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-op)) +range-types+) |
501 |
|
(cons . cons-op) |
502 |
|
(standard-object . standard-op) |
503 |
|
(structure . structure-op) |
504 |
|
,@(mapcar (lambda (x) `(,(cdr x) . complex-op)) +complex-type-alist+) |
505 |
|
,@(mapcar (lambda (x) `(,(cdr x) . array-op)) +array-type-alist+) |
506 |
|
,@(mapcar (lambda (x) `(,x . single-op)) +singleton-types+))) |
507 |
|
|
508 |
|
(defconstant +kindom-recon-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-recon)) +range-types+) |
509 |
|
(cons . cons-recon) |
510 |
|
(standard-object . standard-recon) |
511 |
|
(structure . structure-recon) |
512 |
|
,@(mapcar (lambda (x) `(,(cdr x) . complex-recon)) +complex-type-alist+) |
513 |
|
,@(mapcar (lambda (x) `(,(cdr x) . array-recon)) +array-type-alist+) |
514 |
|
,@(mapcar (lambda (x) `(,x . single-recon)) +singleton-types+))) |
515 |
|
|
516 |
|
(defconstant +kindom-load-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-load)) +range-types+) |
517 |
|
(complex . complex-load) |
518 |
|
(cons . cons-load) |
519 |
|
(standard-object . standard-load) |
520 |
|
(structure . structure-load) |
521 |
|
(array . array-load) |
522 |
|
(simple-array . array-load) |
523 |
|
,@(mapcar (lambda (x) `(,x . single-load)) +singleton-types+))) |
524 |
|
|
525 |
|
|
526 |
|
|
527 |
|
(defmacro make-ntp nil `(make-list 3)) |
528 |
|
(defmacro ntp-tps (ntp) `(first ,ntp)) |
529 |
|
(defmacro ntp-def (ntp) `(second ,ntp)) |
530 |
|
(defmacro ntp-ukn (ntp) `(third ,ntp)) |
531 |
|
(defmacro ntp-ld (ntp tp) (let ((ns (gensym)) (ts (gensym))) |
532 |
|
`(let ((,ns ,ntp) (,ts ,tp)) |
533 |
|
(when ,ts |
534 |
|
(if (ntp-tps ,ns) (nconc (ntp-tps |
535 |
|
,ns) |
536 |
|
(list |
537 |
|
,ts)) |
538 |
|
(setf (ntp-tps ,ns) (list ,ts))))))) |
539 |
(defmacro range-num (x) `(if (atom ,x) ,x (car ,x))) |
(defmacro range-num (x) `(if (atom ,x) ,x (car ,x))) |
540 |
|
(defmacro elcomp (x) `(cond ((eq ,x '*) ,x) |
541 |
|
((atom ,x) (list ,x)) |
542 |
|
((car ,x)))) |
543 |
|
|
544 |
|
;;FIXME --remove these when compiler is ready |
545 |
|
|
546 |
|
(defmacro lposition-if (fn lst) |
547 |
|
(let ((lsym (gensym)) (p (gensym)) (ind (gensym))) |
548 |
|
`(let ((,lsym ,lst)) |
549 |
|
(do ((,ind ,lsym (cdr ,ind)) (,p 0 (1+ ,p))) ((or (not ,ind) (funcall ,fn (car ,ind))) (and ,ind ,p)) |
550 |
|
(declare (seqind ,p)))))) |
551 |
|
|
552 |
|
(defmacro lposition-eq (itm lst) |
553 |
|
(let ((lsym (gensym)) (i (gensym)) (p (gensym)) (ind (gensym))) |
554 |
|
`(let ((,lsym ,lst) (,i ,itm)) |
555 |
|
(do ((,ind ,lsym (cdr ,ind)) (,p 0 (1+ ,p))) ((or (not ,ind) (eq ,i (car ,ind))) (and ,ind ,p)) |
556 |
|
(declare (seqind ,p)))))) |
557 |
|
|
558 |
|
(defmacro lremove-if (fn lst) |
559 |
|
(let ((lsym (gensym)) (tmp (gensym)) (r (gensym)) (l (gensym)) (ind (gensym))) |
560 |
|
`(let ((,lsym ,lst) ,r ,l) |
561 |
|
(do ((,ind ,lsym (cdr ,ind))) ((not ,ind) ,r) |
562 |
|
(unless (funcall ,fn (car ,ind)) |
563 |
|
(setf (car (setq ,l (let ((,tmp (cons nil nil))) (if ,l (cdr (rplacd ,l ,tmp)) (setq ,r ,tmp))))) (car ,ind))))))) |
564 |
|
|
565 |
|
(defmacro lremove-if-not (fn lst) |
566 |
|
(let ((lsym (gensym)) (tmp (gensym)) (r (gensym)) (l (gensym)) (ind (gensym))) |
567 |
|
`(let ((,lsym ,lst) ,r ,l) |
568 |
|
(do ((,ind ,lsym (cdr ,ind))) ((not ,ind) ,r) |
569 |
|
(when (funcall ,fn (car ,ind)) |
570 |
|
(setf (car (setq ,l (let ((,tmp (cons nil nil))) (if ,l (cdr (rplacd ,l ,tmp)) (setq ,r ,tmp))))) (car ,ind))))))) |
571 |
|
|
572 |
|
|
573 |
|
(defun resolve-type (type) |
574 |
|
(nreconstruct-type (nprocess-type (normalize-type type t)))) |
575 |
|
|
576 |
|
|
577 |
|
;;FIXME rethink need for side-effects here and in ntp functions above. |
578 |
|
(defun normalize-type (type &optional ar);FIXME |
579 |
|
(let ((type (if (atom type) type (copy-list type)))) |
580 |
|
(normalize-type-int type ar))) |
581 |
|
|
582 |
|
(defun normalize-type-int (type ar &aux tem) |
583 |
|
(cond ((atom type) (normalize-type-int (list type) ar)) |
584 |
|
((setq tem (coerce-to-standard-class (car type))) (setf (car type) tem) type) |
585 |
|
((classp (car type)) (normalize-type-int (setf (car type) (class-name (car type))) ar)) |
586 |
|
((and (eq (car type) 'satisfies) |
587 |
|
(setq tem (get (cadr type) 'predicate-type))) |
588 |
|
(normalize-type-int tem ar)) |
589 |
|
((let* ((dt (and (symbolp (car type)) |
590 |
|
(get (car type) 'deftype-definition))) |
591 |
|
(rr (do ((tmp (cdr type) (cdr tmp))) ((not tmp) (cdr type)) |
592 |
|
(when (and (consp (car tmp)) (eq (caar tmp) 'load-time-value)) |
593 |
|
(setf (car tmp) (eval (cadar tmp)))))) |
594 |
|
(nt (and dt (apply dt rr)))) |
595 |
|
(when (and nt (not (equal type nt))) |
596 |
|
(normalize-type-int (copy-list nt) ar)))) |
597 |
|
((and ar (member (car type) '(array simple-array))) |
598 |
|
(setf (cadr type) (upgraded-array-element-type (cadr type))) |
599 |
|
type) |
600 |
|
((eq (car type) 'complex) |
601 |
|
(distribute-complex (normalize-type-int (cadr type) ar))) |
602 |
|
((and (eq (car type) 'cons) (cdr type)) |
603 |
|
(setf (cadr type) (normalize-type-int (cadr type) ar)) |
604 |
|
(if (cddr type) |
605 |
|
(setf (caddr type) (normalize-type-int (caddr type) ar)) |
606 |
|
(setf (cddr type) `((t)))) |
607 |
|
(and (caadr type) (caaddr type) type)) |
608 |
|
((member (car type) '(and or not)) |
609 |
|
(do ((tmp (cdr type) (cdr tmp))) ((not tmp)) |
610 |
|
(setf (car tmp) (normalize-type-int (car tmp) ar))) |
611 |
|
(if (cdr type) |
612 |
|
type |
613 |
|
(case (car type) (and '(t)) (or '(nil)) (not (error "Bad type~%"))))) |
614 |
|
(type))) |
615 |
|
|
616 |
|
(defun distribute-complex (type) |
617 |
|
(cond ((atom type) type) |
618 |
|
((consp (car type)) (cons (distribute-complex (car type)) (distribute-complex (cdr type)))) |
619 |
|
((member (car type) '(and or not)) (cons (car type) (distribute-complex (cdr type)))) |
620 |
|
(`(complex ,type)))) |
621 |
|
|
622 |
|
|
623 |
|
|
624 |
|
(defun nprocess-type (type) |
625 |
|
(cond ((eq (car type) 'and) (reduce 'ntp-and (mapcar (lambda (x) (nprocess-type x)) (cdr type)))) |
626 |
|
((eq (car type) 'or) (reduce 'ntp-or (mapcar (lambda (x) (nprocess-type x)) (cdr type)))) |
627 |
|
((eq (car type) 'not) (ntp-not (nprocess-type (cadr type)))) |
628 |
|
((ntp-load type)))) |
629 |
|
|
630 |
|
(defun ntp-and (&rest xy) |
631 |
|
(when xy |
632 |
|
(let ((x (car xy)) (y (cadr xy))) |
633 |
|
(dolist (l (ntp-tps x)) |
634 |
|
(let ((op (cdr (assoc (car l) +kindom-logic-ops-alist+))) |
635 |
|
(ny (assoc (car l) (ntp-tps y)))) |
636 |
|
(when (or ny (not (ntp-def y))) |
637 |
|
(funcall op 'and l ny)))) |
638 |
|
(dolist (l (ntp-tps y)) |
639 |
|
(when (and (ntp-def x) (not (assoc (car l) (ntp-tps x)))) |
640 |
|
(ntp-ld x l))) |
641 |
|
(setf (ntp-def x) (and (ntp-def x) (ntp-def y))) |
642 |
|
(setf (ntp-ukn x) (or (ntp-ukn x) (ntp-ukn y))) |
643 |
|
(ntp-clean x) |
644 |
|
x))) |
645 |
|
|
646 |
|
(defun ntp-or (&rest xy) |
647 |
|
(when xy |
648 |
|
(let ((x (car xy)) (y (cadr xy))) |
649 |
|
(dolist (l (ntp-tps x)) |
650 |
|
(let* ((op (cdr (assoc (car l) +kindom-logic-ops-alist+))) |
651 |
|
(ny (assoc (car l) (ntp-tps y))) |
652 |
|
(ny (or ny (when (ntp-def y) (let ((z `(,(car l) nil))) (funcall op 'not z nil) z))))) |
653 |
|
(when ny |
654 |
|
(funcall op 'or l ny)))) |
655 |
|
(dolist (l (ntp-tps y)) |
656 |
|
(unless (or (ntp-def x) (assoc (car l) (ntp-tps x))) |
657 |
|
(ntp-ld x l))) |
658 |
|
(setf (ntp-def x) (or (ntp-def x) (ntp-def y))) |
659 |
|
(setf (ntp-ukn x) (or (ntp-ukn x) (ntp-ukn y))) |
660 |
|
(ntp-clean x) |
661 |
|
x))) |
662 |
|
|
663 |
|
(defun ntp-not (x) |
664 |
|
(dolist (l (ntp-tps x)) |
665 |
|
(funcall (cdr (assoc (car l) +kindom-logic-ops-alist+)) 'not l nil)) |
666 |
|
(setf (ntp-def x) (negate (ntp-def x))) |
667 |
|
(ntp-clean x) |
668 |
|
x) |
669 |
|
|
670 |
|
(defun ntp-clean (x) ;; FIXME same for t and (ntp-def x) |
671 |
|
(when (and (rassoc nil (ntp-tps x) :key 'car) (not (ntp-def x))) |
672 |
|
(setf (ntp-tps x) (lremove-if (lambda (x) (not (cadr x))) (ntp-tps x))))) |
673 |
|
|
674 |
|
(defun ntp-load (type &aux tem) |
675 |
|
(let ((ntp (make-ntp))) |
676 |
|
(cond ((eq (car type) t) (ntp-not ntp)) |
677 |
|
((setq tem (cdr (assoc (car type) +kindom-load-ops-alist+))) |
678 |
|
(funcall tem ntp type)) |
679 |
|
((setq tem (coerce-to-standard-class (car type))) |
680 |
|
(ntp-ld ntp `(standard-object ,tem))) |
681 |
|
((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data))) |
682 |
|
(ntp-ld ntp `(structure ,tem))) |
683 |
|
((eq (car type) 'member) |
684 |
|
(let ((els (cdr type))) |
685 |
|
(dolist (l +known-types+) |
686 |
|
(let ((z (lremove-if-not (lambda (x) (typep-int x l)) els))) |
687 |
|
(when z |
688 |
|
(setq els (set-difference els z)) |
689 |
|
(let* ((z (cond ((member l +range-types+) |
690 |
|
(reduce 'range-or (mapcar (lambda (x) (number-range-fixup `((,x . ,x)) l)) z))) |
691 |
|
((and (consp l) (eq (car l) 'complex)) |
692 |
|
(cons |
693 |
|
(reduce 'range-or (mapcar (lambda (x) (let ((q (realpart x))) |
694 |
|
(number-range-fixup `((,q . ,q)) (cadr l)))) z)) |
695 |
|
(reduce 'range-or (mapcar (lambda (x) (let ((q (imagpart x))) |
696 |
|
(number-range-fixup `((,q . ,q)) (cadr l)))) z)))) |
697 |
|
(`(member ,@z)))) |
698 |
|
(lst (and (consp l) (if (eq (car l) 'array) +array-type-alist+ +complex-type-alist+))) |
699 |
|
(z (and z `(,(if lst (cdr (assoc (cadr l) lst)) l) ,z)))) |
700 |
|
(ntp-ld ntp z))))) |
701 |
|
(let ((z (lremove-if-not (lambda (x) (typep-int x 'complex)) els))) |
702 |
|
(when z |
703 |
|
(setq els (set-difference els z)) |
704 |
|
(dolist (el z) |
705 |
|
(let* ((rt (car (member (realpart el) +range-types+ :test 'typep-int))) |
706 |
|
(it (car (member (imagpart el) +range-types+ :test 'typep-int))) |
707 |
|
(zr (let ((q (realpart el))) (number-range-fixup `((,q . ,q)) rt))) |
708 |
|
(zi (let ((q (imagpart el))) (number-range-fixup `((,q . ,q)) it)))) |
709 |
|
(ntp-ld ntp `(,(cdr (assoc rt +complex-type-alist+)) (,zr . nil))) |
710 |
|
(ntp-ld ntp `(,(cdr (assoc it +complex-type-alist+)) (nil . ,zi))))))) |
711 |
|
(when els (let ((ntp (ntp-not ntp))) (setf (ntp-ukn ntp) t))))) |
712 |
|
((car type) (let ((ntp (ntp-not ntp))) (setf (ntp-ukn ntp) t)))) ;(format t "not processing type ~a~%" type) |
713 |
|
ntp)) |
714 |
|
|
715 |
|
|
716 |
|
;; RANGE-TYPES |
717 |
|
|
718 |
|
(defun range-load (ntp type) |
719 |
|
(let* ((z `((,(cadr type) . ,(caddr type)))) |
720 |
|
(z (number-range-fixup z (car type)))) |
721 |
|
(ntp-ld ntp (let ((z `(,(car type) ,z))) z)))) |
722 |
|
|
723 |
|
(defun range-op (op x y) |
724 |
|
(case op |
725 |
|
(and (setf (cadr x) (range-and (cadr x) (cadr y)))) |
726 |
|
(or (setf (cadr x) (range-or (cadr x) (cadr y)))) |
727 |
|
(not (setf (cadr x) (range-not (cadr x)))))) |
728 |
|
|
729 |
|
|
730 |
|
(defun range-and (x y &optional res) |
731 |
|
(cond ((or (not x) (not y)) (nreverse res)) |
732 |
|
((elgt (car y) (car x)) (range-and (cdr x) y res)) |
733 |
|
((elgt (car x) (car y)) (range-and x (cdr y) res)) |
734 |
|
((let ((z (elin (cdar y) (cdar x) '<))) |
735 |
|
(range-and (if (equal z (cdar x)) (cdr x) x) (if (equal z (cdar y)) (cdr y) y) |
736 |
|
(cons (cons (elin (caar x) (caar y) '>) z) res)))))) |
737 |
|
|
738 |
|
;;FIXME handle cleanups here and in and |
739 |
|
(defun range-or (x y &optional res) |
740 |
|
(cond ((and (not x) (not y)) (nreverse res)) |
741 |
|
((not x) (range-or x (cdr y) (maybe-or-push (car y) res))) |
742 |
|
((not y) (range-or (cdr x) y (maybe-or-push (car x) res))) |
743 |
|
((elgt (car y) (car x)) (range-or (cdr x) y (maybe-or-push (car x) res))) |
744 |
|
((elgt (car x) (car y)) (range-or x (cdr y) (maybe-or-push (car y) res))) |
745 |
|
((range-or (cdr x) (cdr y) |
746 |
|
(maybe-or-push (cons (elout (caar x) (caar y) '<) (elout (cdar y) (cdar x) '>)) res))))) |
747 |
|
|
748 |
|
(defun maybe-or-push (x res) |
749 |
|
(cond ((not res) (list x)) |
750 |
|
((and (equal (elout (caar res) (car x) '<) (caar res)) |
751 |
|
(equal (elout (cdr x) (cdar res) '>) (cdar res))) |
752 |
|
res) |
753 |
|
((cons x res)))) |
754 |
|
|
755 |
|
(defun range-not (x &optional res (last '* lastp)) |
756 |
|
(cond ((not x) (nreverse (if (and lastp (eq last '*)) res (cons (cons (elcomp last) '*) res)))) |
757 |
|
((range-not (cdr x) (if (eq (caar x) last) res (cons (cons (elcomp last) (elcomp (caar x))) res)) (cdar x))))) |
758 |
|
|
759 |
(defun elgt (x y) |
(defun elgt (x y) |
760 |
(cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil) |
(cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil) |
775 |
((funcall op (range-num x) (range-num y)) x) |
((funcall op (range-num x) (range-num y)) x) |
776 |
(y))) |
(y))) |
777 |
|
|
|
(defun range-and (x y &optional res) |
|
|
(cond ((or (not x) (not y)) (nreverse res));(if (and (not x) (not y)) res (cons (car (or x y)) res)))) |
|
|
((elgt (car y) (car x)) (range-and (cdr x) y res)) |
|
|
((elgt (car x) (car y)) (range-and x (cdr y) res)) |
|
|
((let ((z (elin (cdar y) (cdar x) '<))) |
|
|
(range-and (if (equal z (cdar x)) (cdr x) x) (if (equal z (cdar y)) (cdr y) y) |
|
|
(cons (cons (elin (caar x) (caar y) '>) z) res)))))) |
|
|
|
|
|
(defun range-or (x y &optional res) |
|
|
(cond ((and (not x) (not y)) (nreverse res)) |
|
|
((not x) (range-or x (cdr y) (cons (car y) res))) |
|
|
((not y) (range-or (cdr x) y (cons (car x) res))) |
|
|
((elgt (car y) (car x)) (range-or (cdr x) y (cons (car x) res))) |
|
|
((elgt (car x) (car y)) (range-or x (cdr y) (cons (car y) res))) |
|
|
((and (equal (elout (caar x) (caar y) '<) (caar x)) |
|
|
(equal (elout (cdar y) (cdar x) '>) (cdar x))) (range-or x (cdr y) res)) |
|
|
((and (equal (elout (caar x) (caar y) '<) (caar y)) |
|
|
(equal (elout (cdar y) (cdar x) '>) (cdar y))) (range-or (cdr x) y res)) |
|
|
((range-or (cdr x) (cdr y);(if (equal (caar x) z) (cdr x) x) (if (equal (caar y) z) (cdr y) y) |
|
|
(cons (cons (elout (caar x) (caar y) '<) (elout (cdar y) (cdar x) '>)) res))))) |
|
|
|
|
|
(defmacro elcomp (x) `(cond ((eq ,x '*) ,x) ((atom ,x) (list ,x)) ((car ,x)))) |
|
|
|
|
|
(defun range-not (x &optional res (last '* lastp)) |
|
|
(cond ((not x) (nreverse (if (and lastp (eq last '*)) res (cons (cons (elcomp last) '*) res)))) |
|
|
((range-not (cdr x) (if (eq (caar x) last) res (cons (cons (elcomp last) (elcomp (caar x))) res)) (cdar x))))) |
|
|
; (let* ((el (elcomp last)) |
|
|
; (ex (elcomp (caar x))) |
|
|
; (il (if (atom el) el (car el))) |
|
|
; (ix (if (atom ex) ex (car ex)))) |
|
|
; (if (and (not (eq il '*)) (not (eq ix '*)) (= il ix) (or (listp el) (listp ex))) |
|
|
; res |
|
|
; (cons (cons el ex) res))) (cdar x))))) |
|
778 |
|
|
779 |
(defun imod (x p) |
(defun imod (x p) |
780 |
(if (eq x '*) x |
(if (eq x '*) x |
786 |
((+ cx p)))))) |
((+ cx p)))))) |
787 |
|
|
788 |
(defun integer-range-fixup (x &optional res) |
(defun integer-range-fixup (x &optional res) |
789 |
(cond ((not x) (remove-if (lambda (x) (and (realp (car x)) (realp (cdr x)) (> (car x) (cdr x)))) (nreverse res))) |
(cond ((not x) (lremove-if (lambda (x) (and (realp (car x)) (realp (cdr x)) (> (car x) (cdr x)))) (nreverse res))) |
790 |
((integer-range-fixup (cdr x) |
((integer-range-fixup (cdr x) |
791 |
(cons (cons (imod (caar x) 1) (imod (cdar x) -1)) res))))) |
(cons (cons (imod (caar x) 1) (imod (cdar x) -1)) res))))) |
792 |
|
|
793 |
(defun number-range-fixup (x tp) |
(defun number-range-fixup (x tp) |
794 |
(if (eq tp 'integer) |
(if (eq tp 'integer) |
795 |
(integer-range-fixup x) |
(integer-range-fixup x) |
796 |
(remove-if (lambda (x) (let ((a (car x)) (d (cdr x))) |
(lremove-if (lambda (x) (let ((a (car x)) (d (cdr x))) |
797 |
(let ((na (if (atom a) a (car a))) (nd (if (atom d) d (car d)))) |
(let ((na (if (atom a) a (car a))) (nd (if (atom d) d (car d)))) |
798 |
(and (not (eq na '*)) (not (eq nd '*)) |
(and (not (eq na '*)) (not (eq nd '*)) |
799 |
(= na nd) |
(= na nd) |
800 |
(or (listp a) (listp d)))))) x))) |
(or (listp a) (listp d)))))) x))) |
801 |
|
|
|
(defconstant +real-type-alist+ '((integer) |
|
|
(ratio) |
|
|
(short-float) |
|
|
(long-float) |
|
|
(rational integer ratio) |
|
|
(single-float long-float) |
|
|
(double-float long-float) |
|
|
(float long-float short-float) |
|
|
(real rational float))) |
|
|
|
|
|
(defconstant +numeric-logic-alist+ '((and . range-and) (or . range-or))) |
|
|
|
|
|
;;coerce nums t prope type |
|
|
;; sort non-reals |
|
|
;; comples |
|
|
(defun do-real-ranges (type &aux tem) |
|
|
(cond ((assoc type +real-type-alist+) (do-real-ranges `(,type * *))) |
|
|
((atom type) nil) |
|
|
((setq tem (cdr (assoc (car type) +numeric-logic-alist+) )) |
|
|
(reduce (lambda (x y) (mapcar tem x y)) (mapcar 'do-real-ranges (cdr type)))) |
|
|
((eq (car type) 'not) |
|
|
(mapcar 'range-not (do-real-ranges (cadr type)))) |
|
|
((eq (car type) 'member) |
|
|
(do-real-ranges |
|
|
`(or ,@(mapcar (lambda (x) |
|
|
(let ((tt (car (assoc x +real-type-alist+ :test 'typep)))) |
|
|
(when tt `(,tt ,x ,x)))) (cdr type))))) |
|
|
((setq tem (cdr (assoc (car type) +real-type-alist+))) |
|
|
(do-real-ranges `(or ,@(mapcar (lambda (x) `(,x ,@(cdr type))) tem)))) |
|
|
((setq tem (position (car type) +real-type-alist+ :key 'car)) |
|
|
(append (make-list tem) (list (list (cons (or (cadr type) '*) (or (caddr type) '*)))) (make-list (- 3 tem)))))) |
|
802 |
|
|
803 |
(defun exnr (type) |
(defun range-recon (x) |
804 |
`(or ,@(mapcar (lambda (x y) (when y `(,(car x) ,@y))) +real-type-alist+ (do-real-ranges type)))) |
(let ((z (mapcar (lambda (y) `(,(car x) ,(car y) ,(cdr y))) (number-range-fixup (cadr x) (car x))))) |
805 |
|
(if (cdr z) `(or ,@z) (car z)))) |
806 |
|
|
807 |
|
;; COMPLEX |
808 |
|
|
809 |
|
(defun complex-load (ntp type) |
810 |
|
(let* ((z `((,(cadr (cadr type)) . ,(caddr (cadr type))))) |
811 |
|
(z (number-range-fixup z (car type)))) |
812 |
|
(ntp-ld ntp `(,(cdr (assoc (car (cadr type)) +complex-type-alist+)) (,z . ,z))))) |
813 |
|
|
814 |
|
(defun complex-op (op x y) |
815 |
|
(let ((z |
816 |
|
(case op |
817 |
|
(and (cons (range-and (caadr x) (caadr y)) (range-and (cdadr x) (cdadr y)))) |
818 |
|
(or (cons (range-or (caadr x) (caadr y)) (range-or (cdadr x) (cdadr y)))) |
819 |
|
(not (cons (range-not (caadr x) (caadr y)) (range-not (cdadr x) (cdadr y))))))) |
820 |
|
(setf (cadr x) (and (car z) (cdr z) z)))) |
821 |
|
|
822 |
|
(defun complex-recon (x) |
823 |
|
(let* ((tp (car (rassoc (car x) +complex-type-alist+))) |
824 |
|
(z (range-or (caadr x) (cdadr x))) |
825 |
|
(z (number-range-fixup z tp)) |
826 |
|
(z (mapcar (lambda (y) `(complex (,tp ,(car y) ,(cdr y)))) z))) |
827 |
|
(if (cdr z) `(or ,@z) (car z)))) |
828 |
|
|
829 |
|
|
830 |
|
;; SINGLETON-TYPES |
831 |
|
|
832 |
|
(defun single-load (ntp type) |
833 |
|
(ntp-ld ntp `(,(car type) t))) |
834 |
|
|
835 |
|
(defun single-atm (x) |
836 |
|
(cond ((or (eq x t) (not x))) |
837 |
|
((and (consp x) (eq (car x) 'member))) |
838 |
|
((and (consp x) (eq (car x) 'not)) (single-atm (cadr x))))) |
839 |
|
|
840 |
|
(defun single^ (x y) |
841 |
|
(cond ((eq x t) y) |
842 |
|
((eq y t) x) |
843 |
|
((and x y) (let ((z (intersection (cdr x) (cdr y)))) (when z `(member ,@z)))))) |
844 |
|
|
845 |
|
(defun single-op (op x y) |
846 |
|
(setf (cadr x) |
847 |
|
(case op |
848 |
|
((and or) (sigalg-atom-op op (cadr x) (cadr y) 'single^ 'single-atm)) |
849 |
|
(not (negate (cadr x)))))) |
850 |
|
|
851 |
|
(defun single-recon (x) |
852 |
|
(cond ((atom (cadr x)) (car x)) |
853 |
|
((cadr x)))) |
854 |
|
|
855 |
|
|
856 |
|
;; ARRAY TYPES |
857 |
|
|
858 |
|
(defun array-load (ntp type) |
859 |
|
(let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME |
860 |
|
(z (if (eq z '*) z (car (member z +array-types+))))) |
861 |
|
(unless z (error "Bad array type ~a~%" (cadr type))) |
862 |
|
(let* ((dim (caddr type)) |
863 |
|
(dim (cond ((eq dim '*) t) |
864 |
|
((integerp dim) (if (= 0 dim) dim (make-list dim :initial-element t))) |
865 |
|
((listp dim) (substitute t '* dim))))) ;FIXME consing |
866 |
|
(if (eq z '*) |
867 |
|
(dolist (l +array-type-alist+) |
868 |
|
(ntp-ld ntp `(,(cdr l) ,dim))) |
869 |
|
(ntp-ld ntp `(,(cdr (assoc z +array-type-alist+)) ,dim)))))) |
870 |
|
|
871 |
(defun type-null (type) |
(defun array-atm (x) |
872 |
(equal type `(or nil nil nil nil))) |
(cond ((atom x)) |
873 |
|
((eq (car x) 'not) (array-atm (cadr x))) |
874 |
|
((integerp (car x))) |
875 |
|
((eq (car x) 'member)) |
876 |
|
((eq (car x) t)))) |
877 |
|
|
878 |
(defun subtypep (t1 t2 &optional env) |
(defun array^ (x y) |
879 |
(declare (ignore env)) |
(cond ((not (and x y)) nil) |
880 |
(let ((r (not (resolve-type `(and ,t1 (not ,t2)))))) |
((eq y t) x) |
881 |
(values r t))) |
((eq x t) y) |
882 |
|
((and (integerp x) (integerp y)) (when (= x y) x)) |
883 |
(defun *typep (object type) |
((integerp x) (when (and (consp y) (= x (length y))) y)) |
884 |
(or (pcl-complete-redirect '*typep object type) |
((integerp y) (array^ y x)) |
885 |
(pcl-redirect '*typep object type))) |
((and (consp x) (eq (car x) 'member)) |
886 |
(defun *subtypep (type1 type2) |
(let ((y (cond ((and (consp y) (eq (car y) 'member)) y) |
887 |
(let ((l (multiple-value-list (pcl-complete-redirect '*subtypep type1 type2)))) |
((eq y t) `(array * *)) |
888 |
(if (cdr l) |
((and (consp y) (member t y)) `(array * ,(substitute '* t y))) |
889 |
(values (car l) (cdr l))) |
(`(array * ,y))))) |
890 |
(pcl-redirect '*subtypep type1 type2))) |
(let ((q (lremove-if-not (lambda (z) (typep-int z y)) (cdr x)))) |
891 |
|
(when q `(member ,@q))))) |
892 |
|
((and (consp y) (eq (car y) 'member)) (array^ y x)) |
893 |
|
((/= (length x) (length y)) nil) |
894 |
|
((mapcar 'array^ x y)))) |
895 |
|
|
896 |
|
(defun array-op (op x y) |
897 |
|
(setf (cadr x) |
898 |
|
(case op |
899 |
|
((and or) (sigalg-op op (cadr x) (cadr y) 'array^ 'array-atm)) |
900 |
|
(not (negate (cadr x)))))) |
901 |
|
|
902 |
;;; TYPEP predicate. |
(defun array-recon (x) |
903 |
;;; FIXME --optimize with most likely cases first |
`(array ,(car (rassoc (car x) +array-type-alist+)) ,(cadr x))) |
904 |
(defun typep (object type &optional env &aux tp i tem) |
|
905 |
(declare (ignore env)) |
;; STRUCTURES |
906 |
(if (atom type) |
|
907 |
(setq tp type i nil) |
(defun structure-load (ntp type) (single-load ntp type));;FIXME macro |
908 |
(setq tp (car type) i (cdr type))) |
|
909 |
(if (eq tp 'structure-object) (setq tp 'structure)) |
(defun structure-atm (x) (standard-atm x)) |
910 |
(let ((f (and (not i) (get tp 'type-predicate)))) |
|
911 |
(when f (return-from typep (funcall f object)))) |
(defun structure^ (x y) |
912 |
(case tp |
(cond ((not (and x y)) nil) |
913 |
(cons (and (consp object) (typep (car object) (car i)) (typep (cdr object) (cadr i)))) |
((eq x t) y) |
914 |
(member (member object i)) |
((eq y t) x) |
915 |
(not (not (typep object (car i)))) |
((and (consp x) (eq (car x) 'member)) |
916 |
(or |
(let ((q (lremove-if-not (lambda (z) (typep-int z y)) (cdr x)))) |
917 |
(do ((l i (cdr l))) |
(when q `(member ,@q)))) |
918 |
((null l) nil) |
((and (consp y) (eq (car y) 'member)) (structure^ y x)) |
919 |
(when (typep object (car l)) (return t)))) |
((do ((z x (s-data-includes z))) ((or (not z) (eq z y)) (and z x)))) |
920 |
(and |
((do ((z y (s-data-includes z))) ((or (not z) (eq z x)) (and z y)))))) |
921 |
(do ((l i (cdr l))) |
|
922 |
((null l) t) |
(defun structure-op (op x y) |
923 |
(unless (typep object (car l)) (return nil)))) |
(setf (cadr x) |
924 |
(satisfies (funcall (car i) object)) |
(case op |
925 |
((t) t) |
((and or) (sigalg-op op (cadr x) (cadr y) 'structure^ 'structure-atm)) |
926 |
((nil) (not object)) |
(not (negate (cadr x)))))) |
927 |
(boolean (or (eq object 't) (eq object 'nil))) |
|
928 |
(fixnum (eq (type-of object) 'fixnum)) |
(defun structure-recon (x) (single-recon x)) |
929 |
(bignum (eq (type-of object) 'bignum)) |
|
930 |
(ratio (eq (type-of object) 'ratio)) |
;; STANDARD-OBJECTS |
931 |
(standard-char |
|
932 |
(and (characterp object) (standard-char-p object))) |
(defun standard-load (ntp type) (single-load ntp type)) |
933 |
((base-char string-char) |
|
934 |
(and (characterp object) (string-char-p object))) |
(defun standard-atm (x) |
935 |
(integer |
(cond ((atom x)) |
936 |
(and (integerp object) (in-interval-p object i))) |
((eq (car x) 'not) (standard-atm (cadr x))) |
937 |
(rational |
((eq (car x) 'member)))) |
938 |
(and (rationalp object) (in-interval-p object i))) |
|
939 |
(real |
(defun standard^ (x y) |
940 |
(and (realp object) (in-interval-p object i))) |
(cond ((not (and x y)) nil) |
941 |
(float |
((eq x t) y) |
942 |
(and (floatp object) (in-interval-p object i))) |
((eq y t) x) |
943 |
((short-float) |
((and (consp x) (eq (car x) 'member)) |
944 |
(and (eq (type-of object) 'short-float) (in-interval-p object i))) |
(let ((q (lremove-if-not (lambda (z) (typep-int z y)) (cdr x)))) |
945 |
((single-float double-float long-float) |
(when q `(member ,@q)))) |
946 |
(and (eq (type-of object) 'long-float) (in-interval-p object i))) |
((and (consp y) (eq (car y) 'member)) (standard^ y x)) |
947 |
(complex |
((member y (class-precedence-list x)) x) |
948 |
(and (complexp object) |
((member x (class-precedence-list y)) y))) |
949 |
|
|
950 |
(or (null i) |
(defun standard-op (op x y) |
951 |
(and (typep (realpart object) (car i)) |
(setf (cadr x) |
952 |
;;wfs--should only have to check one. |
(case op |
953 |
;;Illegal to mix real and imaginary types! |
((and or) (sigalg-op op (cadr x) (cadr y) 'standard^ 'standard-atm)) |
954 |
(typep (imagpart object) (car i)))) |
(not (negate (cadr x)))))) |
955 |
)) |
|
956 |
(sequence (or (listp object) (vectorp object))) |
(defun standard-recon (x) (single-recon x)) |
957 |
((base-string string) ;FIXME |
|
958 |
(and (stringp object) |
;; CONS |
959 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
|
960 |
(bit-vector |
(defun cons-load (ntp type) |
961 |
(and (bit-vector-p object) |
(ntp-ld ntp `(cons (,(nprocess-type (cadr type)) . ,(nprocess-type (caddr type)))))) |
962 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
|
963 |
((simple-base-string simple-string) ;FIXME |
(defun cons-atm (x) |
964 |
(and (simple-string-p object) |
(cond ((not x)) |
965 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
((eq x t)) |
966 |
(simple-bit-vector |
((and (consp x) |
967 |
(and (simple-bit-vector-p object) |
(consp (car x)) (= (length (car x)) 3) |
968 |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
(consp (cdr x)) (= (length (cdr x)) 3))))) |
969 |
(simple-vector |
|
970 |
(and (simple-vector-p object) |
(defun cons^ (x y) |
971 |
(or (endp i) (eq (car i) '*) |
(cond ((eq x t) y) |
972 |
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
((eq y t) x) |
973 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
((and x y) |
974 |
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
(let ((ax (copy-tree (car x))) |
975 |
(vector |
(dx (copy-tree (cdr x)))) |
976 |
(and (vectorp object) |
(cons-to-nil |
977 |
(or (endp i) (eq (car i) '*) |
(cons (ntp-and ax (car y)) |
978 |
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
(ntp-and dx (cdr y)))))))) |
979 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
|
980 |
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
(defun cons-op (op x y) |
981 |
(simple-array |
(setf (cadr x) |
982 |
(and (simple-array-p object) |
(case op |
983 |
(or (endp i) (eq (car i) '*) |
((and or) (cons-to-nil (sigalg-op op (cadr x) (cadr y) 'cons^ 'cons-atm))) |
984 |
(equal (array-element-type object)(best-array-element-type (car i)))) |
(not |
985 |
(or (endp (cdr i)) (eq (cadr i) '*) |
(cond ((not (cadr x))) |
986 |
(if (listp (cadr i)) |
((eq (cadr x) t) nil) |
987 |
(match-dimensions (array-dimensions object) (cadr i)) |
((cons-atm (cadr x)) |
988 |
(eql (array-rank object) (cadr i)))))) |
(let ((car (ntp-to-nil (ntp-not (caadr x))));FIXME |
989 |
(array |
(cdr (ntp-to-nil (ntp-not (cdadr x))))) |
990 |
(and (arrayp object) |
(cond ((and car cdr) |
991 |
(or (endp i) (eq (car i) '*) |
(cons-to-nil |
992 |
;; Or the element type of object should be EQUAL to (car i). |
(sigalg-op 'or `(,car . ,(nprocess-type '(t))) |
993 |
;; Is this too strict? |
`(,(nprocess-type '(t)) . ,cdr) 'cons^ 'cons-atm))) |
994 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
(car (cons car (nprocess-type '(t)))) |
995 |
(or (endp (cdr i)) (eq (cadr i) '*) |
(cdr (cons (nprocess-type '(t)) cdr))))) |
996 |
(if (listp (cadr i)) |
(t (reduce (lambda (&rest xy) |
997 |
(match-dimensions (array-dimensions object) (cadr i)) |
(when xy |
998 |
(eql (array-rank object) (cadr i)))))) |
(cons-to-nil |
999 |
(file-stream (eq (type-of object) 'file-stream)) |
(sigalg-op |
1000 |
(string-stream (eq (type-of object) 'string-stream)) |
(if (eq (caadr x) 'or) 'and 'or) (car xy) (cadr xy) 'cons^ 'cons-atm)))) |
1001 |
(synonym-stream (eq (type-of object) 'synonym-stream)) |
(mapcar (lambda (x) (cons-op 'not `(cons ,x) nil)) (cdadr x)))) nil))))) |
1002 |
(concatenated-stream (eq (type-of object) 'concatenated-stream)) |
|
1003 |
(two-way-stream (eq (type-of object) 'two-way-stream)) |
(defun cons-to-nil (cntp) |
1004 |
(echo-stream (eq (type-of object) 'echo-stream)) |
(let* ((at (or (atom cntp) (not (cons-atm cntp)))) |
1005 |
(logical-pathname |
(car (or at (atom (car cntp)) (ntp-to-nil (car cntp)))) |
1006 |
(and (pathnamep object) |
(cdr (or at (atom (cdr cntp)) (ntp-to-nil (cdr cntp))))) |
1007 |
(not (endp (si:pathname-lookup (pathname-host object) |
(and car cdr cntp))) |
1008 |
si:*pathname-logical*))))) |
|
1009 |
(t |
(defun ntp-to-nil (ntp) |
1010 |
(cond ((setq tem (get tp 'deftype-definition)) |
(when (or (ntp-tps ntp) (ntp-def ntp)) |
1011 |
(typep object |
ntp)) |
1012 |
(apply tem i))) |
|
1013 |
((setq tem (get tp 'si::s-data)) |
(defun cons-recon (x) |
1014 |
(structure-subtype-p object tem)) |
(cond ((eq t (cadr x)) `(cons t t)) |
1015 |
)))) |
((atom (cadr x)) nil) |
1016 |
|
((cons-atm (cadr x)) |
1017 |
|
(let ((car (nreconstruct-type (caadr x))) |
1018 |
(defun normalize-type (type &optional ar &aux tem) |
(cdr (nreconstruct-type (cdadr x)))) |
1019 |
(cond ((atom type) (normalize-type (list type) ar)) |
(and car cdr `(cons ,car ,cdr)))) |
1020 |
((and (eq (car type) 'satisfies) (setq tem (get (cadr type) 'predicate-type))) |
((eq (caadr x) 'or) |
1021 |
(normalize-type tem ar)) |
(let ((z (lremove-if 'not (mapcar (lambda (x) (cons-recon `(cons ,x))) (cdadr x))))) |
1022 |
((let* ((dt (and (symbolp (car type)) (get (car type) 'deftype-definition))) |
(if (cdr z) `(or ,@z) (car z)))) |
1023 |
(nt (and dt (apply dt (cdr type))))) |
((error "Bad cons recon~%")))) |
1024 |
(when (and nt (not (equal type nt)) (not (and (eq (car nt) 'satisfies) (find-class (car type) nil)))) |
|
1025 |
(normalize-type nt ar)))) |
|
1026 |
((and ar (member (car type) '(array simple-array))) |
;; GENERIC SIGNA ALGEBRA OPERATIONS |
1027 |
`(,(car type) ,(upgraded-array-element-type (cadr type)) ,(caddr type))) |
|
1028 |
((eq (car type) 'complex) |
(defun sigalg-op (op x y ^ atm) |
1029 |
`(complex ,(normalize-type (cadr type) ar))) |
(let ((ax (funcall atm x))) |
1030 |
((and (eq (car type) 'cons) (cdr type)) |
(cond ((and (not ax) (eq op (car x))) |
1031 |
(let* ((a (normalize-type (cadr type) ar)) |
(sigalg-op op (cadr x) (clean-tp op atm (cddr x) (if (funcall atm y) (list y) y)) ^ atm)) |
1032 |
(ai (if (cdr a) a (car a))) |
((and (not ax) (eq 'not (car x))) |
1033 |
(d (normalize-type (caddr type) ar)) |
(negate (sigalg-op (if (eq op 'or) 'and 'or) (negate x) (negate y) ^ atm))) |
1034 |
(di (if (cdr d) d (car d)))) |
((not ax);FIXME reduce here? |
1035 |
(and ai di `(cons ,a ,d)))) |
(clean-tp |
1036 |
((member (car type) '(and or not)) |
(if (eq op 'or) 'and 'or) |
1037 |
(let ((z `(,(car type)))) |
atm |
1038 |
(dolist (l (mapcar (lambda (z) (normalize-type z ar)) (cdr type))) |
(mapcar (lambda (w) (sigalg-op op w y ^ atm)) (cdr x)))) |
1039 |
(if (and (eq (car l) (car type)) (not (eq (car type) 'not))) |
((funcall atm y) (sigalg-atom-op op x y ^ atm)) |
1040 |
(dolist (w (cdr l)) (push w z)) |
((eq op (car y)) |
1041 |
(push l z))) |
(let* ((y (if (cddr y) (sigalg-op op (cadr y) `(,op ,@(cddr y)) ^ atm) y)) |
1042 |
(if (cdr z) |
(y (if (or (atom y) (not (eq (car y) op))) `(,op ,y) y)) |
1043 |
(nreverse z) |
(q (mapcar (lambda (z) (sigalg-op op x z ^ atm)) (cdr y)))) |
1044 |
(case (car z) (and '(t)) (or '(nil)) (not (error "Bad type~%")))))) |
(let ((z |
1045 |
(type))) |
(clean-tp |
1046 |
|
op atm |
1047 |
|
(do ((y (cdr y) (cdr y)) (q q (cdr q))) |
1048 |
|
((or (not y) (not q) (equal (car y) (car q))) (if (and y q) (eq op 'and) x))) |
1049 |
|
; (if (some 'equal (cdr y) q) (eq op 'and) x) |
1050 |
|
(mapcar (lambda (x y) (if (funcall atm y) y x)) |
1051 |
|
(cdr y) q)))) |
1052 |
|
(if (funcall atm z) z |
1053 |
|
(let ((ny (clean-tp op atm (cddr z)))) |
1054 |
|
(if (and (equal x (cadr z)) (equal ny y)) |
1055 |
|
z |
1056 |
|
(sigalg-op op (cadr z) ny ^ atm))))))) |
1057 |
|
((eq 'not (car y)) |
1058 |
|
(negate (sigalg-op (if (eq op 'or) 'and 'or) (negate x) (negate y) ^ atm))) |
1059 |
|
(t |
1060 |
|
(let ((z (mapcar (lambda (w) (sigalg-op op x w ^ atm)) (cdr y)))) |
1061 |
|
(reduce (lambda (&rest xy) (when xy (sigalg-op (if (eq op 'or) 'and 'or) (car xy) (cadr xy) ^ atm))) z)))))) |
1062 |
|
|
1063 |
|
|
1064 |
|
(defun sigalg-atom-op (op ox oy ^ atm) |
1065 |
|
(let* ((cx (and (consp ox) (eq (car ox) 'not))) |
1066 |
|
(x (if cx (cadr ox) ox)) |
1067 |
|
(cy (and (consp oy) (eq (car oy) 'not))) |
1068 |
|
(y (if cy (cadr oy) oy)) |
1069 |
|
(^xy (funcall ^ x y)) |
1070 |
|
(vxy (memberv x y)) |
1071 |
|
(-xy (if vxy (member- x y) x)) |
1072 |
|
(-yx (if vxy (member- y x) y)) |
1073 |
|
(<xy (equal ^xy x)) |
1074 |
|
(<yx (equal ^xy y)) |
1075 |
|
(opor (case op (or t) (and nil) (otherwise (error "Bad op~%"))))) |
1076 |
|
(cond ((not (or cx cy)) |
1077 |
|
(cond (<xy (if opor y x)) |
1078 |
|
(<yx (if opor x y)) |
1079 |
|
(opor (or vxy (clean-or atm `(or ,x ,y)))) |
1080 |
|
(^xy))) |
1081 |
|
((and cx cy) |
1082 |
|
(cond (<xy `(not ,(if opor x y))) |
1083 |
|
(<yx `(not ,(if opor y x))) |
1084 |
|
(opor (negate ^xy)) |
1085 |
|
((negate (sigalg-atom-op 'or x y ^ atm))))) |
1086 |
|
(cx (sigalg-atom-op op oy ox ^ atm)) |
1087 |
|
((and <xy <yx) opor) |
1088 |
|
(<xy (when opor |
1089 |
|
(if (equal -yx y) |
1090 |
|
(clean-or atm `(or ,x ,(negate y))) |
1091 |
|
(negate -yx)))) |
1092 |
|
(<yx (if opor t (if (equal x -xy) (clean-and atm `(and ,x ,(negate y))) -xy))) |
1093 |
|
(opor (if (funcall ^ ^xy -yx) (clean-or atm `(or ,^xy ,(negate -yx))) (negate -yx))) |
1094 |
|
((clean-and atm (if (funcall ^ -xy ^xy) `(and ,-xy ,(negate ^xy)) -xy)))))) |
1095 |
|
|
1096 |
|
|
1097 |
|
(defun memberv (x y) |
1098 |
|
(and (consp x) (consp y) |
1099 |
|
(eq (car x) 'member) (eq (car y) 'member) |
1100 |
|
(let ((z (union (cdr x) (cdr y)))) |
1101 |
|
(and z `(member ,@z))))) |
1102 |
|
|
1103 |
|
(defun member- (x y) |
1104 |
|
(and (consp x) (consp y) |
1105 |
|
(eq (car x) 'member) (eq (car y) 'member) |
1106 |
|
(let ((z (set-difference (cdr x) (cdr y)))) |
1107 |
|
(and z `(member ,@z))))) |
1108 |
|
|
1109 |
|
|
1110 |
|
(defun clean-or (atm lst) |
1111 |
|
(if (funcall atm lst) lst |
1112 |
|
(or |
1113 |
|
(car (member t lst)) |
1114 |
|
(let ((nl (lremove-if 'not (remove-duplicates (cdr lst) :test 'equal)))) |
1115 |
|
(if (cdr nl) `(or ,@nl) (car nl)))))) |
1116 |
|
|
1117 |
|
(defun clean-and (atm lst) |
1118 |
|
(if (funcall atm lst) lst |
1119 |
|
(unless (member nil lst) |
1120 |
|
(let ((nl (lremove-if (lambda (z) (eq z t)) (remove-duplicates (cdr lst) :test 'equal)))) |
1121 |
|
(if (cdr nl) `(and ,@nl) (or (car nl) t)))))) |
1122 |
|
|
1123 |
|
|
1124 |
|
(defun clean-tp (op atm x &optional y) |
1125 |
|
(let ((cf (case op (or 'clean-or) (and 'clean-and) (otherwise (error "Bad op~%")))) |
1126 |
|
(x (if (funcall atm x) (list x) x))) |
1127 |
|
(let ((z (cond ((eq (car y) op) (funcall cf atm `(,op ,@x ,@(cdr y)))) |
1128 |
|
((member (car y) '(and not or)) `(,op ,@x ,y)) |
1129 |
|
((funcall cf atm `(,op ,@x ,@y)))))) |
1130 |
|
z))) |
1131 |
|
|
1132 |
|
(defmacro negate (lst) |
1133 |
|
(let ((l (gensym))) |
1134 |
|
`(let ((,l ,lst)) |
1135 |
|
(cond ((not ,l)) |
1136 |
|
((eq ,l t) nil) |
1137 |
|
((and (consp ,l) (eq (car ,l) 'not)) (cadr ,l)) |
1138 |
|
(`(not ,,l)))))) |
1139 |
|
|
1140 |
|
|
1141 |
|
|
1142 |
|
(defun nreconstruct-type (x) |
1143 |
|
(if (ntp-ukn x) t |
1144 |
|
(if (ntp-def x) |
1145 |
|
(let ((z (nreconstruct-type (ntp-not x)))) |
1146 |
|
(or (not z) `(not ,z))) |
1147 |
|
(let ((z (lremove-if |
1148 |
|
'not |
1149 |
|
(mapcar (lambda (x) |
1150 |
|
(let ((op (cdr (assoc (car x) +kindom-recon-ops-alist+)))) |
1151 |
|
(funcall op x))) (ntp-tps x))))) |
1152 |
|
(if (cdr z) `(or ,@z) (car z)))))) |
1153 |
|
|
1154 |
|
|
1155 |
|
|
1156 |
|
;; CLASS HACKS |
1157 |
|
|
1158 |
|
|
1159 |
|
|
1160 |
|
(defun classp (object) (declare (ignore object)) nil) |
1161 |
|
(defun class-precedence-list (object) (declare (ignore object)) nil) |
1162 |
|
(defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil) |
1163 |
|
(defun class-name (class) (declare (ignore class)) nil) |
1164 |
|
|
1165 |
|
(defun is-standard-class-symbol (sym) |
1166 |
|
(let* ((z (get sym 'deftype-definition)) |
1167 |
|
(z (and z (not (caddr (get sym 'deftype-form))) (funcall z))) |
1168 |
|
(z (and (consp z) (eq (car z) 'satisfies) (cadr z)))) |
1169 |
|
(and z (not (member (symbol-package z) '(lisp si compiler) :key 'find-package))))) |
1170 |
|
|
1171 |
|
(defun find-standard-class (object) |
1172 |
|
(and (symbolp object) |
1173 |
|
(is-standard-class-symbol object) |
1174 |
|
(find-class object nil))) |
1175 |
|
|
1176 |
|
(defun coerce-to-standard-class (object) |
1177 |
|
(cond ((and (classp object) |
1178 |
|
(is-standard-class-symbol (class-name object))) |
1179 |
|
object) |
1180 |
|
((find-standard-class object)))) |
1181 |
|
|
|
;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. |
|
|
;;; The result is always a list. |
|
|
;(defun normalize-type (type &aux tp i ) |
|
|
;; Loops until the car of type has no DEFTYPE definition. |
|
|
; (when (and (consp type) (eq (car type) 'satisfies)) |
|
|
; (when (setq tp (get (cadr type) 'predicate-type)) |
|
|
; (setq type tp))) |
|
|
; (loop |
|
|
; (if (atom type) |
|
|
; (setq tp type i nil) |
|
|
; (setq tp (car type) i (cdr type))) |
|
|
; (let* ((dt (get tp 'deftype-definition)) |
|
|
; (nt (and dt (apply dt i)))) |
|
|
; (if (and nt (not (equal type nt))) |
|
|
; (setq type nt) |
|
|
; (return-from normalize-type (if (atom type) (list type) type)))))) |
|
|
|
|
|
|
|
|
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
|
|
;;; The type may not be normalized. |
|
|
|
|
|
;;FIXME -- get rid of this list. And those in subtypep. CM 20050106 |
|
|
(defun known-type-p (type) |
|
|
(when (consp type) (setq type (car type))) |
|
|
(if (and (symbolp type) |
|
|
(or (equal (string type) "ERROR") ;FIXME error symbol |
|
|
(member type |
|
|
'(t nil boolean null symbol keyword atom cons list sequence |
|
|
non-negative-char negative-char signed-char unsigned-char |
|
|
non-negative-short negative-short signed-short unsigned-short |
|
|
non-negative-fixnum negative-fixnum |
|
|
number integer bignum rational ratio float method-combination |
|
|
short-float single-float double-float long-float complex |
|
|
character standard-char string-char real |
|
|
package stream pathname readtable hash-table random-state |
|
|
structure array simple-array function compiled-function |
|
|
arithmetic-error base-char base-string broadcast-stream |
|
|
built-in-class cell-error class concatenated-stream condition |
|
|
control-error division-by-zero echo-stream end-of-file error |
|
|
extended-char file-error file-stream floating-point-inexact |
|
|
floating-point-invalid-operation floating-point-overflow |
|
|
floating-point-underflow generic-function logical-pathname method |
|
|
package-error parse-error print-not-readable program-error |
|
|
reader-error serious-condition simple-base-string simple-condition |
|
|
simple-type-error simple-warning standard-class |
|
|
standard-generic-function standard-method standard-object |
|
|
storage-condition stream-error string-stream structure-class |
|
|
style-warning synonym-stream two-way-stream structure-object |
|
|
type-error unbound-slot unbound-variable undefined-function |
|
|
warning )) |
|
|
(get type 's-data) |
|
|
(find-class (implicit-symbol type nil) nil))) |
|
|
t |
|
|
nil)) |
|
|
|
|
|
(defun implicit-symbol (a b) |
|
|
(cond ((not (consp a)) |
|
|
(or (and (symbolp a) a) b)) |
|
|
((null b) |
|
|
(let ((b (car a))) |
|
|
(and (symbolp b) (implicit-symbol (cdr a) b)))) |
|
|
((let ((a (car a))) (or (eq a '*) (eq a t))) |
|
|
(implicit-symbol (cdr a) b)))) |
|
|
|
|
|
;(defun implicit-symbol (a b) |
|
|
; (cond ((atom a) (when (symbolp a) a)) |
|
|
; ((subsetp (cdr a) '(t *)) (car a)))) |
|
1182 |
|
|
|
(defun upgraded-array-element-type (type &optional environment) |
|
|
(declare (ignore environment)) |
|
|
(best-array-element-type type)) |
|
1183 |
|
|
|
(defun type-null (type) |
|
|
(cond ((atom type) (not type)) |
|
|
((eq (car type) 'and) |
|
|
(every (lambda (x) |
|
|
(or (and (consp x) (member (car x) '(and or member not))) |
|
|
(every (lambda (y) |
|
|
(or (and (consp y) (member (car y) '(and or member not))) |
|
|
(subtypep x `(not ,y))))))))))) |
|
|
|
|
|
|
|
|
;;; SUBTYPEP predicate. |
|
|
(defun osubtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
|
|
(declare (ignore env)) |
|
|
(let* ((t1 (or (find-class (implicit-symbol type1 nil) nil) (when (classp type1) type1))) |
|
|
(t2 (or (find-class (implicit-symbol type2 nil) nil) (when (classp type2) type2)))) |
|
|
(when (and t1 t2) |
|
|
(return-from osubtypep |
|
|
(if (member t2 (class-precedence-list t1)) |
|
|
(values t t) (values nil t))))) |
|
|
; (when (or t1 t2) |
|
|
; (return-from osubtypep (values nil nil)))) |
|
|
(setq t1 (normalize-type type1)) |
|
|
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
|
|
(setq t2 (normalize-type type2)) |
|
|
(setq type2 (if (eq (car t2) 'satisfies) (list type2) t2)) |
|
|
; (setq type1 (normalize-type type1)) |
|
|
; (setq type2 (normalize-type type2)) |
|
|
(setq t1 (car type1) t2 (car type2)) |
|
|
(setq i1 (effective-range t1 (cdr type1)) i2 (effective-range t2 (cdr type2))) |
|
|
(cond ((eq t1 'member) |
|
|
(dolist (e i1) |
|
|
(unless (typep e type2) (return-from osubtypep (values nil t)))) |
|
|
(return-from osubtypep (values t t))) |
|
|
((eq t1 'or) |
|
|
(dolist (tt i1) |
|
|
(multiple-value-bind (tv flag) (osubtypep tt (if i2 type2 t2)) |
|
|
(unless tv (return-from osubtypep (values tv flag))))) |
|
|
(return-from osubtypep (values t t))) |
|
|
((eq t1 'and) |
|
|
(let* ((i1 (remove-duplicates i1 :test 'equal)) |
|
|
(i1 (if (not (cdr i1)) i1 |
|
|
(intersection i1 i1 :test |
|
|
(lambda (x y) (and (not (equal x y)) |
|
|
(let ((r (multiple-value-list (osubtypep x y))) |
|
|
(s (multiple-value-list (osubtypep y x)))) |
|
|
(or (car r) (not (cadr r)) |
|
|
(car s) (not (cadr s)))))))))) |
|
|
(unless i1 (return-from osubtypep (values (if (if i2 type2 t2) nil t) t))) |
|
|
(dolist (tt i1) |
|
|
(let ((tv (osubtypep tt (if i2 type2 t2)))) |
|
|
(when tv (return-from osubtypep (values t t))))));;FIXME t2 nil |
|
|
(return-from osubtypep (values nil (and (not t2) (some 'known-type-p i1))))) |
|
|
((eq t1 'not) |
|
|
;; |
|
|
(return-from osubtypep |
|
|
(if (eq t2 'not) |
|
|
(osubtypep (car i2) (car i1)) |
|
|
(let ((r (osubtypep t `(or ,(if i2 type2 t2) ,(car i1))))) |
|
|
(values r (or r (osubtypep type1 `(not ,(if i2 type2 t2)))))))))) |
|
|
(cond ((eq t2 'member) |
|
|
(return-from osubtypep (values nil nil))) |
|
|
((eq t2 'or) |
|
|
(dolist (tt i2) |
|
|
(let ((tv (osubtypep (if i1 type1 t1) tt))) |
|
|
(when tv (return-from osubtypep (values t t))))) |
|
|
(return-from osubtypep (values nil (if (eq t1 t) t nil)))) |
|
|
((eq t2 'and) |
|
|
(dolist (tt i2) |
|
|
(multiple-value-bind (tv flag) (osubtypep (if i1 type1 t1) tt) |
|
|
(unless tv (return-from osubtypep (values tv flag))))) |
|
|
(return-from osubtypep (values t t))) |
|
|
((eq t2 'not) |
|
|
(return-from osubtypep (let ((r (osubtypep `(and ,(if i1 type1 t1) ,(car i2)) nil))) |
|
|
(values r (or r (osubtypep (if i1 type1 t1) (car i2)))))))) |
|
|
|
|
|
(when (equal type1 type2) |
|
|
(return-from osubtypep (values t t))) |
|
|
(setq ntp1 (known-type-p type1) ntp2 (known-type-p type2)) |
|
|
(cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t)) |
|
|
((eq t2 'nil) (values (eq t1 'extended-char) ntp1)) |
|
|
((eq t1 't) (values nil ntp2)) |
|
|
((eq t1 'common) (values nil ntp2)) |
|
|
((eq t2 'cons) |
|
|
(cond ((eq t1 'cons) |
|
|
(macrolet ((ct (f x) |
|
|
(let ((tmp (gensym))) |
|
|
`(let ((,tmp (,f ,x))) |
|
|
(cond ((eq ,tmp '*) t) |
|
|
((null ,tmp) t) |
|
|
(t ,tmp)))))) |
|
|
(return-from osubtypep (values (and (osubtypep (ct car i1) (ct car i2)) |
|
|
(osubtypep (ct cadr i1) (ct cadr i2))) t)))) |
|
|
(t |
|
|
(values nil ntp1)))) |
|
|
((eq t2 'list) |
|
|
(cond ((member t1 '(null cons)) (values t t)) |
|
|
(t (values nil ntp1)))) |
|
|
((eq t2 'sequence) |
|
|
(cond ((member t1 '(null cons list)) |
|
|
(values t t)) |
|
|
((or (eq t1 'simple-array) (eq t1 'array)) |
|
|
(if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) |
|
|
(values t t) |
|
|
(values nil t))) |
|
|
(t (values nil ntp1)))) |
|
|
((eq t1 'list) (values nil ntp2)) |
|
|
((eq t1 'sequence) (values nil ntp2)) |
|
|
((eq t2 'atom) |
|
|
(cond ((member t1 '(cons list)) (values nil t)) |
|
|
(ntp1 (values t t)) |
|
|
(t (values nil nil)))) |
|
|
((eq t1 'atom) (values nil ntp2)) |
|
|
((eq t2 'symbol) |
|
|
(if (member t1 '(keyword boolean null)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'function) |
|
|
(if (member t1 '(compiled-function generic-function standard-generic-function)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'generic-function) |
|
|
(if (eq t1 'standard-generic-function) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'boolean) |
|
|
(if (eq t1 'null) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'standard-object) |
|
|
(if (member t1 '(class built-in-class structure-class standard-class |
|
|
method standard-method)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'class) |
|
|
(if (member t1 '(built-in-class structure-class standard-class )) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'condition) |
|
|
(if (and (symbolp t1) |
|
|
(or (equal (string t1) "ERROR") |
|
|
(member t1 '(serious-condition error type-error simple-type-error |
|
|
parse-error cell-error unbound-slot |
|
|
warning style-warning storage-condition |
|
|
simple-warning unbound-variable control-error |
|
|
program-error undefined-function |
|
|
package-error arithmetic-error |
|
|
division-by-zero simple-condition |
|
|
floating-point-invalid-operation |
|
|
floating-point-inexact |
|
|
floating-point-overflow |
|
|
floating-point-underflow |
|
|
file-error stream-error end-of-file |
|
|
print-not-readable |
|
|
reader-error)))) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'serious-condition) |
|
|
(if (and (symbolp t1) |
|
|
(or (equal (string t1) "ERROR") |
|
|
(member t1 '( error type-error simple-type-error |
|
|
parse-error cell-error unbound-slot |
|
|
storage-condition |
|
|
unbound-variable control-error |
|
|
program-error undefined-function |
|
|
package-error arithmetic-error |
|
|
division-by-zero simple-type-error |
|
|
floating-point-invalid-operation |
|
|
floating-point-inexact |
|
|
floating-point-overflow |
|
|
floating-point-underflow |
|
|
file-error stream-error end-of-file |
|
|
print-not-readable |
|
|
reader-error)))) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'type-error) |
|
|
(if (eq t1 'simple-type-error) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'parse-error) |
|
|
(if (eq t1 'reader-error) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'stream-error) |
|
|
(if (member t1 '(reader-error end-of-file)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((and (symbolp t2) (or (equal (string t2) "ERROR") (eq t2 'error))) |
|
|
(if (member t1 '(simple-type-error type-error |
|
|
parse-error cell-error unbound-slot |
|
|
unbound-variable control-error |
|
|
program-error undefined-function |
|
|
package-error arithmetic-error |
|
|
division-by-zero simple-type-error |
|
|
floating-point-invalid-operation |
|
|
floating-point-inexact |
|
|
floating-point-overflow |
|
|
floating-point-underflow |
|
|
file-error stream-error end-of-file print-not-readable |
|
|
reader-error )) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'stream) |
|
|
(if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream |
|
|
string-stream synonym-stream two-way-stream)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'pathname) |
|
|
(if (eq t1 'logical-pathname) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'method) |
|
|
(if (eq t1 'standard-method) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'simple-condition) |
|
|
(if (member t1 '(simple-type-error simple-warning)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'simple-condition) |
|
|
(if (member t1 '(simple-type-error simple-warning)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'cell-error) |
|
|
(if (member t1 '(unbound-slot unbound-variable undefined-function)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'warning) |
|
|
(if (member t1 '(style-warning simple-warning)) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'arithmetic-error) |
|
|
(if (member t1 '(division-by-zero |
|
|
floating-point-invalid-operation |
|
|
floating-point-inexact |
|
|
floating-point-overflow |
|
|
floating-point-underflow )) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t2 'keyword) |
|
|
(if (eq t1 'keyword) (values t t) (values nil ntp1))) |
|
|
((eq t2 'null) |
|
|
(if (eq t1 'null) (values t t) (values nil ntp1))) |
|
|
((eq t2 'number) |
|
|
(cond ((member t1 '(bignum integer ratio rational float real |
|
|
short-float single-float double-float long-float |
|
|
complex number)) |
|
|
(values t t)) |
|
|
(t (values nil ntp1)))) |
|
|
((eq t1 'number) (values nil ntp2)) |
|
|
((or (eq t2 'structure) (eq t2 'structure-object)) |
|
|
(if (and (symbolp t1) (or (eq t1 'structure) (get t1 'si::s-data))) |
|
|
(values t t) |
|
|
(values nil ntp1))) |
|
|
((eq t1 'structure) (values nil ntp2)) |
|
|
((and (symbolp t1) (setq tem (get t1 'si::s-data))) |
|
|
(let ((tem2 (and (symbolp t2) (get t2 'si::s-data)))) |
|
|
(cond (tem2 |
|
|
(do ((tp1 tem (s-data-includes tp1)) (tp2 tem2)) |
|
|
((null tp1)(values nil t)) |
|
|
(when (eq tp1 tp2) (return (values t t))))) |
|
|
(t (values nil ntp2))))) |
|
|
((eq t2 'real) |
|
|
(let ((r (and (member t1 '(fixnum integer bignum float short-float |
|
|
single-float double-float long-float |
|
|
real ratio |
|
|
rational))))) |
|
|
(values r r))) |
|
|
((and (symbolp t2) (get t2 'si::s-data)) (values nil ntp1)) |
|
|
(t |
|
|
(case t1 |
|
|
(bignum |
|
|
(case t2 |
|
|
(bignum (values t t)) |
|
|
((integer rational) |
|
|
(let ((r (sub-interval-p '(* *) i2))) |
|
|
(values r r))) |
|
|
(t (values nil ntp2)))) |
|
|
(ratio |
|
|
(case t2 |
|
|
(rational |
|
|
(let ((r (sub-interval-p '(* *) i2))) (values r r))) |
|
|
(t (values nil ntp2)))) |
|
|
(standard-char |
|
|
(if (member t2 '(base-char string-char character)) |
|
|
(values t t) |
|
|
(values nil ntp2))) |
|
|
(base-char |
|
|
(if (member t2 '(character string-char)) |
|
|
(values t t) |
|
|
(values nil ntp2))) |
|
|
(string-char |
|
|
(if (member t2 '(character base-char)) |
|
|
(values t t) |
|
|
(values nil ntp2))) |
|
|
(extended-char |
|
|
(if (eq t2 'character) |
|
|
(values t t) |
|
|
(values nil ntp2))) |
|
|
(character |
|
|
(if (member t2 '(string-char base-char)) |
|
|
(values t t) |
|
|
(values nil ntp2))) |
|
|
(integer |
|
|
(if (member t2 '(integer rational bignum)) |
|
|
(let ((r (sub-interval-p i1 i2))) (values r r)) |
|
|
(values nil ntp2))) |
|
|
(rational |
|
|
(if (eq t2 'rational) |
|
|
(let ((r (sub-interval-p i1 i2))) (values r r)) |
|
|
(values nil ntp2))) |
|
|
(float |
|
|
(if (eq t2 'float) |
|
|
(let ((r (sub-interval-p i1 i2))) (values r r)) |
|
|
(values nil ntp2))) |
|
|
((short-float) |
|
|
(if (member t2 '(short-float float)) |
|
|
(let ((r (sub-interval-p i1 i2))) (values r r)) |
|
|
(values nil ntp2))) |
|
|
((single-float double-float long-float) |
|
|
(if (member t2 '(single-float double-float long-float float)) |
|
|
(let ((r (sub-interval-p i1 i2))) (values r r)) |
|
|
(values nil ntp2))) |
|
|
(complex |
|
|
(if (eq t2 'complex) |
|
|
(osubtypep (or (car i1) t) (or (car i2) t)) |
|
|
(values nil ntp2))) |
|
|
((simple-array array) |
|
|
(cond ((or (eq t1 t2) (eq t2 'array)) |
|
|
(labels ((all-sym (a s &optional (b a) (c 0)) |
|
|
(cond ((null b) c) |
|
|
((eq (car b) s) (all-sym a s (cdr b) (1+ c))) |
|
|
(t a)))) |
|
|
(macrolet ((ty (x) `(or (car ,x) '*)) |
|
|
; (let ((tmp (gensym))) |
|
|
; `(or (not ,x) |
|
|
; (let ((,tmp (car ,x))) |
|
|
; (or (eq ,tmp '*) ,tmp))))) |
|
|
(di (x) (let ((tmp (gensym))) |
|
|
`(or (not (cdr ,x)) |
|
|
(let ((,tmp (cadr ,x))) |
|
|
(or (eq ,tmp '*) |
|
|
(and (integerp ,tmp) ,tmp) |
|
|
(all-sym ,tmp '*))))))) |
|
|
(let* ((at1 (ty i1)) |
|
|
(at2 (ty i2)) |
|
|
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
|
|
(unless (or (eq at2 '*) |
|
|
(eq (upgraded-array-element-type at1) (upgraded-array-element-type at2))) |
|
|
(return-from osubtypep (values nil t)))) |
|
|
(let ((ad1 (di i1)) |
|
|
(ad2 (di i2))) |
|
|
(when (eq ad2 t) |
|
|
(return-from osubtypep (values t t))) |
|
|
(when (eq ad1 t) |
|
|
(return-from osubtypep (values nil t))) |
|
|
(values (match-dimensions ad1 ad2) t))))) |
|
|
(t (values nil ntp2)))) |
|
|
(t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) |
|
|
|
|
|
(defun effective-range (tp i) |
|
|
(unless (member tp '(integer bignum)) |
|
|
(return-from effective-range i)) |
|
|
(let (r d) |
|
|
(dolist (j i (nreverse r)) |
|
|
(push (if (consp j) (if d (1- (car j)) (1+ (car j))) j) r) |
|
|
(setq d t)))) |
|
|
|
|
|
|
|
|
(defun sub-interval-p (i1 i2) |
|
|
(let (low1 high1 low2 high2) |
|
|
(if (endp i1) |
|
|
(setq low1 '* high1 '*) |
|
|
(if (endp (cdr i1)) |
|
|
(setq low1 (car i1) high1 '*) |
|
|
(setq low1 (car i1) high1 (cadr i1)))) |
|
|
(if (endp i2) |
|
|
(setq low2 '* high2 '*) |
|
|
(if (endp (cdr i2)) |
|
|
(setq low2 (car i2) high2 '*) |
|
|
(setq low2 (car i2) high2 (cadr i2)))) |
|
|
(cond ((eq low1 '*) |
|
|
(unless (eq low2 '*) |
|
|
(return-from sub-interval-p nil))) |
|
|
((eq low2 '*)) |
|
|
((consp low1) |
|
|
(if (consp low2) |
|
|
(when (< (car low1) (car low2)) |
|
|
(return-from sub-interval-p nil)) |
|
|
(when (< (car low1) low2) |
|
|
(return-from sub-interval-p nil)))) |
|
|
((if (consp low2) |
|
|
(when (<= low1 (car low2)) |
|
|
(return-from sub-interval-p nil)) |
|
|
(when (< low1 low2) |
|
|
(return-from sub-interval-p nil))))) |
|
|
(cond ((eq high1 '*) |
|
|
(unless (eq high2 '*) |
|
|
(return-from sub-interval-p nil))) |
|
|
((eq high2 '*)) |
|
|
((consp high1) |
|
|
(if (consp high2) |
|
|
(when (> (car high1) (car high2)) |
|
|
(return-from sub-interval-p nil)) |
|
|
(when (> (car high1) high2) |
|
|
(return-from sub-interval-p nil)))) |
|
|
((if (consp high2) |
|
|
(when (>= high1 (car high2)) |
|
|
(return-from sub-interval-p nil)) |
|
|
(when (> high1 high2) |
|
|
(return-from sub-interval-p nil))))) |
|
|
(return-from sub-interval-p t))) |
|
1184 |
|
|
|
(defun in-interval-p (x interval) |
|
|
(let (low high) |
|
|
(if (endp interval) |
|
|
(setq low '* high '*) |
|
|
(if (endp (cdr interval)) |
|
|
(setq low (car interval) high '*) |
|
|
(setq low (car interval) high (cadr interval)))) |
|
|
(cond ((eq low '*)) |
|
|
((consp low) |
|
|
(when (<= x (car low)) (return-from in-interval-p nil))) |
|
|
((when (< x low) (return-from in-interval-p nil)))) |
|
|
(cond ((eq high '*)) |
|
|
((consp high) |
|
|
(when (>= x (car high)) (return-from in-interval-p nil))) |
|
|
((when (> x high) (return-from in-interval-p nil)))) |
|
|
(return-from in-interval-p t))) |
|
1185 |
|
|
|
(defun match-dimensions (dim pat) |
|
|
(cond ((null dim) |
|
|
(null pat)) |
|
|
((integerp dim) |
|
|
(eql dim pat)) |
|
|
((integerp pat) |
|
|
(eql (length dim) pat)) |
|
|
(t |
|
|
(and (or (eq (car pat) '*) |
|
|
(eql (car dim) (car pat))) |
|
|
(match-dimensions (cdr dim) (cdr pat)))))) |
|
1186 |
|
|
|
;;; COERCE function. |
|
|
(defun coerce (object type) |
|
|
(when (typep object type) |
|
|
;; Just return as it is. |
|
|
(return-from coerce object)) |
|
|
(when (classp type) |
|
|
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
|
|
; (setq type (normalize-type type)) |
|
|
(if (atom type) (setq type (list type))) |
|
|
(case (car type) |
|
|
; ((and or) (coerce object (cadr type)));FIXME!!! |
|
|
(list |
|
|
(do ((l nil (cons (elt object i) l)) |
|
|
(i (1- (length object)) (1- i))) |
|
|
((< i 0) l))) |
|
|
((array simple-array vector simple-vector string simple-string) |
|
|
(unless (or (endp (cdr type)) |
|
|
(endp (cddr type)) |
|
|
(eq (caddr type) '*) |
|
|
(endp (cdr (caddr type)))) |
|
|
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
|
|
(do ((seq (make-sequence type (length object))) |
|
|
(i 0 (1+ i)) |
|
|
(l (length object))) |
|
|
((>= i l) seq) |
|
|
(setf (elt seq i) (elt object i)))) |
|
|
(character (character object)) |
|
|
(float (float object)) |
|
|
((short-float) (float object 0.0S0)) |
|
|
((single-float double-float long-float) (float object 0.0L0)) |
|
|
(complex |
|
|
(if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*)) |
|
|
(complex (realpart object) (imagpart object)) |
|
|
(complex (coerce (realpart object) (cadr type)) |
|
|
(coerce (imagpart object) (cadr type))))) |
|
|
(t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)))) |
|
1187 |
|
|
1188 |
;; set by unixport/init_kcl.lsp |
;; set by unixport/init_kcl.lsp |
1189 |
;; warn if a file was comopiled in another version |
;; warn if a file was comopiled in another version |