/[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.13 by camm, Wed Jun 29 21:20:09 2005 UTC revision 1.14 by camm, Sat Jul 23 08:52:34 2005 UTC
# Line 1  Line 1 
1    ;; -*-Lisp-*-
2  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
3    
4  ;; This file is part of GNU Common Lisp, herein referred to as GCL  ;; This file is part of GNU Common Lisp, herein referred to as GCL
# Line 24  Line 25 
25    
26  (in-package 'system)  (in-package 'system)
27    
28  (export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce lisp::upgraded-array-element-type) 'lisp)  (export '(lisp::upgraded-complex-part-type
29              lisp::deftype lisp::typep lisp::subtypep
30              lisp::coerce lisp::upgraded-array-element-type) 'lisp)
31    
32  (eval-when (compile)  (eval-when (compile)
33  (proclaim '(optimize (safety 2) (space 3)))  (proclaim '(optimize (safety 2) (space 3)))
# Line 157  Line 160 
160         (not (array-has-fill-pointer-p x))         (not (array-has-fill-pointer-p x))
161         (not (si:displaced-array-p x))))         (not (si:displaced-array-p x))))
162    
163    (deftype list () `(or cons nil))
164    (deftype sequence () `(or list vector))
165    (deftype character () `(or base-char extended-char))
166    (deftype string-char () `(or base-char extended-char))
167    (deftype stream () `(or broadcast-stream concatenated-stream echo-stream
168                            file-stream string-stream synonym-stream two-way-stream))
169    
170    (deftype bignum () `(and integer (not fixnum)))
171    (deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high)))
172    (deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high)))
173    (deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
174    (deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
175    (deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))
176    (deftype number () `(or real complex))
177    ;(deftype boolean () `(member t nil)) ;FIXME member types
178    (deftype atom () `(not cons))
179    (deftype function () `(or interpreted-function compiled-function))
180    (deftype symbol () `(or non-keyword-boolean-symbol null is-t keyword))
181    (deftype base-char () `(or standard-char non-standard-base-char))
182    ;(deftype t () `(or atom cons))
183    
184    (deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))
185    (deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))
186    (deftype short-float (&optional (low '*) (high '*)) `(short-float ,low ,high))
187    (deftype long-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
188    
189    (deftype array (&optional (et '*) (dims '*))
190      `(array ,et ,(if (integerp dims) (make-list dims :initial-element '*) dims)))
191    (deftype simple-array (&optional (et '*) (dims '*))
192      `(simple-array ,et ,(if (integerp dims) (make-list dims :initial-element '*)  dims)))
193    
194    (defun upgraded-complex-part-type (type &optional environment) (declare (ignore environment)) type)
195    
196    (deftype complex (&optional (ts 'real)) `(complex ,(if (eq ts '*) 'real ts)))
197    (deftype eql (x) `(member ,x))
198    
199    
200    (defconstant +singleton-types+ '(cons non-keyword-boolean-symbol is-t null keyword standard-char
201                                          non-standard-base-char extended-char
202                                          package
203                                          broadcast-stream concatenated-stream echo-stream file-stream string-stream
204                                          synonym-stream two-way-stream
205                                          pathname readtable hash-table random-state structure
206                                          interpreted-function compiled-function))
207    
208    (defvar *singleton-types* '#.(reverse (let ((i -1)) (mapcar (lambda (x) `(,x . ,(ash 1 (incf i)))) +singleton-types+))))
209    
210    (defmacro mbtp (x) `(and (consp ,x) (eq (car ,x) 'member)))
211    
212    (defun singleton-tp-from-int (x)
213      (let ((z (mapcar 'car (remove-if (lambda (z) (= 0 (logand x z))) *singleton-types* :key 'cdr))))
214        (if (cdr z)
215            `(or ,@z)
216          z)))
217    
218    (defun singleton-op (op x &optional y)
219      (let ((x (if (integerp x) x (or (cdr (assoc x *singleton-types*)) (if x -1 0))))
220            (y (if (integerp y) y (or (cdr (assoc y *singleton-types*)) (if y -1 0)))))
221        (case op
222              (and (logand x y))
223              (or (logior x y))
224              (not (lognot x)))))
225    
226    
227    ;(defstruct tp
228    ;  (nums (make-list 8) :type list)
229    ;  single
230    ;  array
231    ;  struct
232    ;  class)
233    
234    (defconstant +range-types+ `(integer ratio short-float long-float))
235    (defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short
236                                           fixnum short-float long-float t))
237    
238    (defmacro make-tp () `(list (make-list ,#.(* 2 (length +range-types+)))
239                                nil
240                                (make-list ,#.(length +array-types+))
241                                 nil nil))
242    (defmacro tp-nums (tp) `(first ,tp))
243    (defmacro tp-single (tp) `(second ,tp))
244    (defmacro tp-array (tp) `(third ,tp))
245    (defmacro tp-struct (tp) `(fourth ,tp))
246    (defmacro tp-class (tp) `(fifth ,tp))
247    
248    (defun class< (x y)
249      (cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x)))
250            ((and (consp y) (eq (car y) 'member)) nil)
251            ((let ((x (if (symbolp x) (find-class x nil) x))
252                   (y (if (symbolp y) (find-class y nil) y)))
253               (or (not x) (and y (member y (class-precedence-list x))))))))
254    
255    (defun struct< (x y)
256      (cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x)))
257            ((and (consp y) (eq (car y) 'member)) nil)
258            ((or (not x) (eq y t)))
259            ((let ((x (and (symbolp x) (get x 's-data)))
260                   (y (and (symbolp y) (get y 's-data))))
261               (and x y (do ((x x (s-data-includes x))) ((or (not x) (eq x y)) (eq x y))))))))
262    
263    
264    (defun op-from-inclusion (op ox oy < atm)
265      (let* ((cx (and (consp ox) (eq (car ox) 'not)))
266             (x (if cx (cadr ox) ox))
267             (cy (and (consp oy) (eq (car oy) 'not)))
268             (y (if cy (cadr oy) oy))
269             (<xy (funcall < x y))
270             (<yx (funcall < y x))
271             (opor (case op (or t) (and nil) (otherwise (error "Bad op~%")))))
272        (cond ((not (or cx cy))
273               (cond (<xy (if opor y x))
274                     (<yx (if opor x y))
275                     ((when opor (clean-or atm `(or ,x ,y))))))
276              ((and cx cy)
277               (cond (<xy `(not ,(if opor x y)))
278                     (<yx `(not ,(if opor y x)))
279                     ((if opor t (clean-and atm `(and (not ,x) (not ,y)))))))
280              (cx (op-from-inclusion op oy ox < atm))
281              ((cond ((and <xy <yx) opor)
282                     (<xy (when opor (clean-or atm `(or ,x (not ,y)))))
283                     (<yx (if opor t (clean-and atm `(and ,x (not ,y)))))
284                     ((if opor `(not ,y) x)))))))
285    
286    ;(defun compound (x)
287    ;  (cond ((atom x) nil)
288    ;       ((eq (car x) 'not) (compound (cadr x)))
289    ;       ((consp (car x)))
290    ;       ((member (car x) '(and or t nil)))))
291    ;      
292    ;(defmacro atomic-tp (x) `(not (compound ,x)))
293    
294    (defun classatm (x)
295      (cond ((atom x))
296            ((eq (car x) 'not) (classatm (cadr x)))
297            ((eq (car x) 'member))))
298    
299    (defun structatm (x) (classatm x))
300    (defun dimatm (x)
301      (cond ((atom x))
302            ((eq (car x) 'not) (dimatm (cadr x)))
303            ((integerp (car x)))
304            ((eq (car x) t))))
305    
306    (defun clean-or (atm lst)
307      (if (funcall atm lst) lst
308        (or
309         (car (member t lst))
310         (let ((nl (remove-if 'not (remove-duplicates (cdr lst) :test 'equal))))
311           (if (cdr nl) `(or ,@nl) (car nl))))))
312    
313    (defun clean-and (atm lst)
314      (if (funcall atm lst) lst
315        (unless (member nil lst)
316          (let ((nl (remove-if (lambda (z) (eq z t)) (remove-duplicates (cdr lst) :test 'equal))))
317            (if (cdr nl) `(and ,@nl) (or (car nl) t))))))
318    
319    (defun repl-op (op x y < atm)
320      (let ((z (inclusion-op op x y < atm)))
321        (if (funcall atm z) z y)))
322    
323    (defun clean-tp (op atm x &optional y)
324      (let ((cf (case op (or 'clean-or) (and 'clean-and) (otherwise (error "Bad op~%"))))
325            (x (if (funcall atm x) (list x) x))
326            (y (if (funcall atm y) (list y) y)))
327        (cond ((not (car y)) (funcall cf atm `(,op ,@x)))
328              ((eq (car y) op) (funcall cf  atm `(,op ,@x ,@(cdr y))))
329              ((member (car y) '(and not or)) `(,op ,@x ,y))
330              ((funcall cf atm  `(,op ,@x ,@y))))))
331        
332    (defun clean-not (atm lst)
333      (cond ((atom lst) lst)
334            ((and (eq (car lst) 'not) (consp (cadr lst)) (eq (caadr lst) 'not))
335             (clean-not atm (cadadr lst)))
336            ((eq (cadr lst) t) nil)
337            ((and (cdr lst) (not (cadr lst))))
338            (lst)))
339                                                
340    (defun inclusion-op (op x y < atm)
341      (cond ((and (not (funcall atm x)) (eq op (car x)))
342             (inclusion-op op (cadr x) (clean-tp op atm (cddr x) y) < atm))
343            ((and (not (funcall atm x)) (eq 'not (car x)))
344             (clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm))))
345            ((not (funcall atm x))
346             (clean-tp (if (eq op 'or) 'and 'or) atm (mapcar (lambda (w) (inclusion-op op w y < atm)) (cdr x))))
347            ((funcall atm y) (op-from-inclusion op x y < atm))
348            ((eq op (car y))
349             (let ((z (clean-tp op atm (if (some (lambda (z) (equal z (inclusion-op op x z < atm))) (cdr y))
350                                       (eq op 'and) x)
351                                (mapcar (lambda (z) (repl-op op x z < atm)) (cdr y)))))
352               (if (funcall atm z) z
353                 (let ((ny (clean-tp op atm (cddr z))))
354                   (if (and (equal x (cadr z)) (equal ny y))
355                       z
356                     (inclusion-op op (cadr z) ny < atm))))))
357            ((eq 'not (car y))
358             (clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm))))
359            ((clean-tp (if (eq op 'or) 'and 'or) atm  (mapcar (lambda (w) (inclusion-op op x w < atm)) (cdr y))))))
360    
361    ;       ((inclusion-op op y x <)))));
362    
363    (defun andf (&rest args)
364      (or (not args) (and (car args) (cadr args))))
365    
366    (defun dim< (x y)
367      (cond ((or (eq y t) (not x)))
368            ((or (eq x t) (not y)) nil)
369            ((integerp x) (if (integerp y) (= x y) (and (consp y) (= x (length y)) (every (lambda (z) (eq z t)) y))))
370            ((integerp y) (dim< x (make-list y :initial-element t)))
371            ((/= (length x) (length y)) nil)
372            ((every (lambda (z) (eq z t)) (mapcar 'dim< x y)))))
373    
374    (defun array-op (op x &optional y) ;(declare (ignore op x y)) nil)
375      (case op
376            (not (mapcar (lambda (z) (clean-not 'dimatm `(not ,z))) x))
377            (otherwise (mapcar (lambda (x y) (inclusion-op op x y 'dim< 'dimatm)) x y))))
378    
379    (defun tp-and (&rest xy)
380      (when xy
381        (let ((x (car xy)) (y (cadr xy)))
382          (when x
383            (setf (tp-nums x) (mapcar 'range-and (tp-nums x) (tp-nums y)))
384            (setf (tp-single x) (singleton-op 'and (tp-single x) (tp-single y)))
385            (setf (tp-array x) (array-op 'and (tp-array x) (tp-array y)))
386            (setf (tp-struct x) (inclusion-op 'and (tp-struct x) (tp-struct y) 'struct< 'structatm))
387            (setf (tp-class x) (inclusion-op 'and (tp-class x) (tp-class y) 'class< 'classatm)))
388          x)))
389    
390    (defun tp-or (&rest xy)
391      (when xy
392        (let ((x (car xy)) (y (cadr xy)))
393          (when x
394            (setf (tp-nums x) (mapcar 'range-or (tp-nums x) (tp-nums y)))
395            (setf (tp-single x) (singleton-op 'or (tp-single x) (tp-single y)))
396            (setf (tp-array x) (array-op 'or (tp-array x) (tp-array y)))
397            (setf (tp-struct x) (inclusion-op 'or (tp-struct x) (tp-struct y) 'struct< 'structatm))
398            (setf (tp-class x) (inclusion-op 'or (tp-class x) (tp-class y) 'class< 'classatm)))
399          x)))
400    
401    (defun tp-not (x)
402      (when x
403        (setf (tp-nums x) (mapcar 'range-not (tp-nums x)))
404        (setf (tp-single x) (singleton-op 'not (tp-single x)))
405        (setf (tp-array x) (array-op 'not (tp-array x)))
406        (setf (tp-struct x) (clean-not 'structatm `(not ,(tp-struct x))));FIXME
407        (setf (tp-class x) (clean-not 'classatm `(not ,(tp-class x)))))
408      x)
409    
410    (defun tp-load (type shift &aux tem)
411      (let ((tp (make-tp)))
412        (cond ((eq (car type) t) (tp-not tp))
413              ((setq tem (position (car type) +range-types+))
414               (setf (nth (+ shift tem) (tp-nums tp))
415                     (let ((z `((,(cadr type) . ,(caddr type)))))
416                       (number-range-fixup z (nth tem +range-types+)))))
417              ((member (car type) +singleton-types+)
418               (setf (tp-single tp) (car type)))
419              ((member (car type) '(array simple-array))
420               (let ((z (position (if (eq (cadr type) 'string-char) 'character (cadr type)) +array-types+)));FIXME
421                 (unless (or z (eq (cadr type) '*)) (error "Bad array type ~a~%" (cadr type)))
422                 (let* ((dim (caddr type))
423                        (dim (if (eq dim '*) t dim))
424                        (dim (if (listp dim) (mapcar (lambda (z) (or (eq '* z)  z)) dim) dim)))
425                   (if z
426                       (setf (nth z (tp-array tp)) dim)
427                     (setf (tp-array tp) (mapcar (lambda (z) (declare (ignore z)) dim) (tp-array tp)))))))
428              ((setq tem (or (and (symbolp (car type)) (find-class (car type) nil)) (when (classp (car type)) (car type))))
429               (setf (tp-class tp) tem))
430              ((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data)))
431    ;          (setf (tp-struct tp) tem))FIXME
432               (setf (tp-struct tp) (car type)))
433              ((eq (car type) 'member)
434               (dolist (l (cdr type))
435                 (cond ((setq tem (position-if (lambda (x) (typep l x)) +range-types+))
436                        (setf (nth tem (tp-nums tp))
437                              (range-or (let ((z `((,l . ,l))))
438                                          (number-range-fixup z (nth tem +range-types+)))
439                                        (nth tem (tp-nums tp)))))
440                       ((setq tem (position-if (lambda (x) (typep l x)) +singleton-types+))
441                        (setf (tp-single tp) (if (consp (tp-single tp)) `(,@(tp-single tp) ,l) `(member ,l))))
442                       ((setq tem (position-if (lambda (x) (typep l `(complex ,x))) +range-types+)) ;;FIXME
443                        (setf (nth (+ (length +range-types+) tem) (tp-nums tp))
444                              (range-or (let ((z `((,(realpart l) . ,(realpart l)))))
445                                          (number-range-fixup z (nth tem +range-types+)))
446                                        (range-or (let ((z `((,(imagpart l) . ,(imagpart l)))))
447                                                    (number-range-fixup z (nth tem +range-types+)))
448                                                  (nth (+ (length +range-types+) tem) (tp-nums tp)))))))))
449              ((car type) (setq tp (tp-not tp)))) ;(format t  "not processing type ~a~%" type)
450        tp))
451              
452    (defun reconstruct-type (tp)
453      (if (and (consp tp) (eq (car tp) 'cons) (cdr tp))
454          (let ((a (reconstruct-type (cadr tp)))
455                (d (reconstruct-type (caddr tp))))
456            (and a d `(cons ,(reconstruct-type (cadr tp)) ,(reconstruct-type (caddr tp)))))
457        (let* ((res (when (some 'identity (tp-nums tp))
458                    (remove-if
459                     'not
460                     (append
461                      (mapcan (lambda (x y)
462                                (mapcar (lambda (y)
463                                          (let ((y (car (number-range-fixup (list y) x))))
464                                            (when y `(,x ,(car y) ,(cdr y))))) y))
465                              +range-types+ (tp-nums tp))
466                      (mapcan (lambda (x y)
467                                (mapcar (lambda (y)
468                                          (let ((y (car (number-range-fixup (list y) x))))
469                                            (when y `(complex (,x ,(car y) ,(cdr y)))))) y))
470                              +range-types+ (nthcdr 4 (tp-nums tp)))))))
471             (res (if (some 'identity (tp-array tp))
472                    `(,@res ,@(remove-if
473                               'not
474                               (mapcan (lambda (x y) (mapcar (lambda (y) (when y `(array ,x ,y))) (if (atom y) (list y) y)))
475                                       +array-types+ (tp-array tp)))) res))
476             (res (if (tp-single tp)
477                      `(,@res ,@(remove-if
478                                 'not
479                                 (mapcar (lambda (z)
480                                           (when (/= 0 (logand (cdr z) (tp-single tp)))
481                                             (car z))) *singleton-types*))) res))
482             (res (if (tp-struct tp) `(,@res ,(tp-struct tp)) res))
483             (res (if (tp-class tp) `(,@res ,(tp-class tp)) res)))
484        (when res
485          (if (cdr res)
486              (clean-tp 'or 'null res)
487            (car res))))))
488    
489    
490    (defun resolve-type (type)
491    ;  (format t "norm~%")
492    ;  (setq type (time (normalize-type type t)))
493    ;  (format t "proc~%")
494    ;  (setq type (time (process-type type)))
495    ;  (format t "recon~%")
496    ;  (setq type (time (reconstruct-type type))))
497    ;  (let* ((type (time (normalize-type type t)))
498    ;        (type (time (process-type type)))
499    ;        (type (time (reconstruct-type type))))
500    ;    type))
501      (reconstruct-type (process-type (normalize-type type t))))
502        
503    
504    (defun tp-and1 (&rest xy)
505      (when xy
506        `(and ,@xy)))
507      
508    (defun tp-or1 (&rest xy)
509      (when xy
510        `(or ,@xy)))
511      
512    (defun tp-not1 (&rest xy)
513      (when xy
514        `(not ,@xy)))
515      
516    
517    
518    (defun process-type (type &optional (shift 0))
519      (cond ((not type) type)
520    ;       ((and (setq tem (normalize-type type)) (not (equal type tem)) (not (eq (car tem) 'satisfies)))
521    ;        (process-type tem shift))
522            ((eq (car type) 'and)  (reduce 'tp-and (mapcar (lambda (x) (process-type x shift)) (cdr type))))
523            ((eq (car type) 'or)   (reduce 'tp-or (mapcar (lambda (x) (process-type x shift)) (cdr type))))
524            ((eq (car type) 'not)  (tp-not (process-type (cadr type) shift)))
525            ((eq (car type) 'complex) (process-type (cadr type) 4))
526    ;       ((and (eq (car type) 'cons) (cdr type)) `(cons ,(process-type (cadr type)) ,(process-type (caddr type))))
527            ((tp-load type shift))))
528    
529    (deftype boolean () `(or null is-t))
530    (defun is-t-p (x) (eq x t));FIXME member types
531    
532    (defun non-keyword-boolean-symbol-p (x)
533      (and (symbolp x) (not (keywordp x)) (not (null x)) (not (is-t-p x))))
534    
535    (defun base-char-p (x)
536      (characterp x))
537    
538    (defun non-standard-base-char-p (x)
539      (and (base-char-p x) (not (standard-char-p x))))
540    
541    (defun extended-char-p (x) (declare (ignore x)) nil)
542    
543    (defun interpreted-function-p (x)
544      (and (functionp x) (not (compiled-function-p x))))
545    
546    
547  (do ((l '((null . null)  (do ((l '((null . null)
548            (symbol . symbolp)            (symbol . symbolp)
549            (keyword . keywordp)            (keyword . keywordp)
550              (is-t . is-t-p)
551              (non-keyword-boolean-symbol . non-keyword-boolean-symbol-p)
552              (standard-char . standard-char-p)
553              (base-char . base-char-p)
554              (extended-char . extended-char-p)
555              (string-char . string-char-p);;FIXME
556              (interpreted-function . interpreted-function-p)
557            (atom . atom)            (atom . atom)
558            (cons . consp)            (cons . consp)
559            (list . listp)            (list . listp)
# Line 183  Line 576 
576          (cdr l)))          (cdr l)))
577      ((endp l))      ((endp l))
578    (si:putprop (caar l) (cdar l) 'type-predicate)    (si:putprop (caar l) (cdar l) 'type-predicate)
579    (si:putprop (cdar l) (caar l) 'predicate-type))    (when (symbolp (cdar l)) (si:putprop (cdar l) (caar l) 'predicate-type)))
580    
581    
582    (defun classp (object) (declare (ignore object)) nil)
583    (defun class-precedence-list (object) (declare (ignore object)) nil)
584    (defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil)
585    
586    (defmacro range-num (x) `(if (atom ,x) ,x (car ,x)))
587    
588    (defun elgt (x y)
589      (cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil)
590            ((and (numberp (car x)) (numberp (cdr y))) (> (car x) (cdr y)))
591            ((>= (range-num (car x)) (range-num (cdr y))))))
592    
593    (defun elin (x y op)
594      (cond ((eq x '*) y)
595            ((eq y '*) x)
596            ((= (range-num x) (range-num y)) (if (atom x) y x))
597            ((funcall op (range-num x) (range-num y)) x)
598            (y)))
599    
600    (defun elout (x y op)
601      (cond ((eq x '*) x)
602            ((eq y '*) y)
603            ((= (range-num x) (range-num y)) (if (atom x) x y))
604            ((funcall op (range-num x) (range-num y)) x)
605            (y)))
606    
607    (defun range-and (x y &optional res)
608      (cond ((or (not x) (not y)) (nreverse res));(if (and (not x) (not y)) res (cons (car (or x y)) res))))
609            ((elgt (car y) (car x)) (range-and (cdr x) y res))
610            ((elgt (car x) (car y)) (range-and x (cdr y) res))
611            ((let ((z (elin (cdar y) (cdar x) '<)))
612               (range-and (if (equal z (cdar x)) (cdr x) x) (if (equal z (cdar y)) (cdr y) y)
613                        (cons (cons (elin (caar x) (caar y) '>) z) res))))))
614    
615    (defun range-or (x y &optional res)
616      (cond ((and (not x) (not y)) (nreverse res))
617            ((not x) (range-or x (cdr y) (cons (car y) res)))
618            ((not y) (range-or (cdr x) y (cons (car x) res)))
619            ((elgt (car y) (car x)) (range-or (cdr x) y (cons (car x) res)))
620            ((elgt (car x) (car y)) (range-or x (cdr y) (cons (car y) res)))
621            ((and (equal (elout (caar x) (caar y) '<) (caar x))
622                  (equal (elout (cdar y) (cdar x) '>) (cdar x))) (range-or x (cdr y) res))
623            ((and (equal (elout (caar x) (caar y) '<) (caar y))
624                  (equal (elout (cdar y) (cdar x) '>) (cdar y))) (range-or (cdr x) y res))
625            ((range-or (cdr x) (cdr y);(if (equal (caar x) z) (cdr x) x) (if (equal (caar y) z) (cdr y) y)
626                        (cons (cons (elout (caar x) (caar y) '<) (elout (cdar y) (cdar x) '>)) res)))))
627    
628    (defmacro elcomp (x) `(cond ((eq ,x '*) ,x) ((atom ,x) (list ,x)) ((car ,x))))
629    
630    (defun range-not (x &optional res (last '* lastp))
631      (cond ((not x) (nreverse (if (and lastp (eq last '*)) res (cons (cons (elcomp last) '*) res))))
632            ((range-not (cdr x) (if (eq (caar x) last) res (cons (cons (elcomp last) (elcomp (caar x))) res)) (cdar x)))))
633    ;                   (let* ((el (elcomp last))
634    ;                          (ex (elcomp (caar x)))
635    ;                          (il (if (atom el) el (car el)))
636    ;                          (ix (if (atom ex) ex (car ex))))
637    ;                     (if (and (not (eq il '*)) (not (eq ix '*)) (= il ix) (or (listp el) (listp ex)))
638    ;                         res
639    ;                       (cons (cons el ex) res))) (cdar x)))))
640    
641    (defun imod (x p)
642      (if (eq x '*) x
643        (let* ((e (atom x))
644               (x (if e x (car x)))
645               (cx (if (= p 1) (ceiling x) (floor x))))
646          (cond ((/= cx x) cx)
647                (e cx)
648                ((+ cx p))))))
649      
650    (defun integer-range-fixup (x &optional res)
651      (cond ((not x) (remove-if (lambda (x) (and (realp (car x)) (realp (cdr x)) (> (car x) (cdr x)))) (nreverse res)))
652            ((integer-range-fixup (cdr x)
653                                  (cons (cons (imod (caar x) 1) (imod (cdar x) -1)) res)))))
654    
655    (defun number-range-fixup (x tp)
656      (if (eq tp 'integer)
657          (integer-range-fixup x)
658        (remove-if (lambda (x) (let ((a (car x)) (d (cdr x)))
659                                 (let ((na (if (atom a) a (car a))) (nd (if (atom d) d (car d))))
660                                   (and (not (eq na '*)) (not (eq nd '*))
661                                        (= na nd)
662                                        (or (listp a) (listp d)))))) x)))
663    
664    (defconstant +real-type-alist+ '((integer)
665                                     (ratio)
666                                     (short-float)
667                                     (long-float)
668                                     (rational integer ratio)
669                                     (single-float long-float)
670                                     (double-float long-float)
671                                     (float long-float short-float)
672                                     (real rational float)))
673    
674    (defconstant +numeric-logic-alist+ '((and . range-and) (or . range-or)))
675    
676    ;;coerce nums t prope type
677    ;; sort non-reals
678    ;; comples
679    (defun do-real-ranges (type &aux tem)
680      (cond ((assoc type +real-type-alist+) (do-real-ranges `(,type * *)))
681            ((atom type) nil)
682            ((setq tem (cdr (assoc (car type) +numeric-logic-alist+) ))
683             (reduce (lambda (x y) (mapcar tem x y)) (mapcar 'do-real-ranges (cdr type))))
684            ((eq (car type) 'not)
685             (mapcar 'range-not (do-real-ranges (cadr type))))
686            ((eq (car type) 'member)
687             (do-real-ranges
688              `(or ,@(mapcar (lambda (x)
689                               (let ((tt (car (assoc x +real-type-alist+ :test 'typep))))
690                                 (when tt `(,tt ,x ,x)))) (cdr type)))))
691            ((setq tem (cdr (assoc (car type) +real-type-alist+)))
692             (do-real-ranges `(or ,@(mapcar (lambda (x) `(,x ,@(cdr type))) tem))))
693            ((setq tem (position (car type) +real-type-alist+ :key 'car))
694             (append (make-list tem) (list (list (cons (or (cadr type) '*) (or (caddr type) '*)))) (make-list (- 3 tem))))))
695    
696    (defun exnr (type)
697      `(or ,@(mapcar (lambda (x y) (when y `(,(car x) ,@y))) +real-type-alist+ (do-real-ranges type))))
698    
699    (defun type-null (type)
700      (equal type `(or nil nil nil nil)))
701    
702    (defun subtypep (t1 t2 &optional env)
703      (declare (ignore env))
704      (let ((r (not (resolve-type `(and ,t1 (not ,t2))))))
705        (values r t)))
706    
707    (defun *typep (object type)
708      (or (pcl-complete-redirect '*typep object type)
709          (pcl-redirect '*typep object type)))
710    (defun *subtypep (type1 type2)
711      (let ((l (multiple-value-list (pcl-complete-redirect '*subtypep type1 type2))))
712        (if (cdr l)
713            (values (car l) (cdr l)))
714        (pcl-redirect '*subtypep type1 type2)))
715    
 (defun class-of (object)  
   (declare (ignore object))  
   nil)  
 (defun classp (object)  
   (declare (ignore object))  
   nil)  
 (defun class-precedence-list (object)  
   (declare (ignore object))  
   nil)  
 (defun find-class (object &optional errorp environment)  
   (declare (ignore object errorp environment))  
   nil)  
 ;(defun find-class-no-error (object)  
 ;  (declare (ignore object))  
 ;  nil)  
716    
717  ;;; TYPEP predicate.  ;;; TYPEP predicate.
718  ;;; FIXME --optimize with most likely cases first  ;;; FIXME --optimize with most likely cases first
719  (defun typep (object type &optional env &aux tp i tem)  (defun typep (object type &optional env &aux tp i tem)
720    (declare (ignore env))    (declare (ignore env))
   (when (classp type)  
     (return-from typep (if (member type (class-precedence-list (funcall 'class-of object))) t nil)))  
721    (if (atom type)    (if (atom type)
722        (setq tp type i nil)        (setq tp type i nil)
723        (setq tp (car type) i (cdr type)))        (setq tp (car type) i (cdr type)))
# Line 215  Line 725 
725    (let ((f (and (not i) (get tp 'type-predicate))))    (let ((f (and (not i) (get tp 'type-predicate))))
726      (when f (return-from typep (funcall f object))))      (when f (return-from typep (funcall f object))))
727    (case tp    (case tp
728        (cons (and (consp object) (typep (car object) (car i)) (typep (cdr object) (cadr i))))
729      (member (member object i))      (member (member object i))
730      (not (not (typep object (car i))))      (not (not (typep object (car i))))
731      (or      (or
# Line 227  Line 738 
738         (unless (typep object (car l)) (return nil))))         (unless (typep object (car l)) (return nil))))
739      (satisfies (funcall (car i) object))      (satisfies (funcall (car i) object))
740      ((t) t)      ((t) t)
741      ((nil) nil)      ((nil) (not object))
742      (boolean (or (eq object 't) (eq object 'nil)))      (boolean (or (eq object 't) (eq object 'nil)))
743      (fixnum (eq (type-of object) 'fixnum))      (fixnum (eq (type-of object) 'fixnum))
744      (bignum (eq (type-of object) 'bignum))      (bignum (eq (type-of object) 'bignum))
# Line 250  Line 761 
761       (and (eq (type-of object) 'long-float) (in-interval-p object i)))       (and (eq (type-of object) 'long-float) (in-interval-p object i)))
762      (complex      (complex
763       (and (complexp object)       (and (complexp object)
764              
765      (or (null i)      (or (null i)
766         (and   (typep (realpart object) (car i))         (and   (typep (realpart object) (car i))
767              ;;wfs--should only have to check one.              ;;wfs--should only have to check one.
# Line 318  Line 830 
830             ))))             ))))
831    
832    
833    (defun normalize-type (type &optional ar &aux tem)
834      (cond ((atom type) (normalize-type (list type) ar))
835            ((and (eq (car type) 'satisfies) (setq tem (get (cadr type) 'predicate-type)))
836             (normalize-type tem ar))
837            ((let* ((dt (and (symbolp (car type)) (get (car type) 'deftype-definition)))
838                    (nt (and dt (apply dt (cdr type)))))
839               (when (and nt (not (equal type nt)) (not (and (eq (car nt) 'satisfies) (find-class (car type) nil))))
840                 (normalize-type nt ar))))
841            ((and ar (member (car type) '(array simple-array)))
842             `(,(car type) ,(upgraded-array-element-type (cadr type)) ,(caddr type)))
843            ((eq (car type) 'complex)
844             `(complex ,(normalize-type (cadr type) ar)))
845            ((and (eq (car type) 'cons) (cdr type))
846             (let* ((a (normalize-type (cadr type) ar))
847                    (ai (if (cdr a) a (car a)))
848                    (d (normalize-type (caddr type) ar))
849                    (di (if (cdr d) d (car d))))
850               (and ai di `(cons ,a ,d))))
851            ((member (car type) '(and or not))
852             (let ((z `(,(car type))))
853               (dolist (l (mapcar (lambda (z) (normalize-type z ar)) (cdr type)))
854                 (if (and (eq (car l) (car type)) (not (eq (car type) 'not)))
855                     (dolist (w (cdr l)) (push w z))
856                   (push l z)))
857               (if (cdr z)
858                   (nreverse z)
859                 (case (car z) (and '(t)) (or '(nil)) (not (error "Bad type~%"))))))
860            (type)))
861    
862  ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.  ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
863  ;;; The result is always a list.  ;;; The result is always a list.
864  (defun normalize-type (type &aux tp i )  ;(defun normalize-type (type &aux tp i )
865    ;; Loops until the car of type has no DEFTYPE definition.    ;; Loops until the car of type has no DEFTYPE definition.
866    (when (and (consp type) (eq (car type) 'satisfies))  ;  (when (and (consp type) (eq (car type) 'satisfies))
867      (when (setq tp (get (cadr type) 'predicate-type))  ;    (when (setq tp (get (cadr type) 'predicate-type))
868        (setq type tp)))  ;      (setq type tp)))
869    (loop  ;  (loop
870      (if (atom type)  ;    (if (atom type)
871          (setq tp type i nil)  ;        (setq tp type i nil)
872          (setq tp (car type) i (cdr type)))  ;        (setq tp (car type) i (cdr type)))
873      (if (get tp 'deftype-definition)  ;    (let* ((dt (get tp 'deftype-definition))
874          (setq type (apply (get tp 'deftype-definition) i))  ;          (nt (and dt (apply dt i))))
875          (return-from normalize-type (if (atom type) (list type) type)))))  ;      (if (and nt (not (equal type nt)))
876    ;         (setq type nt)
877    ;        (return-from normalize-type (if (atom type) (list type) type))))))
878    
879    
880  ;;; KNOWN-TYPE-P answers if the given type is a known base type.  ;;; KNOWN-TYPE-P answers if the given type is a known base type.
# Line 341  Line 884 
884  (defun known-type-p (type)  (defun known-type-p (type)
885    (when (consp type) (setq type (car type)))    (when (consp type) (setq type (car type)))
886    (if (and (symbolp type)    (if (and (symbolp type)
887             (or (equal (string type) "ERROR")) ;FIXME error symbol             (or (equal (string type) "ERROR") ;FIXME error symbol
888             (member type                 (member type
889                    '(t nil boolean null symbol keyword atom cons list sequence                         '(t nil boolean null symbol keyword atom cons list sequence
890                        non-negative-char negative-char signed-char unsigned-char                             non-negative-char negative-char signed-char unsigned-char
891                        non-negative-short negative-short signed-short unsigned-short                             non-negative-short negative-short signed-short unsigned-short
892                        non-negative-fixnum negative-fixnum                             non-negative-fixnum negative-fixnum
893                        number integer bignum rational ratio float method-combination                             number integer bignum rational ratio float method-combination
894                        short-float single-float double-float long-float complex                             short-float single-float double-float long-float complex
895                        character standard-char string-char real                             character standard-char string-char real
896                        package stream pathname readtable hash-table random-state                             package stream pathname readtable hash-table random-state
897                        structure array simple-array function compiled-function                             structure array simple-array function compiled-function
898                        arithmetic-error base-char base-string broadcast-stream                             arithmetic-error base-char base-string broadcast-stream
899                        built-in-class cell-error class concatenated-stream condition                             built-in-class cell-error class concatenated-stream condition
900                        control-error division-by-zero echo-stream end-of-file error                             control-error division-by-zero echo-stream end-of-file error
901                        extended-char file-error file-stream floating-point-inexact                             extended-char file-error file-stream floating-point-inexact
902                        floating-point-invalid-operation floating-point-overflow                             floating-point-invalid-operation floating-point-overflow
903                        floating-point-underflow generic-function logical-pathname method                             floating-point-underflow generic-function logical-pathname method
904                        package-error parse-error print-not-readable program-error                             package-error parse-error print-not-readable program-error
905                        reader-error serious-condition simple-base-string simple-condition                             reader-error serious-condition simple-base-string simple-condition
906                        simple-type-error simple-warning standard-class                             simple-type-error simple-warning standard-class
907                        standard-generic-function standard-method standard-object                             standard-generic-function standard-method standard-object
908                        storage-condition stream-error string-stream structure-class                             storage-condition stream-error string-stream structure-class
909                        style-warning synonym-stream two-way-stream structure-object                             style-warning synonym-stream two-way-stream structure-object
910                        type-error unbound-slot unbound-variable undefined-function                             type-error unbound-slot unbound-variable undefined-function
911                        warning ))                             warning ))
912             (get type 's-data))                 (get type 's-data)
913                   (find-class (implicit-symbol type nil) nil)))
914        t        t
915        nil))        nil))
916    
# Line 379  Line 923 
923          ((let ((a (car a))) (or (eq a '*) (eq a t)))          ((let ((a (car a))) (or (eq a '*) (eq a t)))
924           (implicit-symbol (cdr a) b))))           (implicit-symbol (cdr a) b))))
925    
926    ;(defun implicit-symbol (a b)
927    ;  (cond ((atom a)  (when (symbolp a) a))
928    ;       ((subsetp (cdr a) '(t *)) (car a))))
929    
930  (defun upgraded-array-element-type (type &optional environment)  (defun upgraded-array-element-type (type &optional environment)
931    (declare (ignore environment))    (declare (ignore environment))
932    (best-array-element-type type))    (best-array-element-type type))
933    
934    (defun type-null (type)
935      (cond ((atom type) (not type))
936            ((eq (car type) 'and)
937             (every (lambda (x)
938                      (or (and (consp x) (member (car x) '(and or member not)))
939                          (every (lambda (y)
940                                    (or (and (consp y) (member (car y) '(and or member not)))
941                                        (subtypep x `(not ,y)))))))))))
942    
943    
944  ;;; SUBTYPEP predicate.  ;;; SUBTYPEP predicate.
945  (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)  (defun osubtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
946    (declare (ignore env))    (declare (ignore env))
947    (let* ((c1 (classp type1)) (c2 (classp type2))    (let* ((t1 (or (find-class (implicit-symbol type1 nil) nil) (when (classp type1) type1)))
948          (t1 (if c1 type1 (let ((nt (implicit-symbol type1 nil))) (and nt (find-class nt nil)))))           (t2 (or (find-class (implicit-symbol type2 nil) nil) (when (classp type2) type2))))
         (t2 (if c2 type2 (let ((nt (implicit-symbol type2 nil))) (and nt (find-class nt nil))))))  
949      (when (and t1 t2)      (when (and t1 t2)
950        (return-from subtypep        (return-from osubtypep
951                     (if (member t2 (class-precedence-list t1))                     (if (member t2 (class-precedence-list t1))
952                         (values t t) (values nil t))))                         (values t t) (values nil t)))))
953      (when (or c1 c2)  ;    (when (or t1 t2)
954        (return-from subtypep (values nil t))))  ;      (return-from osubtypep (values nil nil))))
955    (setq t1 (normalize-type type1))    (setq t1 (normalize-type type1))
956    (setq type1 (if (eq (car t1) 'satisfies) (list type1) t1))    (setq type1 (if (eq (car t1) 'satisfies) (list type1) t1))
957    (setq t2 (normalize-type type2))    (setq t2 (normalize-type type2))
# Line 405  Line 962 
962    (setq i1 (effective-range t1 (cdr type1)) i2 (effective-range t2 (cdr type2)))    (setq i1 (effective-range t1 (cdr type1)) i2 (effective-range t2 (cdr type2)))
963    (cond ((eq t1 'member)    (cond ((eq t1 'member)
964           (dolist (e i1)           (dolist (e i1)
965             (unless (typep e type2) (return-from subtypep (values nil t))))             (unless (typep e type2) (return-from osubtypep (values nil t))))
966           (return-from subtypep (values t t)))           (return-from osubtypep (values t t)))
967          ((eq t1 'or)          ((eq t1 'or)
968           (dolist (tt i1)           (dolist (tt i1)
969             (multiple-value-bind (tv flag) (subtypep tt (if i2 type2 t2))             (multiple-value-bind (tv flag) (osubtypep tt (if i2 type2 t2))
970               (unless tv (return-from subtypep (values tv flag)))))               (unless tv (return-from osubtypep (values tv flag)))))
971           (return-from subtypep (values t t)))           (return-from osubtypep (values t t)))
972          ((eq t1 'and)          ((eq t1 'and)
973           (dolist (tt i1)           (let* ((i1 (remove-duplicates i1 :test 'equal))
974             (let ((tv (subtypep tt (if i2 type2 t2))))                  (i1 (if (not (cdr i1)) i1
975               (when tv (return-from subtypep (values t t)))))                        (intersection i1 i1 :test
976           (return-from subtypep (values nil nil)))                                   (lambda (x y) (and (not (equal x y))
977                                                        (let ((r (multiple-value-list (osubtypep x y)))
978                                                              (s (multiple-value-list (osubtypep y x))))
979                                                          (or  (car r) (not (cadr r))
980                                                               (car s) (not (cadr s))))))))))
981               (unless i1 (return-from osubtypep (values (if (if i2 type2 t2) nil t) t)))
982               (dolist (tt i1)
983                 (let ((tv (osubtypep tt (if i2 type2 t2))))
984                   (when tv (return-from osubtypep (values t t))))));;FIXME t2 nil
985             (return-from osubtypep (values nil (and (not t2) (some 'known-type-p i1)))))
986          ((eq t1 'not)          ((eq t1 'not)
987           ;;           ;;
988           (return-from subtypep           (return-from osubtypep
989                        (if (eq t2 'not)                        (if (eq t2 'not)
990                            (subtypep (car i2) (car i1))                            (osubtypep (car i2) (car i1))
991                          (subtypep t `(or ,type2 ,(car i1)))))))                          (let ((r (osubtypep t `(or ,(if i2 type2 t2) ,(car i1)))))
992                              (values r (or r (osubtypep type1 `(not ,(if i2 type2 t2))))))))))
993    (cond ((eq t2 'member)    (cond ((eq t2 'member)
994           (return-from subtypep (values nil nil)))           (return-from osubtypep (values nil nil)))
995          ((eq t2 'or)          ((eq t2 'or)
996           (dolist (tt i2)           (dolist (tt i2)
997             (let ((tv (subtypep (if i1 type1 t1) tt)))             (let ((tv (osubtypep (if i1 type1 t1) tt)))
998               (when tv (return-from subtypep (values t t)))))               (when tv (return-from osubtypep (values t t)))))
999           (return-from subtypep (values nil nil)))           (return-from osubtypep (values nil (if (eq t1 t) t nil))))
1000          ((eq t2 'and)          ((eq t2 'and)
1001           (dolist (tt i2)           (dolist (tt i2)
1002             (multiple-value-bind (tv flag) (subtypep (if i1 type1 t1) tt)             (multiple-value-bind (tv flag) (osubtypep (if i1 type1 t1) tt)
1003               (unless tv (return-from subtypep (values tv flag)))))               (unless tv (return-from osubtypep (values tv flag)))))
1004           (return-from subtypep (values t t)))           (return-from osubtypep (values t t)))
1005          ((eq t2 'not)          ((eq t2 'not)
1006           (return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil))))           (return-from osubtypep (let ((r (osubtypep `(and ,(if i1 type1 t1) ,(car i2)) nil)))
1007                                     (values r (or r (osubtypep (if i1 type1 t1) (car i2))))))))
1008                    
1009    (when (equal type1 type2)    (when (equal type1 type2)
1010      (return-from subtypep (values t t)))      (return-from osubtypep (values t t)))
1011    (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2))    (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2))
1012    (cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)    (cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t))
              (and (eq t1 'cons) (or (and i1 (not (car i1))) (and (cdr i1) (not (cadr i1))))))  
          (values t t))  
1013          ((eq t2 'nil) (values (eq t1 'extended-char) ntp1))          ((eq t2 'nil) (values (eq t1 'extended-char) ntp1))
1014          ((eq t1 't) (values nil ntp2))          ((eq t1 't) (values nil ntp2))
1015          ((eq t1 'common) (values nil ntp2))          ((eq t1 'common) (values nil ntp2))
# Line 455  Line 1021 
1021                                      (cond ((eq ,tmp '*) t)                                      (cond ((eq ,tmp '*) t)
1022                                            ((null ,tmp) t)                                            ((null ,tmp) t)
1023                                            (t ,tmp))))))                                            (t ,tmp))))))
1024                    (return-from subtypep (values (and (subtypep (ct car i1) (ct car i2))                    (return-from osubtypep (values (and (osubtypep (ct car i1) (ct car i2))
1025                                                       (subtypep (ct cadr i1) (ct cadr i2))) t))))                                                       (osubtypep (ct cadr i1) (ct cadr i2))) t))))
1026                 (t                 (t
1027                  (values nil ntp1))))                  (values nil ntp1))))
1028          ((eq t2 'list)          ((eq t2 'list)
# Line 628  Line 1194 
1194                         (when (eq tp1 tp2) (return (values t t)))))                         (when (eq tp1 tp2) (return (values t t)))))
1195                   (t (values nil ntp2)))))                   (t (values nil ntp2)))))
1196          ((eq t2 'real)          ((eq t2 'real)
1197           (cond ((and           (let ((r (and (member t1 '(fixnum integer bignum float short-float
1198                   (member t1 '(fixnum integer bignum float short-float                                             single-float double-float long-float
1199                                       single-float double-float long-float                                             real ratio
1200                                       real ratio                                             rational)))))
1201                                       rational))             (values r r)))
                  (sub-interval-p i1 i2))  
                 (values t t))  
                (t (values nil ntp1))))  
1202          ((and (symbolp t2) (get t2 'si::s-data)) (values nil ntp1))          ((and (symbolp t2) (get t2 'si::s-data)) (values nil ntp1))
1203          (t          (t
1204           (case t1           (case t1
# Line 643  Line 1206 
1206              (case t2              (case t2
1207                (bignum (values t t))                (bignum (values t t))
1208                ((integer rational)                ((integer rational)
1209                 (if (sub-interval-p '(* *) i2)                 (let ((r (sub-interval-p '(* *) i2)))
1210                     (values t t)                     (values r r)))
                    (values nil t)))  
1211                (t (values nil ntp2))))                (t (values nil ntp2))))
1212             (ratio             (ratio
1213              (case t2              (case t2
1214                (rational                (rational
1215                 (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))                 (let ((r (sub-interval-p '(* *) i2))) (values r r)))
1216                (t (values nil ntp2))))                (t (values nil ntp2))))
1217             (standard-char             (standard-char
1218              (if (member t2 '(base-char string-char character))              (if (member t2 '(base-char string-char character))
# Line 674  Line 1236 
1236                  (values nil ntp2)))                  (values nil ntp2)))
1237             (integer             (integer
1238              (if (member t2 '(integer rational bignum))              (if (member t2 '(integer rational bignum))
1239                  (values (sub-interval-p i1 i2) t)                  (let ((r (sub-interval-p i1 i2))) (values r r))
1240                  (values nil ntp2)))                  (values nil ntp2)))
1241             (rational             (rational
1242              (if (eq t2 'rational)              (if (eq t2 'rational)
1243                  (values (sub-interval-p i1 i2) t)                  (let ((r (sub-interval-p i1 i2))) (values r r))
1244                  (values nil ntp2)))                  (values nil ntp2)))
1245             (float             (float
1246              (if (eq t2 'float)              (if (eq t2 'float)
1247                  (values (sub-interval-p i1 i2) t)                  (let ((r (sub-interval-p i1 i2))) (values r r))
1248                  (values nil ntp2)))                  (values nil ntp2)))
1249             ((short-float)             ((short-float)
1250              (if (member t2 '(short-float float))              (if (member t2 '(short-float float))
1251                  (values (sub-interval-p i1 i2) t)                  (let ((r (sub-interval-p i1 i2))) (values r r))
1252                  (values nil ntp2)))                  (values nil ntp2)))
1253             ((single-float double-float long-float)             ((single-float double-float long-float)
1254              (if (member t2 '(single-float double-float long-float float))              (if (member t2 '(single-float double-float long-float float))
1255                  (values (sub-interval-p i1 i2) t)                  (let ((r (sub-interval-p i1 i2))) (values r r))
1256                  (values nil ntp2)))                (values nil ntp2)))
1257             (complex             (complex
1258              (if (eq t2 'complex)              (if (eq t2 'complex)
1259                  (subtypep (or (car i1) t) (or (car i2) t))                  (osubtypep (or (car i1) t) (or (car i2) t))
1260                  (values nil ntp2)))                  (values nil ntp2)))
1261             ((simple-array array)             ((simple-array array)
1262              (cond ((or (eq t1 t2) (eq t2 'array))              (cond ((or (eq t1 t2) (eq t2 'array))
# Line 702  Line 1264 
1264                                       (cond ((null b) c)                                       (cond ((null b) c)
1265                                             ((eq (car b) s) (all-sym a s (cdr b) (1+ c)))                                             ((eq (car b) s) (all-sym a s (cdr b) (1+ c)))
1266                                             (t a))))                                             (t a))))
1267                       (macrolet ((ty (x) (let ((tmp (gensym)))                       (macrolet ((ty (x) `(or (car ,x) '*))
1268                                            `(or (not ,x)  ;                               (let ((tmp (gensym)))
1269                                                 (let ((,tmp (car ,x)))  ;                                         `(or (not ,x)
1270                                                   (or (eq ,tmp '*) ,tmp)))))  ;                                              (let ((,tmp (car ,x)))
1271    ;                                                (or (eq ,tmp '*) ,tmp)))))
1272                                  (di (x) (let ((tmp (gensym)))                                  (di (x) (let ((tmp (gensym)))
1273                                            `(or (not (cdr ,x))                                            `(or (not (cdr ,x))
1274                                                 (let ((,tmp (cadr ,x)))                                                 (let ((,tmp (cadr ,x)))
# Line 715  Line 1278 
1278                         (let* ((at1 (ty i1))                         (let* ((at1 (ty i1))
1279                                (at2 (ty i2))                                (at2 (ty i2))
1280                                (at2 (or (and (eq at2 'string-char) 'character) at2)))                                (at2 (or (and (eq at2 'string-char) 'character) at2)))
1281                           (unless (eq (upgraded-array-element-type at1) (upgraded-array-element-type at2))                           (unless (or (eq at2 '*)
1282                             (return-from subtypep (values nil t))))                                       (eq (upgraded-array-element-type at1) (upgraded-array-element-type at2)))
1283                               (return-from osubtypep (values nil t))))
1284                         (let ((ad1 (di i1))                         (let ((ad1 (di i1))
1285                               (ad2 (di i2)))                               (ad2 (di i2)))
1286                           (when (eq ad2 t)                           (when (eq ad2 t)
1287                             (return-from subtypep (values t t)))                             (return-from osubtypep (values t t)))
1288                           (when (eq ad1 t)                           (when (eq ad1 t)
1289                             (return-from subtypep (values nil t)))                             (return-from osubtypep (values nil t)))
1290                           (values (match-dimensions ad1 ad2) t)))))                           (values (match-dimensions ad1 ad2) t)))))
1291                    (t (values nil ntp2))))                    (t (values nil ntp2))))
1292             (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))             (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))
# Line 816  Line 1380 
1380          (return-from coerce object))          (return-from coerce object))
1381    (when (classp type)    (when (classp type)
1382      (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))      (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))
1383    (setq type (normalize-type type))  ;  (setq type (normalize-type type))
1384      (if (atom type) (setq type (list type)))
1385    (case (car type)    (case (car type)
1386    ;       ((and or)  (coerce object (cadr type)));FIXME!!!
1387      (list      (list
1388       (do ((l nil (cons (elt object i) l))       (do ((l nil (cons (elt object i) l))
1389            (i (1- (length object)) (1- i)))            (i (1- (length object)) (1- i)))
1390           ((< i 0) l)))           ((< i 0) l)))
1391      ((array simple-array)      ((array simple-array vector simple-vector string simple-string)
1392       (unless (or (endp (cdr type))       (unless (or (endp (cdr type))
1393                   (endp (cddr type))                   (endp (cddr type))
1394                   (eq (caddr type) '*)                   (eq (caddr type) '*)
1395                   (endp (cdr (caddr type))))                   (endp (cdr (caddr type))))
1396              (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))         (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))
1397       (do ((seq (make-sequence type (length object)))       (do ((seq (make-sequence type (length object)))
1398            (i 0 (1+ i))            (i 0 (1+ i))
1399            (l (length object)))            (l (length object)))
1400           ((>= i l) seq)           ((>= i l) seq)
1401         (setf (elt seq i) (elt object i))))         (setf (elt seq i) (elt object i))))

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

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