
(define (is-t-uniform-list-type2? binder to)
  (and
   (is-tt-union? to)
   (let ((lst-members (tno-field-ref to 'l-member-types)))
     (and (= (length lst-members) 2)
          (is-tc-pair? (car lst-members))
          (let ((x1 (tt-car (car lst-members))))
            (or (is-t-type-variable? x1)
                (is-t-instance-fwd? binder x1 tt-type)))
          (eqv? (tt-cdr (car lst-members)) to)
          (eqv? (cadr lst-members) tc-nil)))))


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

(define (is-general-tuple-type? binder repr)
  (let ((b-result
         (cond
           ;; Tuple types use <null> instead of null.
           ((null? repr) #f)
           ((not (hrecord? repr)) #f)
           ((eq? 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))))
    b-result))


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


(define (is-general-tuple-type0? repr)
  (let ((b-result
         (cond
           ;; Tuple types use <null> instead of null.
           ((null? repr) #f)
           ((not (hrecord? repr)) #f)
           ((eq? repr tc-nil) #t)
           ((is-t-uniform-list-type0? repr) #t)
           ((is-tc-pair? repr)
            (and
             (not (is-incomplete-object? (tt-car repr)))
             (is-general-tuple-type0? (tt-cdr repr))))
           (else #f))))
    b-result))


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


(define (is-tuple-type? binder to)
  (d2wl 'debug1064 "is-tuple-type?")
  (d2wl 'debug1064 (debug-get-string 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)
            (begin (d2wl 'debug1064 "is-tuple-type?/1") #t)
            (is-type? binder (tt-car to))
            (begin (d2wl 'debug1064 "is-tuple-type?/2") #t)
            (is-tuple-type? binder (tt-cdr to))))))


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


(define (is-proc-deduction-alist? al)
  (and (list? al)
       (for-all (lambda (p)
                  (and (pair? p)
                       (is-target-object? (car p))
                       (is-entity? (cdr p))))
                al)))


(set! is-proc-deduction-alist-fwd? is-proc-deduction-alist?)


(define (is-procedure-object? x)
  (and (is-target-object? x) (is-t-proc-type? (get-entity-type x))))


(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 (is-t-uniform-list-type? binder to)
  (and
   (is-tt-union? to)
   (let ((lst-members (tno-field-ref to 'l-member-types)))
     (and (= (length lst-members) 2)
          (is-tc-pair? (car lst-members))
          (is-t-instance-fwd? binder (tt-car (car lst-members)) tt-type)
          (eq? (tt-cdr (car lst-members)) to)
          (eq? (cadr lst-members) tc-nil)))))


(define (is-t-uniform-list-type0? to)
  (and
   (is-tt-union? to)
   (let ((lst-members (tno-field-ref to 'l-member-types)))
     (and (= (length lst-members) 2)
          (is-tc-pair? (car lst-members))
          (not (is-incomplete-object? (car lst-members)))
          (eq? (tt-cdr (car lst-members)) to)
          (eq? (cadr lst-members) tc-nil)))))


(set! is-t-uniform-list-type0-fwd? is-t-uniform-list-type0?)


(define (is-t-uniform-list-type-step1? x)
  (and
   (is-tt-union? x)
   (let ((l-members (tno-field-ref x 'l-member-types)))
     (and (eqv? (length l-members) 2)
          (let ((tt-first (car l-members))
                (tt-second (cadr l-members)))
            (and
             (is-tc-pair? tt-first)
             (not (is-incomplete-object? tt-first))
             (is-t-uniform-list-type0? (tt-cdr tt-first))
             (eqv? (tt-car tt-first)
                   (get-uniform-list-param0 (tt-cdr tt-first)))
             (eq? tt-second tc-nil)))))))


(define (get-uniform-list-param binder to)
  (assert (is-t-uniform-list-type? binder to))
  (tt-car (car (tno-field-ref to 'l-member-types))))


(define (get-uniform-list-param0 to)
  ;; (assert (is-t-uniform-list-type0? to))
  (tt-car (car (tno-field-ref to 'l-member-types))))


(set! get-uniform-list-param0-fwd get-uniform-list-param0)


(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?)


(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 (make-union-expression0 types)
  (assert (for-all is-type0? types))
  (apply make-tt-union types))


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

(define (get-union-of-types0 binder types)
  (d2wl 'debug1012 "get-union-of-types0")
  (d2wl 'debug1012 (debug-get-string types))
  (assert (is-binder? binder))
  ;; and-map? returns #t on empty argument list.
  (assert (and (list? types)
               (and-map? is-type0? 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? is-incomplete-object? types)
     (make-union-expression0 types))
    (else
     (d2wl 'debug1012 "get-union-of-types0/1")
     (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-fwd? binder cur-elem1 cur-elem2))
                  (vector-set! vec-dupl i1 #f))
                 ((and (vector-ref vec-dupl i1)
                       (is-t-subtype-fwd? 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 (make-irregular-union lst-members)
  (make-apti tmt-union lst-members))


(define (get-union-of-types binder args)
  (assert (is-binder? binder))
  (let ((arg-list (construct-toplevel-type-repr-fwd
                   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))))


(define (cowb-apti binder to subreprs type-check?)
  (let ((pt-new (car subreprs))
        (lst-new-params (cadr subreprs))
        (pt-old (tno-field-ref to 'type-meta))
        (lst-old-params (tno-field-ref to 'l-type-args)))
    (assert (eqv? (length lst-new-params) (length lst-old-params)))
    (if (or (not (eqv? pt-new pt-old))
            (and
             (not-null? lst-new-params)
             (not (and-map? eqv? lst-new-params lst-old-params))))
      (cond
        ((eq? pt-new tc-pair)
         (translate-pair-class-expression binder lst-new-params))
        ((eq? pt-new tmt-union)
         (get-union-of-types binder lst-new-params))
        ((is-t-param-class? pt-new)
         (translate-param-class-instance-expr binder pt-new lst-new-params
                                              (not type-check?)
                                              #t))
        ((is-t-param-signature? pt-new)
         (translate-param-sgn-instance-expr binder pt-new lst-new-params))
        ((is-t-param-logical-type? pt-new)
         (translate-param-ltype-instance-expr binder pt-new lst-new-params))
        ((is-tc-vector? pt-new)
         (translate-vector-expression binder lst-new-params))
        ((is-tc-mutable-vector? pt-new)
         (translate-mutable-vector-expression binder lst-new-params))
        (else
         (raise 'unknown-parametrized-type-1)))
      to)))


(set! cowb-apti-fwd cowb-apti)


;; (define (make-sgn-members-from-list-repr subreprs)
;;   (if (null? subreprs)
;;     '()
;;     (if (null? (cdr subreprs))
;;       (raise 'internal-invalid-signature)
;;       (append
;;        (list (cons (car subreprs) (cadr subreprs)))
;;        (make-sgn-members-from-list-repr (cddr subreprs))))))


(define (cowb-signature binder repr subreprs)
  (assert (or (null? binder) (is-binder? binder)))
  (assert (is-t-signature? repr))
  (assert (list? subreprs))
  (let ((l-members-new subreprs)
        (l-members-old (tno-field-ref repr 'l-members)))
    (if (not (and-map? (lambda (pr1 pr2)
                         (and (eq? (car pr1) (car pr2))
                              (equal-reprs1-fwd? binder (cdr pr1) (cdr pr2))))
                       l-members-new l-members-old))
      (begin
       (make-signature-object2 repr l-members-new))
      repr)))


(set! cowb-signature-fwd cowb-signature)


(define (cowb-field binder repr subreprs)
  (assert (or (null? binder) (is-binder? binder)))
  (assert (is-t-field? repr))
  (assert (and (list? subreprs) (= (length subreprs) 2)))
  (let ((to-old-type (tno-field-ref repr 'type))
        (obj-old-value (tno-field-ref repr 'x-init-value))
        (to-new-type (car subreprs))
        (obj-new-value (cadr subreprs)))
    (cond
      ((and (hfield-ref binder 'type-check?)
            (tno-field-ref repr 'has-init-value?)
            (not (is-t-instance-fwd? binder obj-new-value to-new-type)))
       (raise 'field-type-mismatch-in-cloning))
      ((or (not (eqv? to-old-type to-new-type))
           (not (eqv? obj-old-value obj-new-value)))
       (make-field
        (tno-field-ref repr 's-name)
        to-new-type
        (tno-field-ref repr 's-read-access)
        (tno-field-ref repr 's-write-access)
        (tno-field-ref repr 'has-init-value?)
        obj-new-value))
      (else repr))))


(set! cowb-field-fwd cowb-field)


(define-public (cowb-union binder to subreprs type-check?)
  (let ((old-member-types (tno-field-ref to 'l-member-types)))
    (let ((result
           ;; Not sure if the first condition is needed.
           ;; It is OK to compare type variables with eqv? here.
           (if (or (and type-check? (not (type-dispatched? to)))
                   (not (for-all eqv? subreprs old-member-types)))
             (if type-check?
               (let ((to-type (get-union-of-types binder subreprs)))
                 (if (is-tt-union? to-type)
                   (check-none-union to-type '())
                   to-type))
               (check-none-union (make-union-expression0 subreprs) '()))
             to)))
      result)))
  

(set! cowb-union-fwd cowb-union)


(define (cowb-procedure-type binder to subreprs type-check? simple?)
  (let ((new-arg-list-type (car subreprs))
        (new-result-type (cadr subreprs))
        (old-arg-list-type (tno-field-ref to 'type-arglist))
        (old-result-type (tno-field-ref to 'type-result)))
    (if (or (not (eqv? new-arg-list-type old-arg-list-type))
            (not (eqv? new-result-type old-result-type)))
      (let ((pure? (tno-field-ref to 'pure-proc?))
            (always-returns? (tno-field-ref to 'appl-always-returns?))
            (never-returns? (tno-field-ref to 'appl-never-returns?))
            (static-method? (tno-field-ref to 'static-method?)))
        (make-tpti-general-proc
         simple?
         new-arg-list-type
         new-result-type
         pure?
         always-returns?
         never-returns?
         static-method?))
      to)))


(set! cowb-procedure-type-fwd cowb-procedure-type)


(define (cowb-param-class-instance binder repr subreprs)
  (assert (or (null? binder) (is-binder? binder)))
  (assert (is-t-param-class-instance-fwd? repr))
  (assert (and (list? subreprs) (eqv? (length subreprs) 2)))
  (let ((pc-new (car subreprs))
        (args-new (cadr subreprs))
        (pc-old (get-entity-type repr))
        (args-old (tno-field-ref repr 'l-tvar-values)))
    (if (or (not (eqv? pc-new pc-old))
            (not (and-map? type-equal? args-new args-old)))
      (begin
       (translate-param-class-instance-expr
        binder pc-new args-new #f #t))
      (begin
       repr))))


(set! cowb-param-class-instance-fwd cowb-param-class-instance)


(define (cowb-param-proc-class binder obj new-components type-check?)
  (assert (is-binder? binder))
  (assert (is-tc-param-proc? obj))
  (assert (and (list? new-components)
               (eqv? (length new-components) 2)))
  (assert (boolean? type-check?))
  (let* ((name (tno-field-ref obj 'str-name))
         (old-tvars (tno-field-ref obj 'l-tvars))
         (old-inst-type (tno-field-ref obj 'type-contents))
         (old-arg-list (tno-field-ref old-inst-type 'type-arglist))
         (old-result-type (tno-field-ref old-inst-type 'type-result))
         (new-tvars (car new-components))
         (new-inst-type (cadr new-components))
         (new-arg-list (tno-field-ref new-inst-type 'type-arglist))
         (new-result-type (tno-field-ref new-inst-type 'type-result)))
    (d2wl 'cowb-param-proc-class "cowb-param-proc-class/1")
    (d2wl 'cowb-param-proc-class (debug-get-string new-tvars))
    (d2wl 'cowb-param-proc-class (debug-get-string new-arg-list))
    (d2wl 'cowb-param-proc-class (debug-get-string new-result-type))
    (if (for-all is-t-type-variable? new-tvars)
      (if (and (eqv? (length old-tvars) (length new-tvars))
               ;; and-map? returns #t for empty list
               (for-all type-variable=? old-tvars new-tvars)
               (eqv? old-arg-list new-arg-list)
               (eqv? old-result-type new-result-type))
        obj
        (begin
         (let ((new-inst-type2
                (clone-with-branches-fwd
                 binder
                 (tno-field-ref obj 'type-contents)
                 (list new-arg-list new-result-type)
                 type-check?)))
           (make-param-proc-class-object name new-tvars new-inst-type2))))
      (if (not (exists is-t-type-variable? new-tvars))
        (begin
         ;; Is the following assertion OK?
         (assert (and
                  (not (contains-type-variables-fwd? new-arg-list))
                  (not (contains-type-variables-fwd? new-result-type))))
         (clone-with-branches-fwd binder
                                  (tno-field-ref obj 'type-contents)
                                  (list new-arg-list new-result-type)
                                  type-check?))
        (let* ((new-tvars2 (filter is-t-type-variable? new-tvars))
               (new-inst-type2
                (clone-with-branches-fwd binder
                                         (tno-field-ref obj 'type-contents)
                                         (list new-arg-list new-result-type)
                                         type-check?)))
          (make-param-proc-class-object name new-tvars2 new-inst-type2))))))


(set! cowb-param-proc-class-fwd cowb-param-proc-class)


(define (eqv-lists? l1 l2)
  (and (eqv? (length l1) (length l2))
       (for-all eqv? l1 l2)))

       
(define (cowb-type-loop binder repr subreprs type-check?)
  (assert (or (null? binder) (is-binder? binder)))
  (assert (is-t-type-loop? repr))
  (assert (and (list? subreprs) (eqv? (length subreprs) 3)))
  (let ((new-iter-var (car subreprs))
        (new-subtype-list (cadr subreprs))
        (new-iter-expr (caddr subreprs))
        (old-iter-var (tno-field-ref repr 'tvar))
        (old-subtype-list (tno-field-ref repr 'x-subtypes))
        (old-iter-expr (tno-field-ref repr 'x-iter-expr)))
    ;; Not sure if checking subtype list is correct here.
    (if (and (or (not (eqv? new-iter-var old-iter-var))
                 (and (not (eqv? new-subtype-list old-subtype-list))
                      (not
                       (and (list? new-subtype-list)
                            (list? old-subtype-list)
                            (eqv-lists? new-subtype-list old-subtype-list))))
                 (not (eqv? new-iter-expr old-iter-expr)))
             (or
              (is-t-type-list? new-subtype-list)
              (is-t-type-variable? new-subtype-list)
              (is-tuple-type? binder new-subtype-list)
              (list? new-subtype-list)))
      (construct-type-loop-repr-fwd
        binder
        (make-type-loop-object new-iter-var
          new-subtype-list
          new-iter-expr))
      repr)))


(set! cowb-type-loop-fwd cowb-type-loop)


(define (cowb-type-join binder repr subreprs type-check?)
  (assert (or (null? binder) (is-binder? binder)))
  (assert (is-t-type-join? repr))
  (assert (boolean? type-check?))
  (let ((r-old-subreprs (tno-field-ref repr 'l-subtypes))
        (r-new-subreprs (car subreprs)))
    (if (or
         (eqv? r-new-subreprs r-old-subreprs)
         (and 
          (list? r-new-subreprs) (list? r-old-subreprs)
          (= (length r-new-subreprs) (length r-old-subreprs))
          (and-map? eqv? r-new-subreprs r-old-subreprs)))
      repr
      (construct-type-join-repr-fwd
       binder
       (make-type-join-object r-new-subreprs)))))


(set! cowb-type-join-fwd cowb-type-join)


(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-fwd
                         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))))))


;; Argument inside-param-def? is not used.
(define (translate-param-class-instance-expr binder param-class type-args
                                             inside-param-def?
                                             make-ctr?)
  (d2wl 'debug1000 "translate-param-class-instance-expr")
  ;; (d2wl 'debug1000 (tno-field-ref param-class 'str-name))
  (d2wl 'debug1000 (debug-get-string type-args))
  (assert (is-binder? binder))
  (assert (is-target-object? param-class))
  (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-fwd 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?)
       (d2wl 'debug1000 "translate-param-class-instance-expr/1")
       (d2wl 'debug1000 (debug-get-string type-arg-list))
       (d2wl 'debug1000 tuple?)
       (make-apti param-class type-args))
      (tuple?
       (d2wl 'debug1000 "translate-param-class-instance-expr/2")
       (let ((type-params (tuple-type->list-reject-cycles type-arg-list)))
         (cond
           ((is-incomplete-object? param-class)
            (d2wl 'debug93 "translate-param-class-instance-expr/2-1")
            (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	  
            (d2wl 'debug1000 "translate-param-class-instance-expr/2-2")
            (let ((to
                   (make-parametrized-class-instance1-fwd
                    binder param-class
                    type-params
                    make-ctr?)))
              (if (not (is-incomplete-object? to))
                (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)))
  
  (d2wl 'sgn1 "translate-param-sgn-instance-expr")
  (let ((address (hfield-ref param-sgn 'address)))
    (if (not-null? address)
      (d2wl 'sgn1 (hfield-ref address 'source-name))))
  (d2wl 'sgn1 (debug-get-string type-args))
  
  (let* ((type-arg-list (construct-toplevel-type-repr-fwd 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
           ((is-incomplete-object? param-sgn)
            (d2wl 'sgn1 "translate-param-sgn-instance-expr/1")
            (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
            (d2wl 'sgn1 "translate-param-sgn-instance-expr/2")
            (let ((to
                   (make-param-sgn-instance1-fwd
                    binder param-sgn
                    type-params
                    #f)))
              to)))))
      (else (raise 'invalid-param-signature-instance)))))


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


(set! translate-vector-expression0-fwd translate-vector-expression0)


(define (translate-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr-fwd
                         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))


(set! translate-mutable-vector-expression0-fwd
  translate-mutable-vector-expression0)


(define (translate-mutable-vector-expression binder member-type-list)
  (let* ((type-arg-list (construct-toplevel-type-repr-fwd
                         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-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-fwd 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
         ((is-incomplete-object? param-ltype)
          (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
                 (make-param-ltype-instance1-fwd
                  binder param-ltype
                  type-params
                  #f)))
            to))))
      (else
       ;; This is logically impossible.
       (raise 'internal-error)))))


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


(define (contains-type-modifiers0? item visited)
  (cond
    ((null? item) #f)
    ((memq item visited) #f)
    ((eq? item tc-class) #f)
    ((pair? item)
     (let ((new-visited (cons item visited)))
       (or (contains-type-modifiers0? (car item) new-visited)
           (contains-type-modifiers0? (cdr item) new-visited))))
    ((or
      (is-t-splice? item)
      (is-t-rest? item)
      (is-t-type-list? item)
      (is-t-type-loop? item)
      (is-t-type-join? item))
     #t)
    ((and (is-target-object? item) (is-incomplete-object? item))
     #f)
    (else
     (let ((subexprs (get-subexpressions-fwd item))
           (new-visited (cons item visited)))
       (or-map? (lambda (ent) (contains-type-modifiers0? ent new-visited))
                subexprs)))))


(define (contains-type-modifiers? item)
  (contains-type-modifiers0? item '()))


(set! contains-type-modifiers-fwd? contains-type-modifiers?)


(define (check-none-union tt l-visited)
  (cond
    ((memq tt l-visited) tt)
    ((and (is-tt-union? tt) (not (is-incomplete-object0? tt)))
     (let* ((l-member-types (tno-field-ref tt 'l-member-types))
            (l-new-visited (cons tt l-visited))
            (l-member-types2
             (map
              (lambda (tt2) (check-none-union tt2 l-new-visited))
              l-member-types)))
       (if (memq tt-none l-member-types2) tt-none tt)))
    (else tt)))

       
(define (nonoverwritten-type? to)
  (assert (is-target-object? to))
  (or (eq? to tt-none)
      (eq? (get-entity-type to) tc-class)
      (is-tt-unit-type? to)))


(set! nonoverwritten-type-fwd? nonoverwritten-type?)


