;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.



;; *** Translation of type expressions ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-ctr 0)

(define make-constructor-fwd! '())

(define	make-parametrized-class-instance-fwd '())

(define contains-duplicate-field-names-fwd? '())

(define binder-get-instance-fwd '())

(define do-bind-type-vars1-fwd '())

(define get-union-of-types0-fwd '())


(define (is-tuple-type? binder to)
  (and
   (is-target-object? to)
   ;; The following test should not be strictly necessary.
   (not (eqv? to '()))
   (or (target-type=? to tc-nil)
       (and (is-tc-pair? to)
	    (is-type? binder (tt-car to))
	    (is-tuple-type? binder (tt-cdr to))))))


(set! is-tuple-type-fwd? is-tuple-type?)


(define (tuple-type-length binder tup)
  (assert (is-target-object? tup))
  (cond
   ((target-type=? tup tc-nil) 0)
   ((is-tc-pair? tup)
    (+ (tuple-type-length binder (tt-cdr tup)) 1))
   (else (raise 'tuple-type-length:error))))


;; The following procedure accepts markers in the tuple type.
(define (is-tuple-type1? binder to)
  (and
   (is-target-object? to)
   ;; The following test should not be strictly necessary.
   (not (eqv? to '()))
   (or (target-type=? to tc-nil)
       (and (is-tc-pair? to)
	    (let ((head (tt-car to)))
	      (is-type? binder head))
	    (is-tuple-type1? binder (tt-cdr to))))))


(define (is-tuple-type0? to)
  (and
   (is-target-object? to)
   ;; The following test should not be strictly necessary.
   (not (eqv? to '()))
   (or (target-type=? to tc-nil)
       (and (is-tc-pair? to)
	    (is-type0? (tt-car to))
	    (is-tuple-type0? (tt-cdr to))))))


(set! is-tuple-type0-fwd? is-tuple-type0?)


;; A general tuple is either a tuple with a tail
;; or an ordinary tuple.

(define (is-general-tuple-type? binder repr)
  (cond
   ;; Tuple types use <null> instead of null.
   ((null? repr) #f)
   ((not (hrecord? repr)) #f)
   ((eqv? repr tc-nil) #t)
   ((is-t-uniform-list-type2? binder repr) #t)
   ((is-tc-pair? repr)
    (and
     (is-type? binder (tt-car repr))
     (is-general-tuple-type? binder (tt-cdr repr))))
   (else #f)))


(set! is-general-tuple-type-fwd? is-general-tuple-type?)


;; This procedure returns the length of the fixed part when the argument
;; has a tail.
(define (general-tuple-type-length binder tup)
  (assert (is-target-object? tup))
  (cond
   ((target-type=? tup tc-nil) 0)
   ;; We accept type variables as the tail component type.
   ((is-t-uniform-list-type2? binder tup) 0)
   ((is-tc-pair? tup)
    (+ (general-tuple-type-length binder (tt-cdr tup)) 1))
   (else (raise 'general-tuple-type-length:error))))


(define (tuple-type->list-reject-cycles0 tuple-type visited)
  (cond
   ((or (null? tuple-type) (eqv? tuple-type tc-nil))
    '())
   ((memv tuple-type visited)
    (raise 'tuple-cycles-not-allowed))
   (else
    (cons (tt-car tuple-type)
	  (tuple-type->list-reject-cycles0
	   (tt-cdr tuple-type)
	   (cons tuple-type visited))))))


(define (tuple-type->list-reject-cycles tuple-type)
  (tuple-type->list-reject-cycles0 tuple-type '()))


(set! tuple-type->list-reject-cycles-fwd tuple-type->list-reject-cycles)


(define (gen-tuple-type->list0 binder tuple-type visited)
  (cond
   ((or (null? tuple-type) (eqv? tuple-type tc-nil))
    '())
   ((memv tuple-type visited)
    (raise 'tuple-cycles-not-allowed))
   ((is-t-uniform-list-type? binder tuple-type)
    (list (make-rest-object (get-uniform-list-param binder tuple-type))))
   (else
    (cons (tt-car tuple-type)
	  (gen-tuple-type->list0
	   binder
	   (tt-cdr tuple-type)
	   (cons tuple-type visited))))))


(define (gen-tuple-type->type-list binder tuple-type)
  (make-type-list-object (gen-tuple-type->list0 binder tuple-type '())))


(set! gen-tuple-type->type-list-fwd gen-tuple-type->type-list)


(define (tuple-type-ref tuple-type index)
  (assert (>= index 0))
  (cond
   ((or (null? tuple-type) (eqv? tuple-type tc-nil))
    (raise 'tuple-type-ref:index-out-of-range))
   ((= index 0)
    (tt-car tuple-type))
   (else
    (tuple-type-ref (tt-cdr tuple-type) (- index 1)))))


(define (make-irregular-union lst-members)
  (make-apti tmt-union lst-members))


(define (make-irregular-uniform-list type-args)
  (make-apti tplt-uniform-list type-args))


(define (translate-uniform-list-type-expression binder
						type-arg)
  (assert (is-binder? binder))
  (assert (is-entity? type-arg))
  (if (entity-is-none1? binder type-arg)
      (raise 'none-as-uniform-list-member-type)
      (let* ((type-arg-list (construct-toplevel-type-repr
			     binder
			     (list type-arg)))
	     (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	     (type-params
	      (if regular?
		  (tuple-type->list-reject-cycles type-arg-list)
		  '())))
	(if regular?
	    (make-tt-uniform-list (car type-params))
	    (make-irregular-uniform-list (list type-arg))))))


(set! translate-uniform-list-type-expression-fwd
      translate-uniform-list-type-expression)


(define (translate-irregular-pair-class args)
  (make-apti tpc-pair args))


(define (translate-pair-class-expression0 type-args)
  (assert (and (list? type-args)
	       (and-map? is-entity? type-args)))
  (assert (= (length type-args) 2))
  (make-tpci-pair (car type-args) (cadr type-args)))


(set! translate-pair-class-expression0-fwd translate-pair-class-expression0)


(define (translate-pair-class-expression binder
					 type-args)
  (assert (is-binder? binder))
  (assert (and (list? type-args)
	       (and-map? is-entity? type-args)))
  (let* ((type-arg-list (construct-toplevel-type-repr
			 binder
			 type-args))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '())))
    (cond
     ((not regular?)
      (translate-irregular-pair-class type-args))
     ((not (= (length params) 2))
      (raise 'invalid-number-of-pair-component-types))
     ((or (null? (car params)) (null? (cadr params)))
      (raise 'corrupted-pair-class-structures))
     ((or (eqv? (car params) tt-none)
	  (eqv? (cadr params) tt-none))
      (raise 'type-parameter-none-in-pair-class))
     (else
      (make-tpci-pair (car params) (cadr params))))))
 

;; We do not allow type operations with tuple types.
;; Type lists (which are now called tuple-types)
;; may be used for that purpose.
(define (make-tuple-type . subexprs)
  (dvar1-set! subexprs)
  (assert (list? subexprs))
  (assert (and-map? is-target-object? subexprs))
  (if (null? subexprs)
      tc-nil
      (make-tpci-pair
       (car subexprs)
       (apply make-tuple-type (cdr subexprs)))))


(set! make-tuple-type-fwd
      make-tuple-type)


(define (translate-tuple-type-with-tail tuple-type tail-part)
  (assert (is-tuple-type0? tuple-type))
  (assert (is-target-object? tail-part))
  (if (or (null? tuple-type) (eqv? tuple-type tc-nil))
      tail-part
      (let* ((old-tail (tt-cdr tuple-type))
	     (new-tail (translate-tuple-type-with-tail old-tail
						       tail-part))
	     (tuple-head (tt-car tuple-type)))
	(if (eqv? new-tail old-tail)
	    tuple-type
	    (make-tpci-pair tuple-head new-tail)))))


(set! translate-tuple-type-with-tail-fwd
      translate-tuple-type-with-tail)


(define (join-two-tuple-types t1 t2)
  (assert (is-tuple-type0? t1))
  (assert (is-tuple-type0? t2))
  (if (or (null? t1) (eqv? t1 tc-nil))
      t2
      (let* ((old-tail (tt-cdr t1))
	     (new-tail (join-two-tuple-types old-tail t2))
	     (tuple-head (tt-car t1)))
	(if (eqv? new-tail old-tail)
	    t1
	    (make-tpci-pair tuple-head new-tail)))))


(define (join-tuple-types . tuple-types)
  (if (null? tuple-types)
      tc-nil
      (join-two-tuple-types (car tuple-types)
			    (apply join-tuple-types (cdr tuple-types)))))


(set! join-tuple-types-fwd join-tuple-types)


(define (translate-general-proc-type-expression0
	 simple?
	 arg-list-desc result-type pure?
	 always-returns? never-returns?
	 static-method?)
  (assert (boolean? simple?))
  (assert (is-target-object? arg-list-desc))
  (assert (is-target-object? result-type))
  (assert (boolean? pure?))
  (assert (boolean? always-returns?))
  (assert (boolean? never-returns?))
  (assert (boolean? static-method?))
  (make-tpti-general-proc simple? arg-list-desc result-type
			  pure? always-returns? never-returns?
			  static-method?))


(define (translate-general-proc-type-expression
	 binder simple?
	 arg-desc-exprs result-type-desc pure?
	 always-returns? never-returns?
	 static-method?)
  (assert (is-binder? binder))
  (assert (boolean? simple?))
  (assert (list? arg-desc-exprs))
  (assert (and-map? is-entity? arg-desc-exprs))
  (assert (is-entity? result-type-desc))
  (assert (boolean? pure?))
  (assert (boolean? always-returns?))
  (assert (boolean? never-returns?))
  (assert (boolean? static-method?))
  (let ((arg-list-desc
	 (construct-toplevel-type-repr binder arg-desc-exprs)))
    (translate-general-proc-type-expression0
     simple?
     arg-list-desc result-type-desc pure?
     always-returns? never-returns?
     static-method?)))


(define (translate-proc-type-expression
	 binder arg-desc-exprs result-type-desc pure?
	 always-returns? never-returns? static-method?)
  (translate-general-proc-type-expression
   binder #f arg-desc-exprs result-type-desc pure?
   always-returns? never-returns? static-method?))


(define (translate-simple-proc-class-expression
	 binder arg-desc-exprs result-type-desc pure?
	 always-returns? never-returns? static-method?)
  (translate-general-proc-type-expression
   binder #t arg-desc-exprs result-type-desc pure?
   always-returns? never-returns? static-method?))


(define tt-general-procedure
  (make-tpti-general-proc
   #f
   tt-list-of-objects
   tt-none
   #f #f #f #f))


(define tt-general-proc-with-value
  (make-tpti-general-proc
   #f
   tt-list-of-objects
   tc-object
   #f #f #f #f))


(define tt-general-simple-proc  
  (make-tpti-general-proc
   #t
   tt-list-of-objects
   tt-none
   #f #f #f #f))


(define tt-general-simple-proc-with-value
  (make-tpti-general-proc
   #t
   tt-list-of-objects
   tc-object
   #f #f #f #f))


(define tt-general-function
  (make-tpti-general-proc
   #f
   tt-list-of-objects
   tt-none
   #t #f #f #f))


(define tt-general-func-with-value
  (make-tpti-general-proc
   #f
   tt-list-of-objects
   tc-object
   #t #f #f #f))


;; A pure procedure with no result value has no effect
;; except possibly raising an exception.
(define tt-general-simple-func
  (make-tpti-general-proc
   #t
   tt-list-of-objects
   tt-none
   #t #f #f #f))


(define tt-general-simple-func-with-value
  (make-tpti-general-proc
   #t
   tt-list-of-objects
   tc-object
   #t #f #f #f))


(define (translate-vector-expression0 member-type)
  (make-tpci-vector member-type member-type))


(define (translate-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr
			 binder
			 member-type-list))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '()))
	 (tc
	  (if regular?
	      (begin
		(strong-assert (= (length type-params) 1))
		(strong-assert (not (eqv? (car type-params) tt-none)))
		(translate-vector-expression0 (car type-params)))
	      (make-apti tpc-vector member-type-list))))
    tc))


(define (translate-mutable-vector-expression0 member-type)
  (make-tpci-mutable-vector member-type member-type))


(define (translate-mutable-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr
			 binder
			 member-type-list))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '()))
	 (tc
	  (if regular?
	      (begin
		(strong-assert (= (length type-params) 1))
		(strong-assert (not (eqv? (car type-params) tt-none)))
		(translate-mutable-vector-expression0 (car type-params)))
	      (make-apti tpc-mutable-vector member-type-list))))
    tc))


(define (translate-value-vector-expression0 member-type)
  (make-tpci-value-vector member-type member-type))


(define (translate-value-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr
			 binder
			 member-type-list))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '()))
	 (tc
	  (if regular?
	      (begin
		(strong-assert (= (length type-params) 1))
		(strong-assert (not (eqv? (car type-params) tt-none)))
		(translate-value-vector-expression0 (car type-params)))
	      (make-apti tpc-value-vector member-type-list))))
    tc))


(define (translate-mutable-value-vector-expression0 member-type)
  (make-tpci-mutable-value-vector member-type member-type))


(define (translate-mutable-value-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr
			 binder
			 member-type-list))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '()))
	 (tc
	  (if regular?
	      (begin
		(strong-assert (= (length type-params) 1))
		(strong-assert (not (eqv? (car type-params) tt-none)))
		(translate-mutable-value-vector-expression0 (car type-params)))
	      (make-apti tpc-vector member-type-list))))
    tc))


;; Argument inside-param-def? is not used.
(define (translate-param-class-instance-expr binder param-class type-args
					     inside-param-def?
					     make-ctr?)
  (assert (is-binder? binder))
  (assert (is-target-object? param-class))
  (dvar1-set! type-args)
  (assert (and (list? type-args)
	       (and-map? is-entity? type-args)))
  (assert (boolean? inside-param-def?))
  (assert (boolean? make-ctr?))
  (let* ((type-arg-list (construct-toplevel-type-repr binder
						      type-args))
	 (tuple? (is-tuple-type? binder type-arg-list))
	 (regular?
	  (and
	   tuple?
	   (not (contains-type-modifiers-fwd? type-arg-list))))
	 ;; The following definition is unnecessary.
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '())))
    (cond
     ((not regular?)
      (make-apti param-class type-args))
     (tuple?
      (let ((type-params (tuple-type->list-reject-cycles type-arg-list)))
	(cond
	 ((hfield-ref param-class 'incomplete?)
	  (make-apti param-class type-params))
	 ;; We allow <none> as a value of a type parameters.
	 ;; ((and (not-null? type-params)
	 ;;       (or-map? entity-is-none? type-params))
	 ;;  (raise 'invalid-use-of-none-1))
	 (else
	  (let ((to
		 (binder-get-instance-fwd
		  binder param-class
		  type-params
		  make-ctr?)))
	    ;; Not sure if it is necessary to make the constructor
	    ;; here.
	    ;; Procedure binder-get-instance contains code
	    ;; to make the constructor.
	    (if (and make-ctr?
		     (tno-field-ref param-class 'instance-has-constructor?)
		     (hrecord? to)
		     (is-target-object? to)
		     (not (hfield-ref to 'incomplete?))
		     ;; There should be no need to test field type-constructor.
		     (null? (tno-field-ref to 'proc-constructor)))
		(make-constructor-fwd!
		 binder
		 to))
	    (if (not (hfield-ref to 'incomplete?))
		(tno-field-set! to 'l-param-exprs type-params))
	    to)))))
     (else
      ;; This is logically impossible.
      (raise 'internal-error)))))


(define (translate-param-sgn-instance-expr binder param-sgn type-args)
  (assert (is-binder? binder))
  (assert (is-target-object? param-sgn))
  (assert (and (list? type-args)
	       (and-map? is-entity? type-args)))
  (let* ((type-arg-list (construct-toplevel-type-repr binder
						      type-args))
	 (regular? (not (contains-type-modifiers-fwd? type-arg-list)))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '())))
    (cond
     ((not regular?) (make-apti param-sgn type-args))
     ((is-tuple-type? binder type-arg-list)
      (let ((type-params (tuple-type->list-reject-cycles type-arg-list)))
	(cond
	 ((hfield-ref param-sgn 'incomplete?)
	  (make-param-sgn-inst-object param-sgn type-params))
	 ;; We allow <none> as a value of a type parameter.
	 ;; ((and (not-null? type-params)
	 ;;       (or-map? entity-is-none? type-params))
	 ;;  (raise 'invalid-use-of-none-2))
	 (else
	  (let ((to
		 (binder-get-instance-fwd
		  binder param-sgn
		  type-params
		  #f)))
	    to)))))
     (else (raise 'invalid-param-signature-instance)))))


(define (translate-param-ltype-instance-expr binder param-ltype type-args)
  (assert (is-binder? binder))
  (assert (is-target-object? param-ltype))
  (assert (and (list? type-args)
	       (and-map? is-target-object? type-args)))
  (let* ((type-arg-list (construct-toplevel-type-repr binder
						      type-args))
	 (tuple? (is-tuple-type? binder type-arg-list))
	 (regular? 
	  (and
	   tuple?
	   (not (contains-type-modifiers-fwd? type-arg-list))))
	 (type-params
	  (if tuple?
	      (tuple-type->list-reject-cycles type-arg-list)
	      type-args)))
    (cond
     ((not regular?) (make-apti param-ltype type-args))
     (tuple?
      (cond
       ((hfield-ref param-ltype 'incomplete?)
	(make-apti param-ltype type-params))
       ;; <none> is allowed as a type parameter.
       ;; ((and (not-null? type-params)
       ;; 	     (or-map? entity-is-none? type-params))
       ;; 	(raise 'invalid-use-of-none-3))
       (else
	(let ((to
	       (binder-get-instance-fwd
		binder param-ltype
		type-params
		#f)))
	  to))))
     (else
      ;; This is logically impossible.
      (raise 'internal-error)))))


(define (translate-param-ltype-instance-expr2 binder param-ltype type-args
					      visited)
  (assert (is-binder? binder))
  (assert (is-target-object? param-ltype))
  (assert (and (list? type-args)
	       (and-map? is-target-object? type-args)))
  (let* ((type-arg-list (construct-toplevel-type-repr binder
						      type-args))
	 (tuple? (is-tuple-type? binder type-arg-list))
	 (regular? 
	  (and
	   tuple?
	   (not (contains-type-modifiers-fwd? type-arg-list))))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '())))
    (cond
     ((not regular?) (cons (make-apti param-ltype type-args) '()))
     (tuple?
      (cond
       ((hfield-ref param-ltype 'incomplete?)
	(cons (make-apti param-ltype type-params) '()))
       ;; ((and (not-null? type-params)
       ;; 	     (or-map? entity-is-none? type-params))
       ;; 	(raise 'invalid-use-of-none-4))
       ((eq? param-ltype tmt-union)
	(cons (get-union-of-types0-fwd binder type-params) '()))
       (else
	(let ((tvars (tno-field-ref param-ltype 'l-tvars)))
	  (if (not (= (length tvars) (length type-params)))
	      (raise 'invalid-number-of-type-parameters))
	  (let* ((plt-expr (tno-field-ref param-ltype 'x-value-expr))
		 (bindings (map cons tvars type-params))
		 (pr (do-bind-type-vars1-fwd
		      binder bindings plt-expr visited)))
	    pr)))))
     (else
      ;; This is logically impossible.
      (raise 'internal-error)))))


(define (translate-param-ltype-instance-expr3 binder param-ltype type-args
					      visited)
  (assert (is-binder? binder))
  (assert (is-target-object? param-ltype))
  (assert (and (list? type-args)
	       (and-map? is-target-object? type-args)))
  (let* ((type-arg-list (construct-toplevel-type-repr binder
						      type-args))
	 (tuple? (is-tuple-type? binder type-arg-list))
	 (regular? 
	  (and
	   tuple?
	   (not (contains-type-modifiers-fwd? type-arg-list))))
	 (type-params
	  (if regular?
	      (tuple-type->list-reject-cycles type-arg-list)
	      '())))
    (cond
     ((and
       (eq? param-ltype tmt-union)
       (= (length type-args) 1)
       (is-t-splice? (car type-args))
       (is-t-uniform-list-type?
	binder (tno-field-ref (car type-args) 'type-component)))
      (let ((tt-param
	     (get-uniform-list-param
	      binder (tno-field-ref (car type-args) 'type-component))))
	(cons tt-param '())))
     ((not regular?) (cons (make-apti param-ltype type-args) '()))
     (tuple?
      (cond
       ((let* ((param-cache (hfield-ref binder 'param-cache))
	       (binding (param-cache-fetch param-cache
					   param-ltype type-params)))
	  binding)
	=>
	(lambda (pr1)
	  (cons (cdr pr1) '())))
       ((hfield-ref param-ltype 'incomplete?)
	(cons (make-apti param-ltype type-params) '()))
       ;; ((and (not-null? type-params)
       ;; 	     (or-map? entity-is-none? type-params))
       ;; 	(raise 'invalid-use-of-none-5))
       ((eq? param-ltype tmt-union)
	(cons (get-union-of-types0-fwd binder type-params) '()))
       (else
	(let ((tvars (tno-field-ref param-ltype 'l-tvars)))
	  (if (not (= (length tvars) (length type-params)))
	      (raise 'invalid-number-of-type-parameters))
	  (let* ((plt-expr (tno-field-ref param-ltype 'x-value-expr))
		 (bindings (map cons tvars type-params))
		 (pr (do-bind-type-vars1-fwd
		      binder bindings plt-expr visited)))
	    pr)))))
     (else
      ;; This is logically impossible.
      (raise 'internal-error)))))


(define (get-param-def-type r-param-type)
  (let* ((type-type (get-entity-type r-param-type)))
    (cond
     ((eq? type-type t-param-class) 'class)
     ((eq? type-type t-param-logical-type) 'logical-type)
     ((eq? type-type tpc-param-proc) 'procedure) 
     ((eq? type-type t-param-signature) 'signature)
     (else 
      (dvar1-set! r-param-type)
      (raise 'internal-invalid-param-def-3)))))


(define (contains-incomplete-types? item)
  (and (is-target-object? item) (hfield-ref item 'incomplete?)))


(define (make-union-expression0 types)
  (assert (and-map? is-target-object? types))
  (apply make-tt-union types))


;; If any of the types is none return none.

(define (get-union-of-types0 binder types)
  (assert (is-binder? binder))
  ;; and-map? returns #t on empty argument list.
  (assert (and (list? types)
	       (and-map? is-target-object? types)))
  (cond
   ((or-map? (lambda (type)
	       (target-type=? type tt-none))
	     types)
    tt-none)
   ((or-map? contains-type-variables-fwd? types)
    (make-union-expression0 types))
   ((or-map? contains-incomplete-types? types)
    (make-union-expression0 types))
   (else
    (let* ((count (length types))
	   (vec-dupl (make-vector count #t))
	   (res '()))
      (do ((lst1 types (cdr lst1)) (i1 0 (+ i1 1)))
	  ((>= i1 count))
	(assert (not-null? lst1))
	(let ((cur-elem1 (car lst1)))
	  (do ((i2 (+ i1 1) (+ i2 1)))
	      ((>= i2 count))
	    (let ((cur-elem2 (list-ref types i2)))
	      (assert (not-null? cur-elem2))
	      (cond
	       ((and (vector-ref vec-dupl i2)
		     (is-t-subtype? binder cur-elem1 cur-elem2))
		(vector-set! vec-dupl i1 #f))
	       ((and (vector-ref vec-dupl i1)
		     (is-t-subtype? binder cur-elem2 cur-elem1))
		(vector-set! vec-dupl i2 #f)))))))
      (do ((i3 0 (+ i3 1)) (lst3 types (cdr lst3))) ((>= i3 count))
	(if (vector-ref vec-dupl i3)
	    (set! res (append res (list (car lst3))))))
      (let ((len (length res)))
	(cond
	 ((> len 1) (apply make-tt-union res))
	 ((= len 1) (car res))
	 ;; Formerly we had tt-none in the following.
	 ((= len 0) tc-nil)
	 (else (raise 'internal-error))))))))


(set! get-union-of-types0-fwd get-union-of-types0)


(define (get-union-of-types binder args)
  (assert (is-binder? binder))
  (let ((arg-list (construct-toplevel-type-repr
		    binder
		    args)))
    (if (is-t-type-variable? arg-list)
	(make-irregular-union (list (make-splice-object arg-list)))
	(let* ((regular?
		(not (contains-type-modifiers-fwd? arg-list)))
	       (params
		(if regular?
		    (tuple-type->list-reject-cycles arg-list)
		    '()))
	       (result
		(if regular?
		    (get-union-of-types0 binder
					 params)
		    (make-irregular-union args))))
	  result))))
