/[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.15 by camm, Tue Aug 9 00:44:47 2005 UTC revision 1.16 by camm, Wed Aug 10 13:59:26 2005 UTC
# Line 224  Line 224 
224    (when (classp type)    (when (classp type)
225      (setq type (or (class-name type)      (setq type (or (class-name type)
226                     (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))))
227    (when (typep-int object (normalize-type type))    (when (typep-int object (normalize-type-int type nil))
228      (return-from coerce object))      (return-from coerce object))
229    (if (atom type) (setq type (list type)))    (if (atom type) (setq type (list type)))
230    (case (car type)    (case (car type)
# Line 571  Line 571 
571    
572    
573  (defun resolve-type (type)  (defun resolve-type (type)
574    (nreconstruct-type (nprocess-type (normalize-type type t))))    (nreconstruct-type (nprocess-type (normalize-type-int type t))))
575    
576    
577  ;;FIXME rethink need for side-effects here and in ntp functions above.  (defun copy-type (type res)
578      (cond ((atom type) (nreverse res))
579            ((consp (car type)) (copy-type (cdr type) (cons (copy-type (car type) nil) res)))
580            ((member (car type) '(member eql)) type)
581            ((copy-type (cdr type) (cons (car type) res)))))
582    
583  (defun normalize-type (type &optional ar);FIXME  (defun normalize-type (type &optional ar);FIXME
584    (let ((type (if (atom type) type (copy-list type))))    (normalize-type-int type ar))
585      (normalize-type-int type ar)))  
586    (defmacro maybe-eval (x) `(if (and (consp ,x) (eq (car ,x) 'load-time-value)) (eval (cadr ,x)) ,x))
587    
588  (defun normalize-type-int (type ar &aux tem)  (defun normalize-type-int (type ar &aux tem)
589    (cond ((atom type) (normalize-type-int (list type) ar))    (cond ((atom type) (normalize-type-int (list type) ar))
590          ((setq tem (coerce-to-standard-class (car type))) (setf (car type) tem) type)          ;;These are deftype accelerators
591          ((classp (car type)) (normalize-type-int (setf (car type) (class-name (car type))) ar))          ((member (car type) +range-types+)
592             (let* ((l (cadr type))
593                    (ln (if (cdr type) (maybe-eval l) '*))
594                    (h (caddr type))
595                    (hn (if (cddr type) (maybe-eval h) '*)))
596             (if (and (eq l ln) (eq h hn)) type `(,(car type) ,ln ,hn))))
597            ((eq (car type) 'complex)
598             (let* ((z (cadr type))
599                    (zn (if (cdr type) (maybe-eval z) 'real))
600                    (zn (if (eq zn '*) 'real zn))
601                    (zn (normalize-type-int zn ar)))
602               (cond ((member (car zn) '(and or not)) (distribute-complex zn))
603                     ((and (not (cddr type)) (eq z zn)) type)
604                     (`(,(car type) ,zn)))))
605            ((member (car type) '(array simple-array))
606             (let* ((tp (cadr type))
607                    (tpn (if (cdr type) (maybe-eval tp) '*))
608                    (tpn (if ar (upgraded-array-element-type tpn) tpn))
609                    (dm (caddr type))
610                    (dmn (if (cddr type) (maybe-eval dm) '*))
611                    (dmn (or dmn 0)))
612               (if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn))))
613            ((eq (car type) 'member) type)
614            ((and (not (cdr type)) (member (car type) +singleton-types+)) type)
615            ((eq (car type) 'cons)
616             (let* ((def '(t))
617                    (car (cadr type))
618                    (carn (if (cdr type) (maybe-eval car) def))
619                    (carn (if (eq carn '*) def carn))
620                    (carn (if (eq carn def) carn (normalize-type-int carn ar)))
621                    (cdr (caddr type))
622                    (cdrn (if (cddr type) (maybe-eval cdr) def))
623                    (cdrn (if (eq cdrn '*) def cdrn))
624                    (cdrn (if (eq cdrn def) cdrn (normalize-type-int cdrn ar))))
625               (if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn))))
626            ((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type))))
627            ((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar))
628          ((and (eq (car type) 'satisfies)          ((and (eq (car type) 'satisfies)
629                (setq tem (get (cadr type) 'predicate-type)))                (setq tem (get (cadr type) 'predicate-type)))
630           (normalize-type-int tem ar))           (normalize-type-int tem ar))
631          ((let* ((dt (and (symbolp (car type))          ((let* ((dt (and (symbolp (car type))
632                           (get (car type) 'deftype-definition)))                           (get (car type) 'deftype-definition)))
633                  (rr (do ((tmp (cdr type) (cdr tmp))) ((not tmp) (cdr type))                  (rr (if (member 'load-time-value (cdr type) :key (lambda (x) (when (consp x) (car x))))
634                           (when (and (consp (car tmp)) (eq (caar tmp) 'load-time-value))                          (mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x))
635                             (setf (car tmp) (eval (cadar tmp))))))                                  (cdr type))
636                          (cdr type)))
637                  (nt (and dt (apply dt rr))))                  (nt (and dt (apply dt rr))))
638             (when (and nt (not (equal type nt)))             (when (and nt (not (equal type nt)))
639               (normalize-type-int (copy-list nt) ar))))               (normalize-type-int nt ar))))
         ((and ar (member (car type) '(array simple-array)))  
          (setf (cadr type) (upgraded-array-element-type (cadr type)))  
          type)  
         ((eq (car type) 'complex)  
          (distribute-complex (normalize-type-int (cadr type) ar)))  
         ((and (eq (car type) 'cons) (cdr type))  
          (setf (cadr type) (normalize-type-int (cadr type) ar))  
          (if (cddr type)  
              (setf (caddr type) (normalize-type-int (caddr type) ar))  
            (setf (cddr type) `((t))))  
          (and (caadr type) (caaddr type) type))  
640          ((member (car type) '(and or not))          ((member (car type) '(and or not))
641           (do ((tmp (cdr type) (cdr tmp))) ((not tmp))           (let ((type `(,(car type) ,@(mapcar (lambda (x) (normalize-type-int x ar)) (cdr type)))))
              (setf (car tmp) (normalize-type-int (car tmp) ar)))  
642             (if (cdr type)             (if (cdr type)
643                 type                 type
644               (case (car type) (and '(t)) (or '(nil)) (not (error "Bad type~%")))))               (case (car type) (and '(t)) (or '(nil)) (not (error "Bad type~%"))))))
645          (type)))          (type)))
646    
647  (defun distribute-complex (type)  (defun distribute-complex (type)

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

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