/[gcl]/gcl/lsp/gcl_predlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_predlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by camm, Sat Jul 23 08:52:34 2005 UTC revision 1.15 by camm, Tue Aug 9 00:44:47 2005 UTC
# Line 29  Line 29 
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))
# Line 66  Line 292 
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)))
# Line 144  Line 361 
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))
# Line 168  Line 371 
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))
# Line 187  Line 388 
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)
# Line 569  Line 461 
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)
# Line 604  Line 775 
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
# Line 648  Line 786 
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

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26