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


;; *** Type system ***


(define deduce-argument-types-fwd '())


(define get-all-free-tvars1-fwd '())


(define (disp cur-src cur-target)
  (d2wli 'deduce-argument-types "cur-src: ")
  (d2wli 'deduce-argument-types (debug-get-string cur-src))
  (d2wli 'deduce-argument-types "cur-target: ")
  (d2wli 'deduce-argument-types (debug-get-string cur-target)))
;;(define (disp cur-src cur-target) #f)


(define gl-i-ctr2 0)


(define *b-dbg-1* #f)


(define (d2wlin2 . args)
  (if *b-dbg-1* (apply d2wlin args)))


(define (debug-print-signature s-cat sgn)
  (let ((l-members (tno-field-ref sgn 'l-members)))
    (do ((l-cur l-members (cdr l-cur)) (i 1 (+ i 1))) ((null? l-cur))
      (let* ((p-cur (car l-cur))
             (ent-proc (car p-cur)))
        (assert (is-target-object? ent-proc))
        (d2wlin s-cat "signature member " i)
        (d2wlin s-cat "member type: "
                (debug-get-string (cdr p-cur)))
        (d2wli s-cat (debug-get-string ent-proc))
        (d2wli s-cat (debug-get-string (theme-class-of ent-proc)))
        (d2wli s-cat (target-object-number-of-fields ent-proc))
        (if (is-gen-proc? ent-proc)
          (do ((l-cur2 (tno-field-ref ent-proc 'l-methods) (cdr l-cur2))
               (i-method 1 (+ i-method 1)))
            ((null? l-cur2))
            (d2wlin s-cat "target method-type " i-method " : "
                    (debug-get-string (get-entity-type (caar l-cur2)))))
          (d2wlin s-cat "target procedure type: "
                  (debug-get-string (get-entity-type (car p-cur)))))))))


(define (get-applied-type-list arglist)
  (let ((tt (get-entity-type arglist)))
    (strong-assert (is-tuple-type0? tt))
    (tuple-type->list-reject-cycles tt)))


(define (eq-pairs? p1 p2)
  (and (eq? (car p1) (car p2))
       (eq? (cdr p1) (cdr p2))))


(define (make-tt-list . tt-members)
  (d2wl 'debug23 "make-tt-list")
  (d2wl 'debug23 tt-members)
  (assert (or (null? tt-members) (is-type0? (car tt-members))))
  (cond
    ((null? tt-members) tc-nil)
    ((pair? tt-members)
     (make-tpci-pair
      (car tt-members)
      (apply make-tt-list (cdr tt-members))))
    (else (raise 'make-tt-list:invalid-type))))


(define (is-t-nongeneric-proc-type? x)
  (or (is-tt-procedure? x)
      (is-tc-simple-proc? x)
      (is-tc-param-proc? x)))


(define (get-signature-target-types sgn)
  (assert (is-t-signature? sgn))
  (let* ((l-procs (map car (tno-field-ref sgn 'l-members)))
         (l-proc-types (map get-entity-type l-procs))
         ;; We want param. proc. type parameters here, too.
         (l-l-tvars (map get-all-free-tvars l-proc-types)))
    (remove-this
     (delete-duplicates1
      (apply append l-l-tvars) type-variable=?))))


(define (get-signature-declared-types sgn)
  (assert (is-t-signature? sgn))
  (let* ((l-proc-types (map cdr (tno-field-ref sgn 'l-members)))
         ;; We want param. proc. type parameters here, too.
         (l-l-tvars (map get-all-free-tvars l-proc-types)))
    (remove-this
     (delete-duplicates1
      (apply append l-l-tvars) type-variable=?))))


(define (tvar-table-get-final-tvars tvar-table)
  (list-set-diff (hfield-ref tvar-table 'l-all-tvars)
                 (hfield-ref tvar-table 'l-aux-tvars)
                 type-variable=?))


(define (is-empty? expr)
  (assert (is-entity? expr))
  (target-type=? (get-entity-type expr)
                 tt-none))


(define (is-method-object? x)
  (and (pair? x) (is-target-object? (car x)) (boolean? (cdr x))))


(define (make-ppc-tvars-unique binder to-ppc tvar-bindings lst-visited)
  (d2wli 'unique "make-ppc-tvars-unique ENTER")
  (d2wli 'unique (debug-get-string to-ppc))
  (d2wli 'unique (debug-get-string tvar-bindings))
  (assert (is-binder? binder))
  (assert (is-tc-param-proc? to-ppc))
  (assert (and (list? tvar-bindings)
               (for-all (lambda (p-binding)
                          (and (pair? p-binding)
                               (is-t-type-variable? (car p-binding))
                               (is-t-type-variable? (cdr p-binding))))
                        tvar-bindings)))
  (assert (is-sgt-al-tvar? *sgt-al-original*))
  (assert (list? lst-visited))
  (let* ((sgt (make-cycle-object-fwd to-ppc))
         (lst-new-visited (cons (cons to-ppc sgt) lst-visited))
         (l-old-tvars (map car tvar-bindings))
         (l-new-tvars (tno-field-ref to-ppc 'l-tvars))
         (i-nr-of-tvars (length l-new-tvars))
         (l-old-bindings
          (filter
           (lambda (p-binding)
             (not (member (car p-binding) l-new-tvars type-variable=?)))
           tvar-bindings))
         (l-new-tvars2 (make-type-variables binder i-nr-of-tvars))
         (l-new-bindings
          (map (lambda (tvar1 tvar2) (cons tvar1 tvar2))
               l-new-tvars l-new-tvars2)))
    (enclose-tvars
     i-nr-of-tvars
     (update-original-bindings! *sgt-al-original* l-new-bindings)
     (let* ((l-final-bindings (append l-old-bindings l-new-bindings))
            (l-final-tvars (map cdr l-final-bindings))
            ;;  (l-final-tvars0 (map cdr l-final-bindings))
            ;;  (l-final-tvars
            ;;   (union-of-lists *l-enclosing-ppc-tvars* l-final-tvars0 type-variable=?))
            (al-new-original (get-original-bindings *sgt-al-original* l-new-bindings))
            (x-processed-subexpr
             (fluid-let ((*l-enclosing-ppc-tvars* l-final-tvars))
               (make-tvars-unique20 binder
                                    (tno-field-ref to-ppc 'type-contents)
                                    l-final-bindings lst-new-visited)))
            (l-new-tvars2 (get-all-tvars x-processed-subexpr))
            ;;  (l-final-tvars1
            ;;   (filter
            ;;    (lambda (tvar)
            ;;     (member tvar l-new-tvars2 type-variable=?))
            ;;    l-final-tvars0))
            (tmp1
             (begin
              (d2wli 'unique "make-ppc-tvars-unique/1")
              (d2wli 'unique (debug-get-string l-new-tvars))
              (d2wli 'unique (debug-get-string l-final-bindings))
              ;; (d2wli 'unique (debug-get-string l-final-tvars0))
              (d2wli 'unique (debug-get-string l-final-tvars))
              #f))
            (to-ppc-new
             (make-param-proc-class-object
              (tno-field-ref to-ppc 'str-name)
              l-final-tvars
              x-processed-subexpr)))
       (d2wli 'unique "make-ppc-tvars-unique EXIT")
       (d2wli 'unique (debug-get-string to-ppc-new))
       to-ppc-new))))


(set! make-ppc-tvars-unique-fwd make-ppc-tvars-unique)


(define (rebind-object0 binder obj src target cycles)
  (assert (is-binder? binder))
  (let ((result
         (if (eq? obj src)
           target
           (let ((a (assq obj cycles)))
             (cond
               ((not (eq? a #f))
                (if (or (pair? obj) (is-expression? obj))
                  (raise 'illegal-cycle-5)
                  (cdr a)))
               ((null? obj) '())
               ((is-null-class-entity? obj) tc-nil)
               ((pair? obj)
                (let ((l-new-cycles (cons (cons obj #f) cycles)))
                  (let ((obj-head (rebind-object0 binder (car obj)
                                                  src target l-new-cycles))
                        (obj-tail (rebind-object0 binder (cdr obj)
                                                  src target l-new-cycles)))
                    (if (and (eq? obj-head (car obj))
                             (eq? obj-tail (cdr obj)))
                      obj
                      (cons obj-head obj-tail)))))
               ((is-target-object? obj)
                (let* ((sgt (make-cycle-object-fwd obj))
                       (l-new-cycles (cons (cons obj sgt) cycles))
                       (result
                        (let* ((subexprs (get-subexpressions-fwd obj))
                               (translated-subexprs
                                (map (lambda (subexpr)
                                       (if (not-null? subexpr)
                                         (rebind-object0
                                          binder subexpr
                                          src target l-new-cycles)
                                         '()))
                                     subexprs))
                               (result1
                                ;; We don't do type checks here.
                                ;; Otherwise we could have types with type
                                ;; variables to check (?).
                                (clone-with-branches-fwd
                                 binder obj
                                 translated-subexprs #f)))
                          (if (eq? obj result1)
                            obj
                            (if (nonoverwritten-type? result1)
                              result1
                              (begin
                               (update-cycle-object-fwd! sgt result1)
                               sgt))))))
                  result))
               ((is-entity? obj)
                (let* ((l-new-cycles (cons (cons obj #f) cycles))
                       (subexprs (get-subexpressions-fwd obj))
                       (translated-subexprs
                        (map (lambda (subexpr)
                               (if (not-null? subexpr)
                                 (rebind-object0 binder subexpr
                                                 src target l-new-cycles)
                                 '()))
                             subexprs))
                       (result1
                        ;; We don't do type checks here.
                        ;; Otherwise we could have types with type variables
                        ;; to check (?).
                        (clone-with-branches-fwd binder obj
                                                 translated-subexprs #f)))
                  result1))
               (else (raise 'rebind-object0:invalid-arguments)))))))
    
    (d2wi 'binding-addresses2 "rebind-object0 result: ")
    (d2wl 'binding-addresses2 (object-address result))
    
    result))


(define (rebind-object binder obj src target)
  (rebind-object0 binder obj src target '()))



;; Should we update marks here and return it?
(define (check-if-equal-types? binder marks t1 t2)
  (and
   (check-if-t-subtype? binder marks t1 t2)
   (check-if-t-subtype? binder marks t2 t1)))


(define (equal-types1? binder tt1 tt2)
  (cond
    ((and (is-t-type-variable? tt1) (is-t-type-variable? tt2))
     (type-variable=? tt1 tt2))
    ((or (is-t-type-variable? tt1) (is-t-type-variable? tt2))
     #f)
    (else (check-if-equal-types? binder '() tt1 tt2))))


(define (is-t-uniform-list-type3? 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))
          (not (is-incomplete-object? (car lst-members)))
          (equal-types1? binder (tt-cdr (car lst-members)) to)
          (eqv? (cadr lst-members) tc-nil)))))


(define (is-t-nonempty-uniform-list-type? binder to)
  (and
   (is-tc-pair? to)
   (let ((to-tail (tt-cdr to)))
     (and
      (is-t-uniform-list-type0? to-tail)
      (let ((l-members (tno-field-ref to-tail 'l-member-types)))
        (equal-types1?
         binder (tt-car (car l-members)) (tt-car to)))))))


(define (get-general-tuple-type-root-types repr)
  (cond
    ((eq? repr tc-nil) '())
    ((is-t-uniform-list-type0? repr) '())
    ((is-tc-pair? repr)
     (cons (tt-car repr) (get-general-tuple-type-root-types (tt-cdr repr))))
    (else
     (raise 'get-general-tuple-type-root-types:invalid-arg))))


(define (get-general-tuple-type-tail repr)
  (cond
    ((eq? repr tc-nil) '())
    ((is-t-uniform-list-type0? repr) repr)
    ((is-tc-pair? repr)
     (get-general-tuple-type-tail (tt-cdr repr)))
    (else
     (raise 'get-general-tuple-type-tail:invalid-arg))))


(define (proc-attr-inherit? pure1? always-returns1? never-returns1?
                            static-method1?
                            pure2? always-returns2? never-returns2?
                            static-method2?)
  (and (not (and (not pure1?) pure2?))
       (or (and (not always-returns2?) (not never-returns2?))
           (and
            (eq? always-returns1? always-returns2?)
            (eq? never-returns1? never-returns2?)))))


(define (is-t-general-proc-type? t)
  (or (is-tt-procedure? t) (is-tc-simple-proc? t)))


(define (is-t-param-class-instance? type)
  (let ((result
         (is-t-param-class? (get-entity-type type))))
    result))


(set! is-t-param-class-instance-fwd? is-t-param-class-instance?)


(define (is-t-param-ltype-inst? type)
  (assert (hrecord-is-instance? type <target-object>))
  (is-t-param-logical-type? (get-entity-type type)))


;; The following two procedures are not used.

(define (mark-exists-first? marks typ)
  (if (assv typ marks) #t #f))


(define (mark-exists-second? marks typ)
  (cond
    ((null? marks) #f)
    ((pair? marks)
     (or (eqv? typ (cdr (car marks)))
         (mark-exists-second? (cdr marks) typ)))
    (else (raise 'internal-type-error))))


;; We don't do recursion to nested types here.
;; So we don't need to check cycles.
;; Precondition: t1 has to be a class and t2 has to be a simple class.
(define (is-t-simple-class-subtype? t1 t2)
  (assert (is-type0? t1))
  (assert (is-type0? t2))
  (let ((result
         (cond
           ;; It may be unnecessary to check for incomplete and unknown objects
           ;; here since they are already checked in check-if-t-subtype?.
           ((or (is-incomplete-object? t1)
                (is-incomplete-object? t2))
            (raise 'cannot-type-check-incomplete-types-1))
           ((or (not (is-known-target-object1? t1))
                (not (is-known-target-object1? t2)))
            (raise 'cannot-type-check-unknown-types-1))
           ((eq? t1 t2) #t)
           ((eq? t2 tc-object) #t)
           ((eq? t1 tc-object) #f)
           (else (is-t-simple-class-subtype?
                  (tno-field-ref t1 'cl-superclass) t2)))))
    result))


;; We don't handle the case where the type of to is a union and
;; a subtype of tc-class.
(define (is-t-class? to)
  (let ((tt (get-entity-type to)))
    (and (not (is-tc-pair? tt))
         (not (is-tt-union? tt))
         (not (is-tt-unit-type? tt))
         (is-t-simple-class-subtype? tt tc-class))))


(set! is-t-class-fwd? is-t-class?)


(define (is-t-simple-class? to)
  (eq? (theme-class-of to) tc-class))


(define (is-t-general-class? to)
  (or (is-tc-pair? to) (is-t-class? to)))


(define (is-t-regular-class? to)
  (let ((tt-meta (get-entity-type to)))
    (and
     (or
      (eq? tt-meta tc-class)
      (and
       (not (is-tc-pair? tt-meta))
       (not (is-tt-union? tt-meta))
       (not (is-tt-unit-type? tt-meta))
       (is-t-simple-class-subtype? tt-meta tc-class)))
     (not (is-t-atomic-class? to))
     (not (eq? to tc-object))
     (not (is-tt-unit-type? to))
     (not (tno-field-ref to 'goops?)))))

       
(define (check-if-t-param-inst-equal? binder marks t1 t2)
  (d2wli 'subtyping "check-if-t-param-inst-equal?")
  (d2wli 'debug96 "check-if-t-param-inst-equal?")
  (assert (is-type0? t1))
  (assert (is-type0? t2))
  (let ((p1? (is-t-param-class-instance? t1))
        (p2? (is-t-param-class-instance? t2)))
    (cond
      ((and (not p1?) (not p2?))
       (eq? t1 t2))
      ((or (and (not p1?) p2?)
           (and p1? (not p2?)))
       #f)
      ((not (target-type=? (get-tobj-type t1) (get-tobj-type t2)))
       #f)
      (else
       (let* ((tvar-values1 (tno-field-ref t1 'l-param-exprs))
              (tvar-values2 (tno-field-ref t2 'l-param-exprs))
              (tvars1 (get-all-tvars-fwd tvar-values1))
              (tvars2 (get-all-tvars-fwd tvar-values2))
              (nr-of-tvars (length tvars1))
              (nr-of-params (length tvar-values1)))
         (if (and (= (length tvars2) nr-of-tvars)
                  (= (length tvar-values2) nr-of-params))
           ;; The substitution of the type variables may be unnecessary.
           ;; In fact, the substituted values are not used currently.
           (let ((new-tvars (make-type-variables binder nr-of-tvars)))
             (enclose-tvars nr-of-tvars
                            (let* ((bindings1 (map cons tvars1 new-tvars))
                                   (bindings2 (map cons tvars2 new-tvars))
                                   (new-tvar-values1
                                    (map*
                                     (lambda (repr1)
                                       (rebind-type-variables-no-check-fwd
                                        binder repr1 bindings1))
                                     tvar-values1))
                                   (new-tvar-values2
                                    (map*
                                     (lambda (repr2)
                                       (rebind-type-variables-no-check-fwd
                                        binder repr2
                                        bindings2))
                                     tvar-values2))
                                   (result
                                    (and (= (length new-tvar-values1)
                                            (length new-tvar-values2))
                                         (and-map?
                                          (lambda (tt1 tt2)
                                            (check-if-equal-types?
                                             binder marks tt1 tt2))
                                          tvar-values1 tvar-values2))))
                              result)))
           #f))))))


(set! check-if-t-param-inst-equal-fwd? check-if-t-param-inst-equal?)

;; Precondition: t1 and t2 have to be classes.
(define (check-if-t-param-inst-subclass? binder marks t1 t2)
  (d2wli 'subtyping4 "check-if-t-param-inst-subclass?")
  (d2wli 'subtyping4 (debug-get-string t1))
  (d2wli 'subtyping4 (debug-get-string t2))
  (assert (is-type0? t1))
  (assert (is-type0? t2))
  (cond
    ((eq? t2 tc-object) #t)
    ((eq? t1 tc-object) #f)
    ((check-if-t-param-inst-equal? binder marks t1 t2)
     (d2wli 'subtyping4 "check-if-t-param-inst-subclass?/1")
       #t)
    (else
     (check-if-t-param-inst-subclass? binder marks
                                      (tno-field-ref t1 'cl-superclass) t2))))


(define (check-if-t-subtype-x-union? binder marks t1 ut2)
  (d2wli 'subtyping6 "check-if-t-subtype-x-union?")
  (assert (is-type0? t1))
  (assert (is-type0? ut2))
  (let ((member-types (tno-field-ref ut2 'l-member-types))
        (result? #f))
    (do ((cur-list member-types (cdr cur-list)))
      ((or result? (null? cur-list)) result?)
      (if (check-if-t-subtype? binder marks
                               t1 (car cur-list))
        (set! result? #t)))))


(define (check-if-t-subtype-union-x? binder marks ut1 t2)
  (d2wli 'subtyping "check-if-t-subtype-union-x?")
  (assert (is-type0? ut1))
  (assert (is-type0? t2))
  (let ((member-types (tno-field-ref ut1 'l-member-types))
        (result? #t))
    (do ((cur-list member-types (cdr cur-list)))
      ((or (not result?) (null? cur-list)) result?)
      (if (not (check-if-t-subtype? binder marks
                                    (car cur-list) t2))
        (set! result? #f)))))


(define (check-if-t-pair-subclass? binder marks t1 t2)
  (d2wli 'subtyping "check-if-t-pair-subclass?")
  (assert (is-type0? t1))
  (assert (is-type0? t2))
  (let* ((first1 (tno-field-ref t1 'first))
         (second1 (tno-field-ref t1 'second))
         (first2 (tno-field-ref t2 'first))
         (second2 (tno-field-ref t2 'second)))
    (and (check-if-t-subtype? binder marks
                              first1 first2)
         (check-if-t-subtype? binder marks
                              second1 second2))))


(define (check-if-t-abstract-pair-subclass? binder marks t1 t2)
  (d2wli 'subtyping "check-if-t-abstract-pair-subclass?")
  (assert (is-abstract-pair? t1))
  (assert (is-abstract-pair? t2))
  (let* ((tvar-values1 (tno-field-ref t1 'l-type-args))
         (first1 (car tvar-values1))
         (second1 (cadr tvar-values1))
         (tvar-values2 (tno-field-ref t2 'l-type-args))
         (first2 (car tvar-values2))
         (second2 (cadr tvar-values2)))
    (and (check-if-t-subtype? binder marks
                              first1 first2)
         (check-if-t-subtype? binder marks
                              second1 second2))))

;; NOTE:
;; Contravariant inheritance for the argument list type
;; and covariant inheritance for the result type.
(define (check-if-t-proc-subtype? binder marks t1 t2)
  (d2wli 'subtyping "check-if-t-proc-subtype?")
  (assert (is-type0? t1))
  (assert (is-type0? t2))
  
  ;; TBR
  (d2wl 'debug43 "check-if-t-proc-subtype?")
  (d2wl 'debug43 (debug-get-string t1))
  (d2wl 'debug43 (debug-get-string t2))
  
  (let ((simple1? (is-tc-simple-proc? t1))
        (simple2? (is-tc-simple-proc? t2)))
    (if (not (and (not simple1?) simple2?))
      (let ((argl1 (tno-field-ref t1 'type-arglist))
            (argl2 (tno-field-ref t2 'type-arglist))
            (res1 (tno-field-ref t1 'type-result))
            (res2 (tno-field-ref t2 'type-result))
            (pure1? (tno-field-ref t1 'pure-proc?))
            (pure2? (tno-field-ref t2 'pure-proc?))
            (always-returns1? (tno-field-ref t1 'appl-always-returns?))
            (always-returns2? (tno-field-ref t2 'appl-always-returns?))
            (never-returns1? (tno-field-ref t1 'appl-never-returns?))
            (never-returns2? (tno-field-ref t2 'appl-never-returns?))
            (static-method1? (tno-field-ref t1 'static-method?))
            (static-method2? (tno-field-ref t2 'static-method?)))
        (d2wli 'subtyping "check-if-t-proc-subtype?/1")
        (assert (not (and always-returns1? never-returns1?)))
        (assert (not (and always-returns2? never-returns2?)))
        (and (proc-attr-inherit?
              pure1? always-returns1? never-returns1? static-method1?
              pure2? always-returns2? never-returns2? static-method2?)
             (check-if-t-subtype? binder marks
                                  argl2 argl1)
             ;; If procedure class A inherits from procedure class B
             ;; and the result type of B is none the result type of A
             ;; can be anything.
             (or (target-type=? res2 tt-none)
                 (check-if-t-subtype?
                  binder marks res1 res2))))
      #f)))


(define (do-check-t-param-proc-abst-proc? binder marks
          inst-type tpt-proc-type
          tvar-table
          src-tvars target-tvars)
  (d2wlin2 'subtyping-proc "do-check-t-param-proc-abst-proc? ENTER")
  (d2wlin2 'subtyping-proc (debug-get-string inst-type))
  (d2wlin2 'subtyping-proc (debug-get-string tpt-proc-type))
  (let* ((src-tvar-values (get-type-var-values-from-deductions-fwd
                           src-tvars tvar-table))
         (src-bindings (map cons src-tvars src-tvar-values))
         (inst-type2
          (bind-type-vars-fwd binder src-bindings inst-type))
         (target-tvar-values (get-type-var-values-from-deductions-fwd
                              target-tvars tvar-table))
         (target-bindings (map cons target-tvars target-tvar-values))
         (tpt-proc-type2
          (bind-type-vars-fwd binder target-bindings
                              tpt-proc-type))
         (src-arg-list-type (tno-field-ref inst-type2 'type-arglist))
         (target-arg-list-type (tno-field-ref tpt-proc-type2 'type-arglist))
         (src-result-type (tno-field-ref inst-type2 'type-result))
         (target-result-type (tno-field-ref tpt-proc-type2 'type-result))
         (tmp1
          (begin
           (d2wlin2 'subtyping-proc "do-check-t-param-proc-abst-proc?/1")
           (d2wlin2 'subtyping-proc (debug-get-string src-result-type))
           (d2wlin2 'subtyping-proc (debug-get-string target-result-type))
           (d2wlin2 'subtyping "do-check-t-param-proc-abst-proc?/2")
           (d2wlin2 'subtyping
                    (debug-get-string (tno-field-ref inst-type 'type-result)))
           (d2wlin2 'subtyping
                    (debug-get-string (tno-field-ref tpt-proc-type
                                                     'type-result)))
           (d2wlin2 'subtyping-proc "do-check-t-param-proc-abst-proc?/3")
           (d2wlin2 'subtyping-proc (debug-get-string src-arg-list-type))
           (d2wlin2 'subtyping-proc (debug-get-string target-arg-list-type))
           0))
         (res1?
          (or (target-type=? target-result-type tt-none)
              (check-if-t-subtype?
               binder
               marks
               src-result-type target-result-type)))
         (res2?
          ;; Note the order of types in the following expression.
          (check-if-t-subtype?
           binder
           marks
           target-arg-list-type src-arg-list-type))
         (result (and res1? res2?)))
    (d2wlin2 'subtyping-proc "do-check-t-param-proc-abst-proc? EXIT")
    (d2wlin2 'subtyping-proc result)
    (d2wlin2 'subtyping-proc res1?)
    (d2wlin2 'subtyping-proc res2?)
    result))


(define (check-t-param-proc-abst-proc? binder marks tc-param-proc tpt-proc-type)
  (d2wlin2 'subtyping-proc "check-t-param-proc-abst-proc? ENTER")
  (d2wlin2 'subtyping-proc (debug-get-string tc-param-proc))
  (d2wlin2 'subtyping-proc (debug-get-string tpt-proc-type))
  (assert (is-binder? binder))
  (assert (and (is-type0? tc-param-proc)
               (is-tc-param-proc? tc-param-proc)))
  (assert (and (is-type0? tpt-proc-type)
               (is-tt-procedure? tpt-proc-type)))
  (let* ((inst-type (tno-field-ref tc-param-proc 'type-contents))
         (abst-inst-type (simple->abstract-proc-type inst-type))
         (src-tvars (tno-field-ref tc-param-proc 'l-tvars))
         (target-tvars (get-all-tvars-fwd tpt-proc-type))
         (all-tvars (append src-tvars target-tvars))
         (tvar-table (get-new-type-var-assoc-table))
         (l-old-tvars (hfield-ref tvar-table 'l-all-tvars)))
    (hfield-set! tvar-table 'l-all-tvars
                 (union-of-lists all-tvars l-old-tvars type-variable=?))
    (let ((pure1? (tno-field-ref inst-type 'pure-proc?))
          (pure2? (tno-field-ref tpt-proc-type 'pure-proc?))
          (always-returns1? (tno-field-ref inst-type 'appl-always-returns?))
          (always-returns2? (tno-field-ref tpt-proc-type 'appl-always-returns?))
          (never-returns1? (tno-field-ref inst-type 'appl-never-returns?))
          (never-returns2? (tno-field-ref tpt-proc-type 'appl-never-returns?))
          (static-method1? (tno-field-ref inst-type 'static-method?))
          (static-method2? (tno-field-ref tpt-proc-type 'static-method?)))
      (if (not (proc-attr-inherit?
                pure1? always-returns1? never-returns1? static-method1?
                pure2? always-returns2? never-returns2? static-method2?))
        #f
        (begin
         ;; Formerly we have set fixed-tvars to null here.
         (d2wlin2 'caller1 "deduce-argument-types 6")
         (d2wlin2 'subtyping-proc "check-t-param-proc-abst-proc?/1")
         (set! gl-counter18 (+ gl-counter18 1))
         (d2wlin2 'subtyping-proc gl-counter18)
         ;;  (if (eqv? gl-counter18 4)
         ;;    (begin
         ;;     (d2wlin2 'debug138 "HEP")
         ;;     (set! gl-l-active-debug-categories
         ;;       (append gl-l-active-debug-categories '(deduce-argument-types type-deduction2)))))
         (d2wlin2 'subtyping-proc (debug-get-string abst-inst-type))
         (d2wlin2 'subtyping-proc (debug-get-string tpt-proc-type))
         (d2wlin2 'subtyping-proc (debug-get-string all-tvars))
         (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
           (deduce-argument-types-fwd binder tvar-table all-tvars
                                      abst-inst-type tpt-proc-type))
         (d2wlin2 'subtyping-proc "check-t-param-proc-abst-proc?/2")
         (d2wlin2 'subtyping-proc
                  (debug-get-string (hfield-ref tvar-table 'bindings)))
         (d2wlin2 'subtyping-proc
                  (debug-get-string (hfield-ref tvar-table 'l-all-tvars)))
         (d2wlin2 'subtyping-proc
                  (debug-get-string (hfield-ref tvar-table 'l-aux-tvars)))
         (let ((result
                (if (all-tvars-correct? tvar-table all-tvars)	
                  ;; (if (all-tvars-correct1? tvar-table)	
                  (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
                    (do-check-t-param-proc-abst-proc?
                      binder marks
                      inst-type tpt-proc-type
                      tvar-table
                      src-tvars target-tvars))
                  #f)))
           (d2wlin2 'subtyping-proc "check-t-param-proc-abst-proc? EXIT " result)
           result))))))
  
  
;; (define (check-if-t-param-proc-subclass? binder marks ppc1 ppc2)
;;   (d2wl 'debug158 "check-if-t-param-proc-subclass? ENTER")
;;   (assert (is-binder? binder))
;;   (assert (list? marks))
;;   (assert (is-tc-param-proc? ppc1))
;;   (assert (is-tc-param-proc? ppc2))
;;   (let* ((old-tvars1 (tno-field-ref ppc1 'l-tvars))
;;          (old-tvars2 (tno-field-ref ppc2 'l-tvars))
;;          (nr-of-tvars (length old-tvars1)))
;;     (if (eqv? (length old-tvars2) nr-of-tvars)
;;       (let* ((first-tvar-number (get-next-free-loc))
;;              (alloc-loc (hfield-ref binder 'allocate-variable))
;;              (tvars
;;               (map (lambda (i-number)
;;                      (make-tvar-with-number alloc-loc i-number))
;;                    (get-integer-sequence first-tvar-number
;;                                          nr-of-tvars))))
;;         (d2wl 'debug158 "check-if-t-param-proc-subclass?/1")
;;         (enclose-tvars
;;          nr-of-tvars
;;          (let* ((inst-type1 (tno-field-ref ppc1 'type-contents))
;;                 (tvar-bindings1 (map cons old-tvars1 tvars))
;;                 (inst-type-new1
;;                  (rebind-type-variables-no-check-fwd
;;                   binder inst-type1 tvar-bindings1))
;;                 (inst-type2 (tno-field-ref ppc2 'type-contents))
;;                 (tvar-bindings2 (map cons old-tvars2 tvars))
;;                 (inst-type-new2
;;                  (rebind-type-variables-no-check-fwd
;;                   binder inst-type2 tvar-bindings2))
;;                 (result (check-if-t-subtype?
;;                          binder marks
;;                          inst-type-new1 inst-type-new2)))
;;            (d2wl 'debug158 "check-if-param-proc-subclass? EXIT 1")
;;            result)))
;;       (begin
;;        (d2wl 'debug158 "check-if-param-proc-subclass? EXIT 2")
;;        #f))))


(define (check-if-t-subtype-gen-pp? binder marks gp pp)
  (d2wli 'subtyping "check-if-t-subtype-gen-pp?")
  (assert (is-binder? binder))
  (assert (and (is-type0? gp)
               (is-tc-gen-proc? gp)))
  (assert (and (is-type0? pp)
               (is-tc-param-proc? pp)))
  (let* ((method-classes (tno-field-ref gp 'l-method-classes))
         (found? #f)
         (res
          (do ((cur-lst method-classes (cdr cur-lst)))
            ((or (null? cur-lst) found?) found?)
            (if (equal-reprs1-fwd? binder (car cur-lst) pp)
              (set! found? #t)))))
    res))


(define (check-if-t-subtype-gen-abst? binder marks t1 t2)
  (d2wli 'subtyping4 "check-if-t-subtype-gen-abst? ENTER")
  (let ((method-classes (tno-field-ref t1 'l-method-classes))
        (result? #f))
    (d2wli 'subtyping4 (debug-get-string method-classes))
    (d2wli 'subtyping4 (length method-classes))
    (do ((cur-list method-classes (cdr cur-list)))
      ((or result? (null? cur-list)))
      (if (check-if-t-subtype? binder marks
                               (car cur-list) t2)
        (set! result? #t)))
    (d2wli 'subtyping4 "check-if-t-subtype-gen-abst? EXIT")
    (d2wli 'subtyping4 result?)
    result?))


(define (check-if-t-subtype-gen-gen? binder marks t1 t2)
  (d2wli 'subtyping "check-if-t-subtype-gen-gen?")
  (if (eq? (tno-field-ref t1 'virtual?) (tno-field-ref t2 'virtual?))
    (let* ((mc1 (tno-field-ref t1 'l-method-classes))
           (mc2 (tno-field-ref t2 'l-method-classes))
           (result2? #t)
           (result
            (do ((lst2 mc2 (cdr lst2)))
              ((or (null? lst2) (not result2?)) result2?)
              (if (not
                   (let ((result1? #f))
                     (do ((lst1 mc1 (cdr lst1)))
                       ((or (null? lst1) result1?) result1?)
                       (if (check-if-t-subtype? binder
                                                marks
                                                (car lst1)
                                                (car lst2))
                         (set! result1? #t)))))
                (set! result2? #f)))))
      result)
    #f))


(define (check-if-t-vector-subclass? binder marks tl1 tl2)
  (d2wli 'subtyping "check-if-t-vector-subclass?")
  (let ((mt1 (car (tno-field-ref tl1 'l-tvar-values)))
        (mt2 (car (tno-field-ref tl2 'l-tvar-values))))
    (check-if-t-subtype? binder marks mt1 mt2)))


(define (check-if-apti-subtype? binder marks t1 t2)
  (assert (is-t-apti? t1))
  (assert (is-t-apti? t2))
  (equal-reprs1-fwd? binder t1 t2))
;; (and
;;  (eqv? (tno-field-ref t1 'param-type)
;; 	 (tno-field-ref t2 'param-type))
;;  (equal-reprs-fwd? (tno-field-ref t1 'type-args)
;; 		     (tno-field-ref t2 'type-args))))


;; Argument sgn is not used.
(define (sgn-subst-member-type binder sgn member-type target-type)
  (assert (is-binder? binder))
  ;; (assert (is-type0? sgn))
  (assert (is-type0? member-type))
  (assert (is-type0? target-type))
  (let ((new-type (rebind-object binder member-type
                                 to-this target-type)))
    new-type))


(define (sgn-member-implemented? binder marks sgn member target-type)
  (d2wli 'subtyping-sgn "sgn-member-implemented? ENTER")
  (assert (is-binder? binder))
  (let* ((to (car member))
         (r-actual-type (get-entity-type to))
         (r-type (cdr member)))
    (let ((new-type
           (sgn-subst-member-type binder sgn r-type target-type)))
      (if (null? new-type)
        (raise 'internal-error-in-signature)
        (let ((b-result
               (check-if-t-subtype? binder marks
                                    r-actual-type new-type)))
          (d2wlin 'subtyping-sgn "sgn-member-implemented? EXIT " b-result)
          b-result)))))


(define (check-if-implements-signature? binder marks typ sgn)
  (d2wli 'subtyping-sgn "check-if-implements-signature? ENTER")
  ;; (debug-print-signature 'subtyping-sgn sgn)
  (assert (is-binder? binder))
  (assert (list? marks))
  (assert (is-type0? typ))
  (assert (and (is-target-object? sgn) (is-signature? sgn)))
  (let* ((members (tno-field-ref sgn 'l-members))
         (result
          (and-map? (lambda (member)
                      (sgn-member-implemented? binder marks
                                               sgn member typ))
                    members)))
    (d2wli 'subtyping-sgn "check-if-implements-signature? EXIT")
    result))


(define (check-if-subsignature? binder marks t1 t2)
  (d2wli 'subtyping-sgn "check-if-subsignature?")
  (assert (is-binder? binder))
  (assert (list? marks))
  (assert (is-signature? t1))
  (assert (is-signature? t2))
  (let ((l-members1 (tno-field-ref t1 'l-members))
        (l-members2 (tno-field-ref t2 'l-members))
        (match2? #t))
    (do ((l-cur2 l-members2 (cdr l-cur2)))
      ((or (null? l-cur2) (not match2?)))
      (let ((o-cur2 (car l-cur2))
            (match1? #f))
        (do ((l-cur1 l-members1 (cdr l-cur1)))
          ((or (null? l-cur1) match1?))
          (let ((o-cur1 (car l-cur1)))
            (if (and
                 (eq? (car o-cur1) (car o-cur2))
                 (check-if-t-subtype?
                  binder marks
                  (cdr o-cur1) (cdr o-cur2)))
              (set! match1? #t))))
        (if (not match1?) (set! match2? #f))))
    match2?))


(define (general-lists-subtype? binder marks lst1 lst2)
  (cond
    ((and (not (list? lst1)) (not (list? lst2)))
     (check-if-t-subtype? binder marks lst1 lst2))
    ((and (list? lst1) (list? lst2))
     (and (= (length lst1) (length lst2))
          (and-map?
           (lambda (t1 t2)
             (check-if-t-subtype? binder marks t1 t2))
           lst1 lst2)))
    (else #f)))


;; This procedure is used only in case the instances cannot
;; be parsed to a list. (?)
(define (check-if-t-param-ltype-inst-subtype? binder marks inst1 inst2)
  (if (eqv? (tno-field-ref inst1 'type-meta)
            (tno-field-ref inst2 'type-meta))
    (let* ((args1 (tno-field-ref inst1 'l-tvar-values))
           (args2 (tno-field-ref inst2 'l-tvar-values))
           (result
            (general-lists-subtype? binder marks args1 args2)))
      result)
    #f))


(define (check-if-t-splice-subtype? binder marks splice1 splice2)
  (let ((component1 (tno-field-ref splice1 'type-component))
        (component2 (tno-field-ref splice2 'type-component)))
    (check-if-t-subtype? binder marks component1 component2)))


(define (check-if-t-rest-subtype? binder marks rest1 rest2)
  (let ((component1 (tno-field-ref rest1 'type-component))
        (component2 (tno-field-ref rest2 'type-component)))
    (check-if-t-subtype? binder marks component1 component2)))


(define (check-if-t-type-list-subtype? binder marks lst1 lst2)
  (let* ((subtypes1 (tno-field-ref lst1 'l-subtypes))
         (subtypes2 (tno-field-ref lst2 'l-subtypes))
         (result
          (general-lists-subtype? binder marks subtypes1 subtypes2)))
    result))


(define (equal-loop-lists? binder lst1 lst2)
  (cond
    ((and (not (list? lst1)) (not (list? lst2)))
     (equal-reprs1-fwd? binder lst1 lst2))
    ((and (list? lst1) (list? lst2))
     (and (= (length lst1) (length lst2))
          (let ((my-eq? (lambda (lst3 lst4)
                          (equal-reprs1-fwd? binder lst3 lst4))))
            (and-map? my-eq? lst1 lst2))))
    (else #f)))


(define (check-if-t-loop-subtype? binder marks loop1 loop2)
  (let ((iter-var1 (tno-field-ref loop1 'tvar))
        (iter-var2 (tno-field-ref loop2 'tvar)))
    (if (type-variable=? iter-var1 iter-var2)
      (let ((subtypes1 (tno-field-ref loop1 'x-subtypes))
            (subtypes2 (tno-field-ref loop2 'x-subtypes))
            (iter-expr1 (tno-field-ref loop1 'x-iter-expr))
            (iter-expr2 (tno-field-ref loop2 'x-iter-expr)))
        (and (equal-loop-lists? binder subtypes1 subtypes2)
             (check-if-t-subtype? binder marks
                                  iter-expr1 iter-expr2)))
      (if (equal-loop-lists?
            binder
            (tno-field-ref loop1 'x-subtypes)
            (tno-field-ref loop2 'x-subtypes))
        (let* ((i-tvar-number (get-next-free-loc))
               (new-tvar (make-tvar-with-number binder i-tvar-number)))
          (enclose-tvars 1
                         (let* ((iter-expr1 (tno-field-ref loop1 'x-iter-expr))
                                (iter-expr2 (tno-field-ref loop2 'x-iter-expr))
                                (bindings1 (list (cons iter-var1 new-tvar)))
                                (bindings2 (list (cons iter-var2 new-tvar)))
                                (new-expr1 (rebind-type-variables-no-check-fwd
                                            binder iter-expr1 bindings1))
                                (new-expr2 (rebind-type-variables-no-check-fwd
                                            binder iter-expr2 bindings2)))
                           (check-if-t-subtype? binder marks
                                                new-expr1 new-expr2))))
        #f))))



(define (check-if-t-join-subtype? binder marks join1 join2)
  (let* ((subtypes1 (tno-field-ref join1 'l-subtypes))
         (subtypes2 (tno-field-ref join2 'l-subtypes))
         (result
          (general-lists-subtype? binder marks subtypes1 subtypes2)))
    result))


(define equal-pair-reprs? eqv?)


(define (do-subtyping-basic-checks binder marks-new t1 t2)
  (cond
    ((target-type=? t1 t2) #t)
    ((and (is-t-type-variable? t1) (is-t-type-variable? t2))
     (type-variable=? t1 t2))
    ((or (is-t-type-variable? t1) (is-t-type-variable? t2))
     #f)
    ((and (is-t-atomic-class? t1)
          (is-t-atomic-class? t2))
     (eq? t1 t2))
    (else '())))


(define (do-union-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (cond
    ((eq? tt-meta1 tmt-union)
     (check-if-t-subtype-union-x? binder marks-new
                                  t1 t2))
    ((eq? tt-meta2 tmt-union)
     (check-if-t-subtype-x-union? binder marks-new
                                  t1 t2))
    (else '())))


(define (do-subtyping-basic-checks2 binder marks-new t1 t2)
  (cond
    ;; <none> inherits only from <none>.
    ((target-type=? t1 tt-none)
     (target-type=? t2 tt-none))
    ;; No other type but <none> inherits from <none>.
    ((target-type=? t2 tt-none)
     (target-type=? t1 tt-none))
     ;; We know that t1 is not <none> here.
    ((target-type=? t2 tc-object)
     #t)
    ;; We know that t2 is not <object> here.
    ((target-type=? t1 tc-object)
     #f)
    (else '())))


;; Unit types are represented differently in the legacy translator and the RTE.
;; Hence we have to use is-tt-unit-type? here.
(define (do-unit-type-checks binder marks tt1 tt2)
  (d2wli 'subtyping6 "do-unit-type-checks ENTER")
  (d2wli 'subtyping6 (debug-get-string tt1))
  (d2wli 'subtyping6 (debug-get-string tt2))
  (let ((x-result
        (if (is-tt-unit-type? tt2)
          (begin
           (d2wli 'subtyping6 "do-unit-type-checks/1")
           (and (is-tt-unit-type? tt1)
                (equal-prim-objects?
                 (get-unit-type-component tt1)
                 (get-unit-type-component tt2))))
          (begin
           (d2wli 'subtyping6 "do-unit-type-checks/2")
           (if (is-tt-unit-type? tt1)
             (begin
              (d2wli 'subtyping6 "do-unit-type-checks/3")
              ;; We use eqv? to compare atomic objects.
              (eqv?
               ;; tt2 is not a unit type here.
               ;; Hence we need the class of the tt1 component value.
            ;;    (get-entity-type
            ;;     (get-unit-type-component tt1))
               (get-unit-type-class tt1)
               tt2))
             (begin 
              (d2wli 'subtyping6 "do-unit-type-checks/4")
              '()))))))
   (d2wlin 'subtyping6 "do-unit-type-checks EXIT " x-result)
    x-result))
       

(define (do-pair-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping "do-pair-checks")
  (let ((p1? (eq? tt-meta1 tc-pair))
        (p2? (eq? tt-meta2 tc-pair)))
    (cond
      ((or (and p1? (not p2?))
           (and (not p1?) p2?))
       #f)
      ((and p1? p2?)
       (check-if-t-pair-subclass? binder marks-new
                                  t1 t2))
      (else
       (let ((ap1? (is-abstract-pair1? t1))
             (ap2? (is-abstract-pair1? t2)))
         (cond
           ((or (and ap1? (not ap2?))
                (and (not ap1?) ap2?))
            #f)
           ((and ap1? ap2?)
            (check-if-t-abstract-pair-subclass? binder marks-new
                                                t1 t2))
           (else '())))))))


(define (do-proc-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping-proc "do-proc-checks ENTER")
  (d2wli 'subtyping-proc (debug-get-string t1))
  (d2wli 'subtyping-proc (debug-get-string t2))
  (let ((ap1? (eq? tt-meta1 tmt-procedure))
        (ap2? (eq? tt-meta2 tmt-procedure))
        (sp1? (eq? tt-meta1 tpc-simple-proc))
        (sp2? (eq? tt-meta2 tpc-simple-proc))
        (pp1? (eq? tt-meta1 tpc-param-proc))
        (pp2? (eq? tt-meta2 tpc-param-proc))
        (gp1? (eq? tt-meta1 tc-gen-proc))
        (gp2? (eq? tt-meta2 tc-gen-proc)))
    (let ((result
           (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
             (cond
               ((or (and ap1? sp2?) (and ap1? pp2?) (and sp1? pp2?)
                    (and pp1? sp2?)
                    (and gp1? sp2?)
                    (and ap1? gp2?) (and sp1? gp2?) (and pp1? gp2?))
                #f)
               ((or (and ap1? ap2?) (and sp1? ap2?) (and sp1? sp2?))
                (check-if-t-proc-subtype? binder marks-new
                                          t1 t2))
               ((and pp1? ap2?)
                (check-t-param-proc-abst-proc?
                 binder marks-new
                 t1 t2))
               ((and pp1? pp2?)
                (check-if-t-param-proc-subclass?
                 binder marks-new
                 t1 t2))
               ((and gp1? ap2?)
                (check-if-t-subtype-gen-abst?
                 binder marks-new
                 t1 t2))
               ((and gp1? gp2?)
                (check-if-t-subtype-gen-gen?
                 binder marks-new
                 t1 t2))
               ((and gp1? pp2?)
                (check-if-t-subtype-gen-pp?
                 binder marks-new
                 t1 t2))
               (else
                '())))))
      (d2wlin 'subtyping-proc "do-proc-checks EXIT " result)
      result)))


(define (do-vector-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping "do-vector-checks")
  (let ((uv1? (eq? tt-meta1 tpc-vector))
        (uv2? (eq? tt-meta2 tpc-vector)))
    (cond
      ((and uv1? uv2?)
       (check-if-t-vector-subclass?
        binder marks-new t1 t2))
      ((and uv1? (not uv2?))
       #f)
      ((and (not uv1?) uv2?)
       #f)
      (else '()))))


(define (do-signature-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (let ((sgn1? (eq? tt-meta1 tc-signature))
        (sgn2? (eq? tt-meta2 tc-signature)))
    (cond
      ((and (not sgn1?) sgn2?)
       (check-if-implements-signature?
        binder marks-new t1 t2))
      ((and sgn1? sgn2?)
       (check-if-subsignature?
        binder marks-new t1 t2))
      ((and sgn1? (not sgn2?) (eq? tt-meta2 tmt-union))
       (check-if-t-subtype-x-union? binder marks-new t1 t2))
      ((and sgn1? (eq? t2 tc-object))
       #t)
      ((and sgn1? (not sgn2?))
       #f)
      (else '()))))


(define (do-modifier-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping "do-modifier-checks")
  (cond
    ((eq? tt-meta2 tc-splice)
     (if (eq? tt-meta1 tc-splice)
       (check-if-t-splice-subtype?
        binder marks-new t1 t2)
       #f))
    ((eq? tt-meta2 tc-rest)
     (if (eq? tt-meta1 tc-rest)
       (check-if-t-rest-subtype?
        binder marks-new t1 t2)
       #f))
    ((eq? tt-meta2 tc-type-list)
     (if (eq? tt-meta1 tc-type-list)
       (check-if-t-type-list-subtype?
        binder marks-new t1 t2)
       #f))
    ((eq? tt-meta2 tc-type-loop)
     (if (eq? tt-meta1 tc-type-loop)
       (check-if-t-loop-subtype?
         binder marks-new t1 t2)
       #f))
    ((eq? tt-meta2 tc-type-join)
     (if (eq? tt-meta1 tc-type-join)
       (check-if-t-join-subtype?
        binder marks-new t1 t2)
       #f))
    (else '())))


(define (do-apti-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping "do-apti-checks")
  (let ((apti1? (eq? tt-meta1 tc-abstract-param-type-inst))
        (apti2? (eq? tt-meta2 tc-abstract-param-type-inst)))
    (cond
      ((and apti1? apti2?)
       (check-if-apti-subtype? binder marks-new t1 t2))
      ((not (eq? apti1? apti2?))
       #f)
      (else '()))))


(define (do-rest-checks binder marks-new tt-meta1 tt-meta2 t1 t2)
  (d2wli 'subtyping4 "do-rest-checks")
  (let ((inst1? (eq? (get-entity-type tt-meta1) t-param-class))
        (inst2? (eq? (get-entity-type tt-meta2) t-param-class))
        (cl1? (is-t-class? t1))
        (cl2? (is-t-class? t2))
        (this1? (eq? t1 to-this))
        (this2? (eq? t2 to-this)))
    (assert (not (and inst1? (not cl1?))))
    (assert (not (and inst2? (not cl2?))))
    (d2wli 'subtyping4 "do-rest-checks/1")
    (cond
      ((and cl1? inst2?)
       (check-if-t-param-inst-subclass?
        binder marks-new t1 t2))
      ((and cl1? cl2?)
       ;; We know that t2 is not a parametrized class instance here.
       (is-t-simple-class-subtype?
        t1 t2))
      ((and this1? this2?) #t)
      ((or this1? this2?) #f)
      (else
       #f))))


(define (check-if-t-subtype? binder marks t1 t2)
  (assert (is-binder? binder))
  (assert (and (list? marks) (for-all pair? marks)))
  (fluid-let ((gl-i-indent (+ gl-i-indent 1))
              (*b-dbg-1* #t))
    ;; (if *b-dbg-1*
    ;;   (begin
    ;;    (set! gl-counter20 (+ gl-counter20 1))
    ;;    (d2wli 'subtyping3 gl-counter20)
    ;;    (d2wli 'subtyping3 "check-if-t-subtype?")))
    (let ((unit1? (is-tt-unit-type? t1))
          (unit2? (is-tt-unit-type? t2)))
      (cond
        ((eqv? t1 t2) #t)
        ((or (and (not unit1?) (not (is-target-object? t1)))
             (and (not unit2?) (not (is-target-object? t2))))
         (raise 'invalid-type-in-subtype-check))
        ((or (and (not unit1?) (is-incomplete-object0? t1))
             (and (not unit2?) (is-incomplete-object0? t2)))
         ;;      (raise 'cannot-type-check-incomplete-types-2))
         (eq? t1 t2))
        ((or (and (not unit1?) (not (is-known-target-object2? t1)))
             (and (not unit2?) (not (is-known-target-object2? t2))))
         (d2wl 'debug25 "check-if-t-subtype?/1-1")
         (d2wl 'debug25 t1)
         (d2wl 'debug25 t2)
         (raise 'cannot-type-check-unknown-types-2))
        (else
         ;;    (d2wli 'subtyping3 "check-if-t-subtype?/2")
         ;;    (if *b-dbg-1*
         ;;      (begin
         ;;       (d2wli 'subtyping2 "check-if-t-subtype?/2-1")
         ;;       (d2wlin 'subtyping2 "t1: " (debug-get-string t1))
         ;;       (d2wlin 'subtyping2 "t2: " (debug-get-string t2))))
         (if (member (cons t1 t2) marks eq-pairs?)
           (begin
            #t)
           (begin
            ;; (d2wli 'subtyping3 "check-if-t-subtype?/3")
            (let* ((marks-new (cons (cons t1 t2) marks))
                   (t1-2 (check-none-union t1 '()))
                   (t2-2 (check-none-union t2 '()))
                   (res1 (do-subtyping-basic-checks binder marks-new t1-2 t2-2))
                   (tt-meta1 (get-entity-type t1-2))
                   (tt-meta2 (get-entity-type t2-2))
                   (res2 (if (boolean? res1)
                           res1
                           (do-signature-checks binder marks-new
                                                tt-meta1 tt-meta2 t1-2 t2-2)))
                   (res3 (if (boolean? res2)
                           res2
                           (do-union-checks binder marks-new
                                            tt-meta1 tt-meta2 t1-2 t2-2)))
                   (res4 (if (boolean? res3)
                           res3
                           (do-subtyping-basic-checks2 binder marks-new
                                                       t1-2 t2-2)))
                   ;; Unit types have to be checked after unions.  
                   (res5 (if (boolean? res4)
                           res4
                           (do-unit-type-checks binder marks-new
                                                t1-2 t2-2)))
                   (tmp1 (begin (d2wli 'debug1001 "HEP1") #f))
                   (res6 (if (boolean? res5)
                           res5
                           (do-pair-checks binder marks-new
                                           tt-meta1 tt-meta2 t1-2 t2-2)))
                   (tmp2 (begin (d2wli 'debug1001 "HEP2") #f))
                   (res7 (if (boolean? res6)
                           res6
                           (do-proc-checks binder marks-new
                                           tt-meta1 tt-meta2 t1-2 t2-2)))
                   (tmp3 (begin (d2wli 'debug1001 "HEP3") #f))
                   (res8 (if (boolean? res7)
                           res7
                           (do-vector-checks binder marks-new
                                             tt-meta1 tt-meta2 t1-2 t2-2)))
                   (tmp4 (begin (d2wli 'debug1001 "HEP4") #f))
                   (res9 (if (boolean? res8)
                           res8
                           (do-apti-checks binder marks-new
                                           tt-meta1 tt-meta2 t1-2 t2-2)))
                   (tmp5 (begin (d2wli 'debug1001 "HEP5") #f))
                   (res10 (if (boolean? res9)
                            res9
                            (do-modifier-checks binder marks-new
                                                tt-meta1 tt-meta2 t1-2 t2-2)))
                   (tmp6 (begin (d2wli 'debug1001 "HEP6") #f))
                   (res11 (if (boolean? res10)
                            res10
                            (do-rest-checks binder marks-new
                                            tt-meta1 tt-meta2 t1-2 t2-2))))
              ;; (if *b-dbg-1* (d2wlin 'subtyping2 "check-if-t-subtype? EXIT " res11))
              (dummy #f) ;; for profiling
              res11))))))))
  

(set! check-if-t-subtype-fwd? check-if-t-subtype?)


;; NOTE: This procedure is allowed to return #f in case
;; t1 is a subtype of t2.
(define (is-t-subtype? binder t1 t2)
  (assert (is-binder? binder))
  (check-if-t-subtype? binder '() t1 t2))


(set! is-t-subtype-fwd? is-t-subtype?)


(define (equal-types? binder t1 t2)
  (and (is-t-subtype? binder t1 t2) (is-t-subtype? binder t2 t1)))


(define (is-t-instance? binder to tc)
  (assert (is-binder? binder))
  (is-t-subtype? binder
                 (get-entity-type2 to)
                 tc))


;; (cond
;;  ((eq? tc tc-object) #t)
;;  ((eq? tc tc-nil) (or (null? to) (eqv? to to-nil)))
;;  ((eq? tc tc-char) (char? to))
;;  ((eq? tc tc-real) (is-real? to))
;;  ((eq? tc tc-integer) (is-integer? to))
;;  ((eq? tc tc-boolean) (boolean? to))
;;  ((eq? tc tc-symbol) (symbol? to))
;;  ((eq? tc tc-string) (string? to))
;;  ;; Calling get-object-value is needed because some type fields
;;  ;; may contain variables.
;;  (else (is-t-subtype? binder
;; 			(get-entity-type to)
;; 			tc))))


(set! is-t-instance-fwd? is-t-instance?)


(define (is-object-list-type? x)
  (and (is-t-uniform-list-type0? x)
       (eq? (get-uniform-list-param0 x) tc-object)))

       
(define (is-uniform-proc-class? binder x)
  (and (or (is-tt-procedure? x) (is-tc-simple-proc? x))
       (equal-types? binder (tno-field-ref x 'type-result) tc-object)
       (let ((type-arglist (tno-field-ref x 'type-arglist)))
         (and (is-t-uniform-list-type0? type-arglist)
              (eq? (get-uniform-list-param0 type-arglist)
                   tc-object)))))


(define (is-simple-uniform-proc-class? binder x)
  (and (is-tc-simple-proc? x)
       (equal-types? binder (tno-field-ref x 'type-result) tc-object)
       (let ((type-arglist (tno-field-ref x 'type-arglist)))
         (and (is-t-uniform-list-type0? type-arglist)
              (eq? (get-uniform-list-param0 type-arglist)
                   tc-object)))))


(define (is-abstract-uniform-proc-class? binder x)
  (and (is-tt-procedure? x)
       (equal-types? binder (tno-field-ref x 'type-result) tc-object)
       (let ((type-arglist (tno-field-ref x 'type-arglist)))
         (and (is-t-uniform-list-type0? type-arglist)
              (eq? (get-uniform-list-param0 type-arglist)
                   tc-object)))))


(define (vector-copy-contents src dest)
  (let ((len1 (vector-length src))
        (len2 (vector-length dest)))
    (assert (= len1 len2))
    (do ((i 0 (+ i 1))) ((>= i len1))
      (vector-set! dest i (vector-ref src i)))))


(define (count-true v)
  (let ((len (vector-length v))
        (count 0))
    (do ((i 0 (+ i 1))) ((>= i len) count)
      (if (eq? (vector-ref v i) #t)
        (set! count (+ count 1))))))


(define (vector-count-nonfalse v)
  (let ((len (vector-length v))
        (count 0))
    (do ((i 0 (+ i 1))) ((>= i len) count)
      (if (vector-ref v i)
        (set! count (+ count 1))))))


(define (is-final-class0? binder typ l-visited)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? typ <target-object>))
  (dvar1-set! typ)
  (cond
    ((memq typ l-visited) #f)
    ((eq? typ tc-procedure) #f)
    ((not (is-t-general-class? typ)) #f)
    ;; ((eq? typ tc-nil) #t)
    ;; Unit types may be dispatched by their component class.
    ((is-t-atomic-class? typ) #t)
    ;; Unit types are final.
    ((is-tt-unit-type? typ) #t)
    ((is-tc-gen-proc? typ) #f)
    ((is-tc-pair? typ)
     (let ((l-new-visited (cons typ l-visited)))
       (and
        (is-final-class0? binder (get-pair-first-type typ) l-new-visited)
        (is-final-class0? binder (get-pair-second-type typ) l-new-visited))))
    ((is-tc-vector? typ)
     (let ((tt-comp (car (tno-field-ref typ 'l-tvar-values))))
       (is-final-class0? binder tt-comp (cons typ l-visited))))
    ((tno-field-ref typ 'inheritable?) #f)
    (else #t)))


;; The following procedure is allowed to return #f
;; also for noninheritable types.
(define (is-final-class? binder typ)
  (is-final-class0? binder typ '()))


(define (all-types-final? binder types)
  (and-map?
   (lambda (type)
     (is-final-class? binder type))
   types))


(define (get-matching-index matches)
  (let ((len (vector-length matches))
        (index -1))
    (do ((i 0 (+ i 1))) ((>= i len) index)
      (if (vector-ref matches i)
        (set! index i)))))


(define (get-item-at-index fixed-args rest-arg n)
  (if (< n 0)
    (raise 'internal-negative-index))
  (let ((len (length fixed-args)))
    (if (< n len)
      (list-ref fixed-args n)
      (if (is-empty? rest-arg)
        (raise 'internal-index-out-of-range)
        rest-arg))))


(define (reject-by-length binder n v-arg-list-descs vb-included)
  (let ((k (vector-length v-arg-list-descs)))
    (assert (= k (vector-length vb-included)))
    (do ((j 0 (+ j 1))) ((>= j k) vb-included)
      (if (vector-ref vb-included j)
        (let* ((cur-list-desc (vector-ref v-arg-list-descs j))
               (cur-type-list
                (if (is-t-type-list? cur-list-desc)
                  cur-list-desc
                  (begin
                   (d2wl 'debug24 "reject-by-length/1")
                   (d2wl 'debug24 cur-list-desc)
                   (assert (is-general-tuple-type0-fwd? cur-list-desc))
                   (gen-tuple-type->type-list-fwd binder cur-list-desc))))
               (cur-descs (tno-field-ref cur-type-list 'l-subtypes))
               (cur-len (length cur-descs))
               (has-rest?
                (and (>= cur-len 1)
                     (is-t-rest? (last cur-descs)))))
          (if (not (or (and (not has-rest?) (= n cur-len))
                       (and has-rest? (>= n (- cur-len 1)))))
            (vector-set! vb-included j #f)))))))


(define (reject-mismatches binder
                           argl-type v-arg-list-types vb-included)
  (assert (is-binder? binder))
  (d2wl 'debug1023 "reject-mismatches")
  (d2wl 'debug1023 (debug-get-string argl-type))
  (let ((n (vector-length v-arg-list-types)))
    (d2wl 'debug48 n)
    (assert (= (vector-length vb-included) n))
    (do ((i 0 (+ i 1))) ((>= i n))
      (d2wl 'debug1023 "reject-mismatches/1")
      (d2wl 'debug1023 i)
      (d2wl 'debug1023 (debug-get-string (vector-ref v-arg-list-types i)))
      (let ((cur-target-arg-list (vector-ref v-arg-list-types i)))
        ;; Testataan vb-included, jotta vältetään turhia
        ;; funktion is-t-subtype? kutsuja.
        (if (or (not cur-target-arg-list)
                (not (vector-ref vb-included i))
                (not (is-t-subtype? binder
                                    argl-type
                                    cur-target-arg-list)))
          (begin 
           (d2wl 'debug1023 "reject-mismatches/2")
           (vector-set! vb-included i #f)))))))


(define (check-contravariant-inheritance binder
                                         type i v-fixed-args v-rest vb-inh
                                         vb-included)
  (assert (is-binder? binder))
  (let ((k (vector-length vb-inh)))
    (do ((j 0 (+ j 1))) ((>= j k))
      (if (and
           (vector-ref vb-included j)
           (is-t-subtype? binder
                          (get-item-at-index (vector-ref v-fixed-args j)
                                             (vector-ref v-rest j)
                                             i)
                          type))
        (vector-set! vb-inh j #t)
        (vector-set! vb-inh j #f)))))


(define (method-loop binder
          index v-fixed-args v-rest-arg vb-included t1 i n)
  (do ((j 0 (+ j 1))) ((>= j n))
    (if (and (not (= i j))
             (vector-ref vb-included j))
      (let ((t2 (get-item-at-index
                 (vector-ref v-fixed-args j)
                 (vector-ref v-rest-arg j)
                 index)))
        (if (and (is-t-subtype? binder t1 t2)
                 (not (is-t-subtype? binder t2 t1)))
          ;; t2 is excluded
          (vector-set! vb-included j #f))))))


(define (select-nearest-methods binder
                                index v-fixed-args v-rest-arg vb-included)
  (assert (is-binder? binder))
  (let ((n (vector-length vb-included)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (if (vector-ref vb-included i)
        (let ((t1 (get-item-at-index
                   (vector-ref v-fixed-args i)
                   (vector-ref v-rest-arg i)
                   index)))
          (method-loop binder index v-fixed-args v-rest-arg vb-included
            t1 i n))))))


(define (parse-arg-list binder arg-list-desc)
  (if (eq? arg-list-desc #f)
    #f
    (let* ((arg-list
            (if (is-t-type-list? arg-list-desc)
              arg-list-desc
              (begin
               (assert (is-general-tuple-type0-fwd? arg-list-desc))
               (gen-tuple-type->type-list-fwd binder arg-list-desc))))
           (arg-descs (tno-field-ref arg-list 'l-subtypes))
           (len (length arg-descs))
           (has-rest? (and (>= len 1)
                           (is-t-rest? (last arg-descs)))))
      (if has-rest?
        (cons (drop-right arg-descs 1) (last arg-descs))
        (cons arg-descs tt-none)))))


(define (parse-arg-lists binder v-arg-list-descs)
  (vector-map (lambda (i desc) (parse-arg-list binder desc))
              v-arg-list-descs))


(define (select-best-methods-for-arg binder
                                     type i v-fixed-args v-rest vb-included)
  ;; The following call may be unnecessary.
  ;; (select-applicable-methods type i v-fixed-args v-rest vb-included)
  (let* ((m-count (vector-length v-fixed-args))
         (vb-inh (make-vector m-count #f)))
    (check-contravariant-inheritance binder
                                     type i v-fixed-args v-rest vb-inh
                                     vb-included)
    (let* ((vb-exact (vector-map
                      (lambda (i b1 b2) (and b1 b2))
                      vb-included vb-inh))
           (exact-match? #f))
      ;; Previously we had the stopping condition
      ;; (or (>= j m-count) exact-match?)
      (do ((j 0 (+ j 1))) ((>= j m-count))
        (if (vector-ref vb-exact j)
          (set! exact-match? #t)))
      (if exact-match?
        (vector-copy-contents vb-exact vb-included)
        ;; (select-nearest-method type i v-fixed-args v-rest vb-included)))))
        (select-nearest-methods binder
                                i v-fixed-args v-rest vb-included)))))


(define (car1 i obj)
  (assert (or (pair? obj) (boolean? obj)))
  (if (eq? obj #f) #f (car obj)))


(define (cdr1 i obj)
  (assert (or (pair? obj) (boolean? obj)))
  (if (eq? obj #f) #f (cdr obj)))


(define (do-select-best-methods binder
          vb-included v-argl v-arg-list-descs)
  (assert (is-binder? binder))
  (let* ((argl (parse-arg-lists binder v-arg-list-descs))
         (v-fixed-args (vector-map car1 argl))
         (v-rest-args (vector-map cdr1 argl)))
    (let ((n (vector-length v-argl))
          (unique-solution? #f))
      (do ((k 0 (+ k 1))) ((or (>= k n) unique-solution?))
        (select-best-methods-for-arg binder
                                     (vector-ref v-argl k) k
                                     v-fixed-args v-rest-args vb-included)
        (let ((c (vector-count (lambda (i item) (eqv? item #t))
                               vb-included)))
          ;; If we have zero or one method candidates left it makes no sense
          ;; to continue the iteration.
          (if (or (= c 0) (= c 1))
            (set! unique-solution? #t)))))))


(define (reject-incompatible-param method-classes vb-included)
  (let ((len (vector-length vb-included)))
    (assert (= (length method-classes) len))
    (do ((i 0 (+ i 1)) (cur-lst method-classes (cdr cur-lst)))
      ((or (>= i len) (null? cur-lst)))
      (if (eq? (car cur-lst) #f)
        (vector-set! vb-included i #f)))))


(define (get-indices vec)
  (assert (and (vector? vec) (vector-every boolean? vec)))
  (let ((indices '())
        (len (vector-length vec)))
    (do ((i 0 (+ i 1))) ((>= i len) indices)
      (if (vector-ref vec i)
        (set! indices (append indices (list i)))))))


(define (select-best-method0 binder argl method-classes0 method-classes)
  (assert (is-binder? binder))
  (d2wli 'select-best-method0 "select-best-method0 ENTER")
  (d2wli 'select-best-method0 (debug-get-string argl))
  (let ((argl1
         (cond
           ((list? argl) argl)
           ((is-tuple-type-fwd? binder argl)
            (tuple-type->list-reject-cycles-fwd argl))
           (else
            #f)))
        (i-count (length method-classes)))
    (cond
      ((= i-count 1)
       (d2wli 'select-best-method0 "select-best-method0/1")
       (dvar1-set! argl1)
       (let ((mtc (car method-classes)))
         
         ;; TBR
         ;; (d2wl 'debug43 (debug-get-string mtc))
         ;; (set! gl-counter26 (+ gl-counter26 1))
         ;; (d2wl 'debug43 gl-counter26)
         ;; (dvar1-set! mtc)
         ;; (raise 'stop-mtc)
         
         (if mtc
           (begin
            (d2wli 'select-best-method0 "select-best-method0/1-1")
            (d2wli 'select-best-method0 (debug-get-string (car method-classes0)))
            (let* ((tt-method-args (tno-field-ref mtc 'type-arglist))
                   (tt-arglist
                    (if argl1 (apply make-tt-list argl1) argl)))
              (d2wli 'select-best-method0 (debug-get-string tt-method-args))
              (d2wli 'select-best-method0 (debug-get-string tt-arglist))
              ;; Runtime environment takes care of typechecking
              ;; parametrized procedure calls.
              (let ((mtc0 (car method-classes0)))
                (if (or (is-tc-param-proc? mtc0)
                        (contains-free-tvars-fwd? mtc0)
                        (is-t-subtype? binder tt-arglist tt-method-args))
                  '(0)
                  '()))))
           (begin
            (d2wli 'select-best-method0 "select-best-method0/1-2")
            '()))))
      ((= i-count 0) '())
      (else
       (d2wli 'select-best-method0 "select-best-method0/2")
       (if argl1
         (let* ((v-argl (list->vector argl1))
                (arg-list-types
                 (map
                  (lambda (mtc)
                    (if (not (eq? mtc #f))
                      (tno-field-ref mtc 'type-arglist)
                      #f))
                  method-classes))
                (v-arg-list-types
                 (list->vector arg-list-types))
                (argl-type (apply make-tt-list argl1)))
           (d2wli 'select-best-method0 "select-best-method0/2-1")
           (let* ((argcount (vector-length v-argl))
                  (m-count (vector-length v-arg-list-types))
                  (vb-included (make-vector m-count #t)))
             (d2wli 'select-best-method0 "select-best-method0/2-2")
             (d2wli 'select-best-method0 (vector-count-nonfalse vb-included))
             (reject-incompatible-param method-classes vb-included)
             (d2wli 'select-best-method0 "select-best-method0/2-3")
             (d2wli 'select-best-method0 (vector-count-nonfalse vb-included))
             (reject-by-length binder argcount v-arg-list-types
                               vb-included)
             (d2wli 'select-best-method0 "select-best-method0/2-4")
             (d2wli 'select-best-method0 (vector-count-nonfalse vb-included))
             (reject-mismatches binder argl-type v-arg-list-types vb-included)
             (d2wli 'select-best-method0 "select-best-method0/2-5")
             (d2wli 'select-best-method0 (vector-count-nonfalse vb-included))
             (do-select-best-methods binder
               vb-included
               v-argl
               v-arg-list-types)
             (get-indices vb-included)))
         (let* ((vb-included (make-vector i-count #t))
                (arg-list-types
                 (map
                  (lambda (mtc)
                    (if (not (eq? mtc #f))
                      (tno-field-ref mtc 'type-arglist)
                      #f))
                  method-classes))
                (v-arg-list-types
                 (list->vector arg-list-types)))
           (reject-mismatches binder argl v-arg-list-types vb-included)
           (get-indices vb-included)))))))


(define (get-nonfixed-tvars all-tvars fixed-tvars)
  (filter
   (lambda (tvar)
     (not (member tvar fixed-tvars type-variable=?)))
   all-tvars))


(define (process-param-method binder argl mtc)
  (d2wli 'process-param-method "process-param-method")
  (d2wli 'process-param-method (debug-get-string argl))
  (d2wli 'process-param-method (debug-get-string mtc))
  (assert (is-binder? binder))
  (assert (is-tc-param-proc? mtc))
  ;; Should we check for bound type variables in the arguments?
  ;; Can method-tvars and argument-tvars overlap?
  (let* ((fixed-tvars (hfield-ref binder 'fixed-tvars))
         (arg-tvars0 (get-all-free-tvars-fwd argl))
         (arg-tvars (get-nonfixed-tvars arg-tvars0 fixed-tvars))
         (mtc-tvars (get-all-tvars mtc))
         (p-uniq (make-tvars-unique-fwd binder mtc-tvars mtc))
         (mtc2 (car p-uniq))
         ;; (mtc2 (make-tvars-unique2 binder mtc))
         (mtc2-tvars (cdr p-uniq))
         (al-tvars (map cons mtc2-tvars mtc-tvars))
         (all-tvars (append arg-tvars mtc2-tvars))
         (all-nonfixed-tvars (get-nonfixed-tvars all-tvars fixed-tvars))
         (tvar-table (get-new-type-var-assoc-table))
         (arg-list-type (tno-field-ref (tno-field-ref mtc2 'type-contents)
                                       'type-arglist)))
    (assert (eqv? (length mtc-tvars) (length mtc2-tvars)))
    (if (not-null? all-tvars)
      (begin
       
       ;; TBR
       (d2wli 'process-param-method "process-param-method/1")
       (d2wli 'process-param-method (debug-get-string arg-list-type))
       (d2wli 'process-param-method (debug-get-string mtc-tvars))
       (d2wli 'process-param-method (debug-get-string mtc))
       (d2wli 'process-param-method (debug-get-string mtc2))
       (d2wli 'process-param-method1 (debug-get-string all-tvars))
       (d2wli 'process-param-method1
              (debug-get-string (hfield-ref binder 'fixed-tvars)))
       
       (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
         (d2wli 'caller1 "deduce-argument-types 7")
         (deduce-argument-types-fwd binder tvar-table all-tvars
                                    argl arg-list-type)
         #f)
       
       (d2wlin 'process-param-method "process-param-method/1-2")
       (d2wlin 'process-param-method1 (debug-get-string all-tvars))
       (d2wlin 'process-param-method1
               (debug-get-string (hfield-ref tvar-table 'bindings)))
       
       ;; TBR
       ;; (set! gl-counter28 (+ gl-counter28 1))
       ;; (d2wl 'debug43 gl-counter28)
       ;; (if (= gl-counter28 2)
       ;; 	(begin
       ;; 	  (dvar1-set! tvar-table)
       ;; 	  (dvar2-set! all-tvars)
       ;; 	  (dvar3-set! fixed-tvars)
       ;; 	  (raise 'stop28)))
       ;; (d2wl 'type-deduction
       ;; 	(debug-get-string
       ;; 	 (map car (hfield-ref tvar-table 'bindings))))
       
       (let* ((sgt-al-original (make-singleton '())))
         (update-original-bindings! sgt-al-original al-tvars)
         (let* ((tvar-bindings0 (hfield-ref tvar-table 'bindings))
                (tvar-bindings
                 (append tvar-bindings0
                         (singleton-get-element sgt-al-original)))
                (inst-type (tno-field-ref mtc2 'type-contents))
                (result-mtc (bind-type-vars-fwd
                             binder tvar-bindings inst-type)))
           (d2wli 'process-param-method "process-param-method/1-3")
           (d2wli 'process-param-method1 (debug-get-string inst-type))
           ;;  (if (or (all-tvars-correct? tvar-table all-tvars)
           ;;          (not (contains-free-tvars-fwd?
           ;;                (tno-field-ref result-mtc 'type-arglist))))
           (if (or (all-tvars-correct? tvar-table all-nonfixed-tvars)
                   (not (contains-free-tvars-fwd?
                         (tno-field-ref result-mtc 'type-arglist))))
             (begin
              (d2wli 'process-param-method "process-param-method/2")
              result-mtc)
             (begin
              (d2wli 'process-param-method "process-param-method/3")
              #f)))))
      (let ((result-mtc (tno-field-ref mtc2 'type-contents)))
        (if (not (contains-free-tvars-fwd?
                  (tno-field-ref result-mtc 'type-arglist)))
          (begin
           (d2wli 'process-param-method "process-param-method/4")
           result-mtc)
          (begin
           (d2wli 'process-param-method "process-param-method/5")
           #f))))))


(define (contains-simple-methods? l-method-classes)
  (or-map? (lambda (to-mtc) (is-tc-simple-proc? to-mtc))
           l-method-classes))


(define (contains-param-methods? l-method-classes)
  (or-map? (lambda (to-mtc) (is-tc-param-proc? to-mtc))
           l-method-classes))


(define (reject-param-methods l-selection l-method-classes)
  (filter (lambda (i) (is-tc-simple-proc? (list-ref l-method-classes
                                                    (list-ref l-selection i))))
          l-selection))


(define (select-best-method-class binder argl method-classes)
  (d2wli 'sbmc "select-best-method-class")
  (assert (is-binder? binder))
  (assert (and (list? method-classes)
               (and-map?
                (lambda (mtc)
                  (or
                   (is-tc-simple-proc? mtc)
                   (is-tc-param-proc? mtc)))
                method-classes)))
  (let* ((processed-classes
          (map (lambda (mtc)
                 (if (is-tc-param-proc? mtc)
                   (process-param-method binder argl mtc)
                   mtc))
               method-classes))
         (tmp1 (begin (d2wli 'sbmc "select-best-method-class/1") #f))
         (selection
          (select-best-method0 binder argl method-classes processed-classes)))
    ;; (sel2
    ;;  (if (and (contains-simple-methods? method-classes)
    ;; 	   (contains-param-methods? method-classes))
    ;;      (reject-param-methods selection method-classes)
    ;;      selection)))
    (d2wlin 'sbmc "select-best-method-class/2 " (length selection))
    (map (lambda (index)
           (cons
            (list-ref method-classes index)
            (list-ref processed-classes index)))
         selection)))


(define (select-best-method binder argl mts)
  (assert (is-binder? binder))
  (assert (and (list? mts) (and-map? is-method? mts)))
  (d2wli 'sbm "select-best-method")
  (d2wli 'sbm (length mts))
  (let* ((method-classes
          (map (lambda (mt)
                 (get-entity-type (car mt)))
               mts))
         (processed-classes
          (map (lambda (mtc)
                 (if (is-tc-param-proc? mtc)
                   (process-param-method binder argl mtc)
                   mtc))
               method-classes))
         (selection
          (select-best-method0 binder argl method-classes processed-classes)))
    ;; (sel2
    ;;  (if (and (contains-simple-methods? method-classes)
    ;; 	   (contains-param-methods? method-classes))
    ;;      (reject-param-methods selection method-classes)
    ;;      selection)))
    (d2wli 'sbm "select-best-method/1")
    (d2wli 'sbm selection)
    (map (lambda (index) (cons (list-ref mts index)
                               (list-ref processed-classes index)))
         selection)))


(define (process-param-method2 binder l-args l-arg-types0 to-mtc)
  (set! gl-counter27 (+ gl-counter27 1))
  (d2wl 'debug131 gl-counter27)
  ;; (set! gl-l-active-debug-categories
  ;;   (append gl-l-active-debug-categories '(deduce-argument-types
  ;;                                          type-deduction2 add-deduction
  ;;                                          type-deduction5 debug156)))
  (d2wli 'process-param-method2 "process-param-method2")
  ;; (d2wli 'process-param-method2 (debug-get-string l-args))
  ;; (d2wli 'process-param-method2 (debug-get-string (map get-entity-type l-args)))
  (d2wli 'process-param-method2 (debug-get-string to-mtc))
  (assert (is-binder? binder))
  (assert (or (is-entity? l-args)
              (and (list? l-args) (for-all is-entity? l-args))))
  (assert (is-tc-param-proc? to-mtc))
  (d2wli 'process-param-method2 "process-param-method2/0-1")
  (let* ((l-fixed-tvars (hfield-ref binder 'fixed-tvars))
         (to-mtc2 (make-tvars-unique2 binder to-mtc))
         (l-mtc2-tvars (get-all-free-tvars to-mtc2))
         (tvar-table (get-new-type-var-assoc-table))
         (tt-arg-list (tno-field-ref
                       (tno-field-ref to-mtc2 'type-contents)
                       'type-arglist))
         (l-arg-types
          (if (list? l-args)
            (compute-arg-types binder l-args tt-arg-list)
            (process-static-arg-type-list l-arg-types0 tt-arg-list)))
         (l-arg-tvars0 (get-all-free-tvars l-arg-types))
         (l-arg-tvars (get-nonfixed-tvars l-arg-tvars0 l-fixed-tvars))
         (l-all-tvars (append l-arg-tvars l-mtc2-tvars))
         (l-all-nonfixed-tvars
          (get-nonfixed-tvars l-all-tvars l-fixed-tvars)))
    (d2wli 'process-param-method2 "process-param-method2/0-2-0")
    (d2wli 'process-param-method2 (debug-get-string to-mtc))
    (d2wli 'process-param-method2 "process-param-method2/0-2-1")
    (d2wli 'process-param-method2 (debug-get-string to-mtc2))
    (d2wli 'process-param-method2 "process-param-method2/0-2-2")
    (d2wli 'process-param-method2 (debug-get-string l-arg-types))
    (d2wli 'process-param-method2 "process-param-method2/0-2-3")
    (d2wli 'process-param-method2 (debug-get-string l-all-tvars))
    (d2wli 'process-param-method2 "process-param-method2/0-2-4")
    (d2wli 'process-param-method2 (debug-get-string l-arg-tvars))
    (d2wli 'process-param-method2 "process-param-method2/0-2-5")
    (d2wli 'process-param-method2 (debug-get-string l-mtc2-tvars))
    (d2wli 'process-param-method2 "process-param-method2/0-2-6")
    (d2wli 'process-param-method2 (debug-get-string tt-arg-list))
    (d2wli 'process-param-method2 "process-param-method2/0-2-7")
    (d2wli 'process-param-method2 (debug-get-string l-fixed-tvars))
    (d2wli 'process-param-method2 "process-param-method2/0-2-8")
    (d2wli 'process-param-method2 (debug-get-string l-all-nonfixed-tvars))
    (if (not-null? l-all-tvars)
      (begin
       (set! gl-counter16 (+ gl-counter16 1))
       (d2wli 'debug141 gl-counter16)
       ;;  (if (eqv? gl-counter16 3)
       ;;    (set! gl-l-active-debug-categories
       ;;      '(debug141 deduce-argument-types tvar-replacement process-param-method2 unique)))
       (d2wl 'debug141 gl-counter27)
       (d2wli 'process-param-method2 "process-param-method2/1")
       (d2wli 'process-param-method2 (debug-get-string l-all-tvars))
       (d2wli 'process-param-method2 "process-param-method2/1-1")
       (d2wli 'process-param-method2 (debug-get-string l-arg-types))
       (d2wli 'process-param-method2 "process-param-method2/1-1-1")
       (d2wli 'process-param-method2 (debug-get-string tt-arg-list))
       (let ((i-counter gl-counter16))
         (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
           ;; (d2wli 'caller1 "deduce-argument-types 8")
           (deduce-argument-types binder tvar-table l-all-tvars l-arg-types
                                  tt-arg-list)
           ;; (if (eqv? i-counter 3) (raise 'stop3)) ;; TBR!!!
           #f))
       
       (d2wli 'process-param-method2 "process-param-method2/1-2")
       (let* ((l-tvar-bindings (hfield-ref tvar-table 'bindings))
              (tt-inst-type (tno-field-ref to-mtc2 'type-contents))
              (tt-result
               (fluid-let ((*b-param->simple* #f))
                 (bind-type-vars-fwd binder l-tvar-bindings
                                     tt-inst-type))))
         (d2wlin 'process-param-method2 "bindings: "
                 (debug-get-string l-tvar-bindings))
         (d2wlin 'process-param-method2 "old type: "
                 (debug-get-string tt-inst-type))
         (d2wlin 'process-param-method2 "new type: "
                 (debug-get-string tt-result))
         ;;  (if (or (all-tvars-correct? tvar-table l-all-tvars)
         ;;          (not (contains-free-tvars-fwd?
         ;;                (tno-field-ref tt-result 'type-arglist))))
         (if (or (all-tvars-correct? tvar-table l-all-nonfixed-tvars)
                 (not (contains-free-tvars-fwd?
                       (tno-field-ref tt-result 'type-arglist))))
           (begin
            (d2wli 'process-param-method2 "process-param-method2/2")
            tt-result)
           (begin
            (d2wli 'process-param-method2 "process-param-method2/3")
            #f))))
      (let ((tt-result (tno-field-ref to-mtc2 'type-contents)))
        (if (not (contains-free-tvars-fwd?
                  (tno-field-ref tt-result 'type-arglist)))
          (begin
           (d2wli 'process-param-method2 "process-param-method2/4")
           tt-result)
          (begin
           (d2wli 'process-param-method2 "process-param-method2/5")
           #f))))))


(define (select-best-method2 binder l-args l-methods)
  (d2wli 'sbm2 "select-best-method2")
  (d2wli 'sbm2 (length l-methods))
  (set! gl-counter30 (+ gl-counter30 1))
  (d2wl 'method-selection gl-counter30)
  (d2wl 'debug22 "select-best-method2")
  (d2wl 'debug22 l-args)
  (d2wl 'debug22 l-methods)
  ;; TBR
  ;; (if (eqv? gl-counter30 5)
  ;;   (set! gl-l-active-debug-categories 
  ;;     '(method-selection select-best-method0 type-deduction3 type-deduction4)))
  (assert (is-binder? binder))
  (assert (or (is-entity? l-args)
              (and (list? l-args) (for-all is-entity? l-args))))
  (assert (and (list? l-methods) (for-all is-method-object? l-methods)))
  ;; We want unit types for atomic objects.
  (let* ((l-arg-types
          (if (list? l-args)
            (map get-entity-type2 l-args)
            (let ((tt-args (get-entity-type l-args)))
              (strong-assert (is-tuple-type0? tt-args))
              (tuple-type->list-reject-cycles tt-args))))
         (l-method-classes
          (map (lambda (to-method)
                 ;; We don't need to handle atomic objects here.
                 (get-entity-type (car to-method)))
               l-methods))
         (l-processed-classes
          (map (lambda (to-mtc)
                 (if (is-tc-param-proc? to-mtc)
                   (process-param-method2 binder l-args l-arg-types to-mtc)
                   to-mtc))
               l-method-classes))
         (l-selection
          (select-best-method0 binder l-arg-types l-method-classes
                               l-processed-classes)))
    (d2wli 'sbm2 "select-best-method2/1")
    (d2wli 'sbm2 l-selection)
    (map (lambda (i)
           (cons (list-ref l-methods i)
                 ;; The processed class is not #f for a selected method.
                 (list-ref l-processed-classes i)))
         l-selection)))


(define (is-exact-match? binder argl method-type)
  (assert (is-binder? binder))
  (assert (and (list? argl) (and-map? is-target-object? argl)))
  (assert (is-target-object? method-type))
  (let* ((not-inh? (all-types-final? binder argl))
         (actual-arg-list-type (apply make-tt-list argl))
         (method-arg-list-type	      
          (tno-field-ref method-type 'type-arglist)))
    (and not-inh?
         (equal-types?
          binder
          actual-arg-list-type
          method-arg-list-type))))


(define (check-covariant-typing-for-method-ss? binder
                                               method-type1 method-type2)
  (assert (is-binder? binder))
  (assert (and (is-tc-simple-proc? method-type1)
               (is-tc-simple-proc? method-type2)))
  (let ((arglist1 (tno-field-ref method-type1 'type-arglist))
        (arglist2 (tno-field-ref method-type2 'type-arglist))
        (result1 (tno-field-ref method-type1 'type-result))
        (result2 (tno-field-ref method-type2 'type-result))
        (pure1? (tno-field-ref method-type1 'pure-proc?))
        (pure2? (tno-field-ref method-type2 'pure-proc?))
        (always-returns1? (tno-field-ref method-type1 'appl-always-returns?))
        (always-returns2? (tno-field-ref method-type2 'appl-always-returns?))
        (never-returns1? (tno-field-ref method-type1 'appl-never-returns?))
        (never-returns2? (tno-field-ref method-type2 'appl-never-returns?))
        (static-method1? (tno-field-ref method-type1 'static-method?))
        (static-method2? (tno-field-ref method-type2 'static-method?)))
    ;; If argument list A inherits from argument list B
    ;; and result type B is none then result type A can be
    ;; anything.
    ;; Equivalent argument list types are forbidden.
    (let ((check1? (is-t-subtype? binder arglist1 arglist2))
          (check2? (is-t-subtype? binder arglist2 arglist1)))
      (if (and check1? check2?)
        #f
        (let ((check3?
               (if check1?
                 (and (or (target-type=? result2 tt-none)
                          (is-t-subtype? binder
                                         result1 result2))
                      (proc-attr-inherit? pure1? always-returns1?
                                          never-returns1?
                                          static-method1?
                                          pure2? always-returns2?
                                          never-returns2?
                                          static-method2?))
                 #t))
              (check4?
               (if check2?
                 (and (or (target-type=? result1 tt-none)
                          (is-t-subtype? binder
                                         result2 result1))
                      (proc-attr-inherit? pure2? always-returns2?
                                          never-returns2?
                                          static-method2?
                                          pure1? always-returns1?
                                          never-returns1?
                                          static-method1?))
                 #t)))
          (and check3? check4?))))))


(define (check-arglist-typing-for-method-ss? binder
                                             method-type1 method-type2)
  (assert (is-binder? binder))
  (assert (and (is-tc-simple-proc? method-type1)
               (is-tc-simple-proc? method-type2)))
  (let ((arglist1 (tno-field-ref method-type1 'type-arglist))
        (arglist2 (tno-field-ref method-type2 'type-arglist)))
    (not
     (and (is-t-subtype? binder arglist1 arglist2)
          (is-t-subtype? binder arglist2 arglist1)))))


(define (is-param-expr-subtype? binder expr1 tvars1 expr2 tvars2)
  (assert (is-binder? binder))
  (assert (is-type0? expr1))
  (assert (and (list? tvars1) (and-map? is-t-type-variable? tvars1)))
  (assert (is-type0? expr2))
  (assert (and (list? tvars2) (and-map? is-t-type-variable? tvars2)))
  (let ((nr-of-tvars (length tvars1)))
    (if (= (length tvars2) nr-of-tvars)
      (let ((new-tvars (make-type-variables binder nr-of-tvars)))
        (enclose-tvars nr-of-tvars
                       (let* ((bindings1 (map cons tvars1 new-tvars))
                              (bindings2 (map cons tvars2 new-tvars))
                              (new-expr1
                               (rebind-type-variables-no-check-fwd
                                binder expr1 bindings1))
                              (new-expr2
                               (rebind-type-variables-no-check-fwd
                                binder expr2 bindings2))
                              (result
                               (check-if-t-subtype? binder '() new-expr1 new-expr2)))
                         result)))
      #f)))


(define (check-covariant-typing-for-method-pp? binder
                                               method-type1 method-type2)
  (assert (is-binder? binder))
  (assert (and (is-tc-param-proc? method-type1)
               (is-tc-param-proc? method-type2)))
  (let ((tvars1 (tno-field-ref method-type1 'l-tvars))
        (tvars2 (tno-field-ref method-type2 'l-tvars)))
    (if (= (length tvars1) (length tvars2))
      (let* ((inst-type1 (tno-field-ref method-type1 'type-contents))
             (inst-type2 (tno-field-ref method-type2 'type-contents))
             (arglist1 (tno-field-ref inst-type1 'type-arglist))
             (arglist2 (tno-field-ref inst-type2 'type-arglist))
             (result1 (tno-field-ref inst-type1 'type-result))
             (result2 (tno-field-ref inst-type2 'type-result))
             (pure1? (tno-field-ref inst-type1 'pure-proc?))
             (pure2? (tno-field-ref inst-type2 'pure-proc?))
             (always-returns1? (tno-field-ref inst-type1
                                              'appl-always-returns?))
             (always-returns2? (tno-field-ref inst-type2
                                              'appl-always-returns?))
             (never-returns1? (tno-field-ref inst-type1
                                             'appl-never-returns?))
             (never-returns2? (tno-field-ref inst-type2
                                             'appl-never-returns?))
             (static-method1? (tno-field-ref inst-type1 'static-method?))
             (static-method2? (tno-field-ref inst-type2 'static-method?)))
        ;; If argument list A inherits from argument list B
        ;; and result type B is none then result type A can be
        ;; anything.
        ;; Equivalent argument list types are forbidden.
        (let ((check1? (is-param-expr-subtype?
                        binder arglist1 tvars1 arglist2 tvars2))
              (check2? (is-param-expr-subtype?
                        binder arglist2 tvars2 arglist1 tvars1)))
          (if (and check1? check2?)
            #f
            (let ((check3?
                   (if check1?
                     (and (or (target-type=? result2 tt-none)
                              (is-param-expr-subtype?
                               binder
                               result1 tvars1 result2 tvars2))
                          (proc-attr-inherit?
                           pure1? always-returns1? never-returns1?
                           static-method1?
                           pure2? always-returns2? never-returns2?
                           static-method2?))
                     #t))
                  (check4?
                   (if check2?
                     (and (or (target-type=? result1 tt-none)
                              (is-param-expr-subtype?
                               binder
                               result2 tvars2 result1 tvars1))
                          (proc-attr-inherit?
                           pure2? always-returns2? never-returns2?
                           static-method2?
                           pure1? always-returns1? never-returns1?
                           static-method1?))
                     #t)))
              (and check3? check4?)))))
      #t)))


(define (check-arglist-typing-for-method-pp? binder
                                             method-type1 method-type2)
  (assert (is-binder? binder))
  (assert (and (is-tc-param-proc? method-type1)
               (is-tc-param-proc? method-type2)))
  (let ((tvars1 (tno-field-ref method-type1 'l-tvars))
        (tvars2 (tno-field-ref method-type2 'l-tvars)))
    (if (= (length tvars1) (length tvars2))
      (let* ((inst-type1 (tno-field-ref method-type1 'type-contents))
             (inst-type2 (tno-field-ref method-type2 'type-contents))
             (arglist1 (tno-field-ref inst-type1 'type-arglist))
             (arglist2 (tno-field-ref inst-type2 'type-arglist)))
        (not
         (and
          (is-param-expr-subtype?
           binder arglist1 tvars1 arglist2 tvars2)
          (is-param-expr-subtype?
           binder arglist2 tvars2 arglist1 tvars1))))
      #t)))


(define (check-covariant-typing-for-method? binder
                                            method-type1 method-type2)
  (let ((simple1? (is-tc-simple-proc? method-type1))
        (simple2? (is-tc-simple-proc? method-type2))
        (param1? (is-tc-param-proc? method-type1))
        (param2? (is-tc-param-proc? method-type2)))
    ;; Methods have to be either simple or parametrized procedures.
    ;; Abstract and generic procedures are not allowed as methods.
    (strong-assert (xor simple1? param1?))
    (strong-assert (xor simple2? param2?))
    (let ((result
           (cond
             ((and simple1? simple2?)
              (check-covariant-typing-for-method-ss?
               binder method-type1 method-type2))
             ((and param1? param2?)
              (check-covariant-typing-for-method-pp?
               binder method-type1 method-type2))
             ((or (and simple1? param2?) (and param1? simple2?))
              #t)
             (else
              ;; We should never arrive here.
              (raise 'internal-error)))))
      result)))


(define (check-arglist-typing-for-method? binder
                                          method-type1 method-type2)
  (let ((simple1? (is-tc-simple-proc? method-type1))
        (simple2? (is-tc-simple-proc? method-type2))
        (param1? (is-tc-param-proc? method-type1))
        (param2? (is-tc-param-proc? method-type2)))
    ;; Methods have to be either simple or parametrized procedures.
    ;; Abstract and generic procedures are not allowed as methods.
    (strong-assert (xor simple1? param1?))
    (strong-assert (xor simple2? param2?))
    (let ((result
           (cond
             ((and simple1? simple2?)
              (check-arglist-typing-for-method-ss?
               binder method-type1 method-type2))
             ((and param1? param2?)
              (check-arglist-typing-for-method-pp?
               binder method-type1 method-type2))
             ((or (and simple1? param2?) (and param1? simple2?))
              #t)
             (else
              ;; We should never arrive here.
              (raise 'internal-error)))))
      result)))


(define (check-covariant-typing-for-method2? binder method method-type)
  (assert (is-binder? binder))
  (assert (is-entity? method))
  (assert (is-target-object? method-type))
  (let ((type1 (get-entity-type method)))
    (assert (is-target-object? type1))
    (check-covariant-typing-for-method? binder
                                        type1 method-type)))


(define (check-arglist-typing-for-method2? binder method method-type)
  (assert (is-binder? binder))
  (assert (is-entity? method))
  (assert (is-target-object? method-type))
  (let ((type1 (get-entity-type method)))
    (assert (is-target-object? type1))
    (check-arglist-typing-for-method? binder
                                      type1 method-type)))


(define (check-covariant-typing? binder genproc method)
  (assert (is-binder? binder))
  (assert (is-target-object? genproc))
  (assert (is-entity? method))
  (let* ((method-type (get-entity-type method))
         (methods (tno-field-ref genproc 'l-methods))
         (result
          (and-map? (lambda (mt)
                      (check-covariant-typing-for-method2? 
                       binder
                       (car mt) method-type))
                    methods)))
    result))


(define (check-arglist-typing? binder genproc method)
  (assert (is-binder? binder))
  (assert (is-gen-proc? genproc))
  (assert (is-entity? method))
  (let ((method-type (get-entity-type method)))
    (let ((result
           (and-map?
            (lambda (mt)
              (check-arglist-typing-for-method2? binder
                                                 (car mt) method-type))
            (tno-field-ref genproc 'l-methods))))
      result)))


(define (check-covariant-typing-for-method-type? binder genproc
                                                 method-type)
  (assert (is-binder? binder))
  (assert (is-gen-proc? genproc))
  (assert (is-target-object? method-type))
  (let ((result
         (and-map?
          (lambda (mt)
            (check-covariant-typing-for-method2? binder
                                                 (car mt) method-type))
          (tno-field-ref genproc 'l-methods))))
    result))


(define (check-arglist-typing-for-method-type? binder genproc
                                               method-type)
  (assert (is-binder? binder))
  (assert (is-gen-proc? genproc))
  (assert (is-target-object? method-type))
  (let ((result
         (and-map?
          (lambda (mt)
            (check-arglist-typing-for-method2? binder
                                               (car mt) method-type))
          (tno-field-ref genproc 'l-methods))))
    result))


(define (dispatch-normal-method-w-params binder ngp tt-actual-arglist)
  
  ;; TBR
  ;; (set! gl-l-active-debug-categories '(debug142 process-param-method deduce-argument-types))
  
  (d2wl 'debug142 "dispatch-normal-method-w-params ENTER")
  (assert (hrecord-is-instance? binder <binder>))
  (assert (is-normal-gen-proc? ngp))
  (assert (is-type0? tt-actual-arglist))
  (d2wl 'debug142 "dispatch-normal-method-w-params/1")
  (let* ((l-methods (map car (tno-field-ref ngp 'l-methods)))
         (l-tt-method-classes (map get-entity-type l-methods))
         (tmp1 (begin (d2wl 'debug142 "dispatch-normal-method-w-params/1-1") #f))
         (l-processed-classes
          (let ((l-old-fixed (hfield-ref binder 'fixed-tvars))
                (l-free-tvars
                 (get-all-free-tvars1 tt-actual-arglist)))
            (hfield-set! binder 'fixed-tvars
                         (union-of-lists l-free-tvars l-old-fixed type-variable=?))
            (d2wl 'debug1007 "dispatch-normal-method-w-params/2")
            (d2wl 'debug1007
                  (debug-get-string (hfield-ref binder 'fixed-tvars)))
            (let ((l-processed1
                   (map (lambda (mtc)
                          (if (is-tc-param-proc? mtc)
                            (let ((mtc-new
                                   (process-param-method
                                    binder tt-actual-arglist mtc)))
                              (cond
                                ((eq? mtc-new #f)
                                 (my-raise1 'method-dispatch-failed
                                            (list
                                             (cons 'ngp ngp)
                                             (cons 'tt-actual-arglist 
                                                   tt-actual-arglist)
                                             (cons 'to-original-mtc mtc))))
                                ((not (is-tc-simple-proc? mtc-new))
                                 (raise 'internal-error-in-method-dispatch))
                                (else mtc-new)))
                            mtc))
                        l-tt-method-classes)))
              (hfield-set! binder 'fixed-tvars l-old-fixed)
              l-processed1)))
         (tmp2 (begin (d2wl 'debug142 "dispatch-normal-method-w-params/1-2") #f))
         (l-tt-declared
          (map (lambda (tt-method)
                 ;; Should we check that tt-method is not #f?
                 (tno-field-ref tt-method 'type-arglist))
               l-processed-classes))
         (tmp3 (begin (d2wl 'debug142 "dispatch-normal-method-w-params/1-3") #f))
         (i-methods (length l-methods))
         (vb-match (make-vector i-methods #f)))
    (d2wl 'debug142 "dispatch-normal-method-w-params/2")
    (do ((i 0 (+ i 1))) ((>= i i-methods))
      (vector-set! vb-match i
                   (equal-reprs1-fwd? binder
                                      tt-actual-arglist
                                      (list-ref l-tt-declared i))))
    (d2wl 'debug142 "dispatch-normal-method-w-params EXIT")
    (get-indices vb-match)))


(define (get-new-type-var-assoc-table)
  (make-hrecord <type-var-assoc-table> '() '() '() '() '()))


(define (type-var-inquire tvars tvar)
  ;;  (dwl4 "type-var-inquire")
  (assoc tvar (hfield-ref tvars 'bindings) type-variable=?))


(define (type-var-do-add-new-binding! tvars tvar type)
  ;; (d2wl 'debug1011 "type-var-do-add-new-binding!")
  ;; (d2wl 'debug1011 (debug-get-string tvar))
  ;; (d2wl 'debug1011 (debug-get-string type))
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-t-type-variable? tvar))
  (assert (is-type0? type))
  (hfield-set!
   tvars 'l-new-tvars
   (cons tvar
         (hfield-ref tvars 'l-new-tvars)))
  ;; The following check may not be necessary.
  (if (not (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?))
    (hfield-set!
     tvars 'l-all-tvars
     (cons tvar
           (hfield-ref tvars 'l-all-tvars))))
  (hfield-set! tvars 'bindings
               (cons
                (cons tvar type)
                (hfield-ref tvars 'bindings))))


(define (type-var-add-new-binding! tvars binder tvar type)
  (assert (is-binder? binder))
  (d2wli 'type-deduction "type-var-add-new-binding!")
  ;; (d2wli 'type-deduction "tvar name:")
  ;; (d2wli 'type-deduction (hfield-ref (hfield-ref tvar 'address)
  ;;                                    'source-name))
  ;; (d2wli 'type-deduction "tvar number:")
  ;; (d2wli 'type-deduction (hfield-ref (hfield-ref tvar 'address)
  ;;                                    'number))
  (d2wli 'type-deduction "type: ")
  (d2wli 'type-deduction (debug-get-string type))
  (cond
    ((and (is-t-type-variable? type)
          (type-variable=? type tvar))
     #f)
    ((is-type0? type)
     (type-var-do-add-new-binding!
      tvars tvar
      (construct-argument-type-repr-fwd binder type)))
    ((and (list? type)
          (and-map? is-type0? type))
     (let ((repr
            (construct-toplevel-type-repr-fwd binder type)))
       (type-var-do-add-new-binding! tvars tvar repr)))
    (else
     (raise 'erroneous-type-var-binding))))


;;(define (equal-values? t1 t2)
;;  (eqv? (get-expr-value t1) (get-expr-value t2)))


(define (do-handle-static-repr binder type visited use-tuples? simple->abstract?)
  (assert (is-binder? binder))
  (assert (list? visited))
  (assert (boolean? use-tuples?))
  (let* ((new-visited (cons type visited))
         (result
          (cond
            ((memv type visited) type)
            ((and simple->abstract? (is-tc-param-proc? type))
             (simple->abstract-proc-type (tno-field-ref type 'type-contents)))
            ((and simple->abstract? (is-tc-simple-proc? type))
             (simple->abstract-proc-type type))
            ((is-t-type-list? type)
             (if use-tuples?
               (apply make-tuple-type-fwd
                 ;; Formerly we had hfield-ref here.
                 (tno-field-ref type 'l-subtypes))
               (tno-field-ref type 'l-subtypes)))
            (else type))))
    result))


(define (handle-static-repr binder type use-tuples? simple->abstract?)
  (let ((result
         (do-handle-static-repr binder type '() use-tuples? simple->abstract?))) 
    result))


(define (get-subreprs-for-type-deduction repr)
  (cond
    ((or
      (null? repr)
      (pair? repr)
      (eqv? repr tc-nil)
      (is-tc-pair? repr))
     repr)
    ((is-t-param-class-instance? repr)
     (tno-field-ref repr 'l-tvar-values))
    ((is-tc-param-proc? repr)
     (get-subexpressions-fwd (tno-field-ref repr 'type-contents)))
    (else
     ;; The following code is needed at least for procedure types.
     (get-subexpressions-fwd repr))))


(define (deduce-subreprs deduced-type-vars binder
                         all-type-vars
                         t1 t2 visited)
  (d2wli 'type-deduction "deduce-subreprs")
  (assert (hrecord-is-instance? deduced-type-vars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (list? visited))
  (strong-assert (is-gen-pair? t1))
  (dvar1-set! t1)
  (dvar2-set! t2)
  (let* ((t1-new
          (if (pair? t1)
            (cons
             (get-subreprs-for-type-deduction (car t1))
             (cdr t1))
            (let ((hd (get-subreprs-for-type-deduction (gen-car t1)))
                  (tl (gen-cdr t1)))
              (cons hd tl))))
         (subreprs2 (get-subreprs-for-type-deduction t2)))
    (d2wli 'type-deduction "deduce-subreprs/2")
    (deduce-type-params0 deduced-type-vars
                         binder
                         all-type-vars
                         t1-new
                         subreprs2
                         visited)))

;; Not sure if the following procedure makes sense.
(define (deduce-union-x tvars binder
                        all-type-vars
                        t1 t2 visited)
  (d2wli 'type-deduction "deduce-union-x")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (is-tt-union? t1))
  (assert (list? visited))
  (let ((union-members (tno-field-ref t1 'l-member-types)))
    (for-each
     (lambda (union-member)
       (deduce-type-params0 tvars binder
                            all-type-vars
                            (list union-member)
                            t2
                            visited))
     union-members)))


(define (deduce-x-union tvars binder
                        all-type-vars
                        t1 t2 visited)
  (d2wli 'type-deduction "deduce-x-union")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (is-tt-union? t2))
  (assert (list? visited))
  (let ((union-members (tno-field-ref t2 'l-member-types)))
    (for-each
     (lambda (union-member)
       (deduce-type-params0 tvars binder
                            all-type-vars
                            t1
                            union-member
                            visited))
     union-members)))


(define (deduce-union-union tvars binder
                            all-type-vars
                            t1 t2 visited)
  (d2wli 'type-deduction "deduce-union-union")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (is-tt-union? t1))
  (assert (is-tt-union? t2))
  (assert (list? visited))
  (let ((union-members1 (tno-field-ref t1 'l-member-types))
        (union-members2 (tno-field-ref t2 'l-member-types)))
    (do ((lst1 union-members1 (cdr lst1))
         (lst2 union-members2 (cdr lst2)))
      ((or (null? lst1) (null? lst2)))
      (deduce-type-params0 tvars
                           binder
                           all-type-vars
                           (list (car lst1))
                           (car lst2)
                           visited))))


;; If an abstract pair does not contain two arguments
;; it is not handled as a pair in type checking and
;; type deduction.
(define (is-abstract-pair? obj)
  (and (is-t-apti? obj)
       (eq? (tno-field-ref obj 'type-meta) tc-pair)
       (= (length (tno-field-ref obj 'l-type-args)) 2)))


;; Precondition: to has to be a <target-object>.
(define (is-abstract-pair1? to)
  (and (eq? (get-entity-type to) tc-abstract-param-type-inst)
       (eq? (tno-field-ref to 'type-meta) tc-pair)
       (equal? (length (tno-field-ref to 'l-type-args)) 2)))


(define (is-gen-pair? obj)
  (or
   (pair? obj)
   (is-tc-pair? obj)
   (is-abstract-pair? obj)))


(define (gen-car obj)
  (cond
    ((pair? obj) (car obj))
    ((is-tc-pair? obj)
     (get-pair-first-type obj))
    ((is-abstract-pair? obj)
     (car (tno-field-ref obj 'l-type-args)))
    (else (raise 'gen-car:invalid-argument))))


(define (gen-cdr obj)
  (cond
    ((pair? obj) (cdr obj))
    ((is-tc-pair? obj)
     (get-pair-second-type obj))
    ((is-abstract-pair? obj)
     (cadr (tno-field-ref obj 'l-type-args)))
    (else (raise 'gen-cdr:invalid-argument))))


(define (deduce-pair-class tvars binder
                           all-type-vars
                           t1 t2 visited)
  (d2wli 'type-deduction "deduce-pair-class")
  ;; If t1 does not fulfill the following condition
  ;; should we just do nothing instead of giving an error?
  (assert (is-gen-pair? t1))
  (assert (is-gen-pair? t2))
  (let ((src (gen-car t1)))
    (if (is-gen-pair? src)
      (begin
       (deduce-type-params0 tvars binder
                            all-type-vars
                            src (gen-car t2) visited)
       (deduce-type-params0 tvars binder
                            all-type-vars
                            (list (gen-cdr src)) (gen-cdr t2)
                            visited)))))


(define (arg-list-desc->list arg-list-desc)
  ;; When a procedure type is created with
  ;; translate-general-proc-type-expression0 the argument list descriptor is
  ;; either a type list or a general tuple type.
  (cond
    ((is-t-type-list? arg-list-desc)
     (hfield-ref arg-list-desc 'subexprs))
    ;; We don't handle the case where arg-list-desc is not a normal tuple type.
    ((is-tuple-type0-fwd? arg-list-desc)
     (tuple-type->list-reject-cycles-fwd arg-list-desc))
    (else arg-list-desc)))


(define (deduce-gen-proc-abst-proc tvars binder
                                   all-type-vars
                                   t1 t2 visited)
  (d2wli 'deduce-gp "deduce-gen-proc-abst-proc ENTER")
  (d2wli 'gp-ap (debug-get-string t1))
  (d2wli 'gp-ap (debug-get-string t2))
  
  (assert (is-tc-gen-proc? t1))
  (assert (is-tt-procedure? t2))
  
  ;; TBR
  ;; (d2wli 'type-deduction (debug-get-string
  ;;			  (car (tno-field-ref t1 'l-method-classes))))
  ;; (d2wli 'type-deduction (debug-get-string t2))
  ;; (d2wli 'type-deduction (debug-get-string (tno-field-ref t2 'type-arglist)))
  
  (let* ((target-arg-list (arg-list-desc->list
                            (tno-field-ref t2 'type-arglist)))
         (target-result (tno-field-ref t2 'type-result))
         (tvars1? (contains-type-variables-fwd? target-arg-list))
         (tvars2? (contains-type-variables-fwd? target-result))
         (method-classes (tno-field-ref t1 'l-method-classes))
         (best
          (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
            (select-best-method-class binder target-arg-list
                                      method-classes))))
    (if (eqv? (length best) 1)
      (begin
       (d2wli 'debug137 "deduce-gen-proc-abst-proc/0-1")
       (d2wli 'debug137 (debug-get-string best))
       (let* ((best-method-class2 (cdar best))
              (best-arg-list-type (tno-field-ref best-method-class2
                                                 'type-arglist))
              (best-result-type (tno-field-ref best-method-class2
                                               'type-result)))
         (d2wli 'gp-ap "deduce-gen-proc-abst-proc/1")
         (d2wli 'gp-ap (debug-get-string target-arg-list))
         (d2wli 'gp-ap (debug-get-string best-method-class2))
         (d2wli 'gp-ap (debug-get-string t2))
         (d2wli 'gp-ap (debug-get-string all-type-vars))
         (d2wli 'gp-ap "deduce-gen-proc-abst-proc/2")
         (if tvars1?
           (deduce-type-params0 tvars binder
                                all-type-vars
                                (list best-arg-list-type)
                                target-arg-list
                                visited))
         (if tvars2?
           (deduce-type-params0 tvars binder
                                all-type-vars
                                (list best-result-type)
                                target-result
                                visited))))
      (d2wli 'deduce-gp "deduce-gen-proc-abst-proc ENTER"))))


(define (deduce-abst-proc-gen-proc tvars binder
                                   all-type-vars
                                   t1 t2 visited)
  (d2wli 'deduce-gp "deduce-abst-proc-gen-proc ENTER")
  (d2wli 'deduce-gp (debug-get-string t1))
  (d2wli 'deduce-gp (debug-get-string (hfield-ref tvars 'l-all-tvars)))
  (assert (is-tt-procedure? t1))
  (assert (is-tc-gen-proc? t2))
  ;; TBR
  ;; (d2wli 'type-deduction (debug-get-string
  ;;			  (car (tno-field-ref t2 'l-method-classes))))
  ;; (d2wli 'type-deduction (debug-get-string t1))
  (let* ((target-arg-list (arg-list-desc->list
                            (tno-field-ref t1 'type-arglist)))
         (method-classes (tno-field-ref t2 'l-method-classes))
         (best
          (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
            (select-best-method-class binder target-arg-list
                                      method-classes))))
    (if (eqv? (length best) 1)
      (let ((best-method-class 
             (let ((pc (cdar best)))
               (if (is-tc-simple-proc? pc)
                 (simple->abstract-proc-type pc)
                 pc))))
        (d2wli 'deduce-gp "deduce-abst-proc-gen-proc/1")
        (d2wli 'deduce-gp (debug-get-string best-method-class))
        (deduce-type-params0 tvars binder
                             all-type-vars
                             (list t1) best-method-class
                             visited)))
    (d2wli 'deduce-gp "deduce-abst-proc-gen-proc EXIT")))


(define (simple->abstract-proc-type tc)
  (assert (is-tc-simple-proc? tc))
  (make-tpti-general-proc
   #f
   (tno-field-ref tc 'type-arglist)
   (tno-field-ref tc 'type-result)
   (tno-field-ref tc 'pure-proc?)
   (tno-field-ref tc 'appl-always-returns?)
   (tno-field-ref tc 'appl-never-returns?)
   (tno-field-ref tc 'static-method?)))


;; This procedure is for target objects having free type variables.
;; Source object has to be a generic procedure.
(define (deduce-gen-proc-abst-proc2 tvar-table binder l-all-tvars to1 to2 l-visited)
  (assert (hrecord-is-instance? tvar-table <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? l-all-tvars)
               (for-all is-t-type-variable? l-all-tvars)))
  (assert (and (list? l-visited)
               (for-all pair? l-visited)))
  (assert (is-tc-gen-proc? to1))
  (assert (is-tt-procedure? to2))
  (set! gl-counter29 (+ gl-counter29 1))
  (d2wli 'gp-ap2 gl-counter29)
  ;; (if (eqv? gl-counter29 1)
  ;;   (set! gl-l-active-debug-categories
  ;;     '(sgn1 gp-ap2 type-deduction3 add-deduction)))
  (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2 ENTER")  
  (d2wli 'gp-ap2 (debug-get-string l-all-tvars))
  (d2wli 'gp-ap2
        (debug-get-string (car (tno-field-ref to1 'l-method-classes))))
  (d2wli 'gp-ap2 (debug-get-string to2))
  (let ((l-mtc (tno-field-ref to1 'l-method-classes)))
    (assert (and (list? l-mtc) (not-null? l-mtc)
                 (for-all is-t-nongeneric-proc-type? l-mtc)))
    ;; (if (eqv? (length l-mtc) 1)
    (if (null? (cdr l-mtc))
      (begin
       (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2/0")
       (d2wli 'gp-ap2 (debug-get-string (car l-mtc)))
       (deduce-type-params0 tvar-table binder
                            l-all-tvars
                            (list (car l-mtc))
                            to2
                            l-visited))
      (let* ((l-free-tvars2 (get-all-free-tvars1 to2))
             (l-deductions
              (map (lambda (tc-method)
                     (let* ((tc-method1
                             (if (is-tc-simple-proc? tc-method)
                               (simple->abstract-proc-type tc-method)
                               tc-method))
                            (l-free-tvars1 (get-all-free-tvars tc-method1))
                            (l-free-tvars
                             (union-of-lists l-free-tvars1 l-free-tvars2
                                             type-variable=?)))
                       (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2/1")
                       (d2wli 'gp-ap2 (debug-get-string tc-method1))
                       (d2wli 'gp-ap2 (debug-get-string l-free-tvars))
                       (equal-reprs-w-deduction-fwd binder tc-method1 to2
                                                    l-free-tvars)))
                   l-mtc))
             (i-count
              (count not-false? l-deductions)))
        (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2")
        (d2wlin 'gp-ap2 "number of handled method classes: "
                (length l-deductions))
        (d2wlin 'gp-ap2 "number of matching method classes: "
                i-count)
        (if (eqv? i-count 1)
          (let ((al-deduction
                 ;; We know that l-deductions contains an element not equal to #f.
                 (find not-false? l-deductions)))
            (assert (is-proc-deduction-alist-fwd? al-deduction))
            (d2wlin 'gp-ap2 "number of deduced type variables: "
                    (length al-deduction))
            (for-each
             (lambda (p)
               (add-deduction tvar-table binder (car p) (cdr p)))
             al-deduction)))))))


;; This procedure is for target objects having free type variables.
;; Source object has to be a generic procedure.
;; (define (deduce-gen-proc-abst-proc2 tvar-table binder l-all-tvars to1 to2 l-visited)
;;   (assert (hrecord-is-instance? tvar-table <type-var-assoc-table>))
;;   (assert (is-binder? binder))
;;   (assert (and (list? l-all-tvars)
;;                (for-all is-t-type-variable? l-all-tvars)))
;;   (assert (and (list? l-visited)
;;                (for-all pair? l-visited)))
;;   (assert (is-tc-gen-proc? to1))
;;   (assert (is-tt-procedure? to2))
;;   (set! gl-counter29 (+ gl-counter29 1))
;;   (d2wli 'gp-ap2 gl-counter29)
;;   ;; (if (eqv? gl-counter29 1)
;;   ;;   (set! gl-l-active-debug-categories
;;   ;;     '(sgn1 gp-ap2 type-deduction3 add-deduction)))
;;   (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2 ENTER")  
;;   (d2wli 'gp-ap2 (debug-get-string l-all-tvars))
;;   (d2wli 'gp-ap2
;;         (debug-get-string (car (tno-field-ref to1 'l-method-classes))))
;;   (d2wli 'gp-ap2 (debug-get-string to2))
;;   (let ((l-mtc (tno-field-ref to1 'l-method-classes)))
;;     (assert (and (list? l-mtc) (not-null? l-mtc)
;;                  (for-all is-t-nongeneric-proc-type? l-mtc)))
;;     ;; (if (eqv? (length l-mtc) 1)
;;     ;; (if (null? (cdr l-mtc))
;;     ;;   (let* ((tc-method (car l-mtc))
;;     ;;          (tc-method1
;;     ;;           (if (is-tc-simple-proc? tc-method)
;;     ;;             (simple->abstract-proc-type tc-method)
;;     ;;             tc-method))
;;     ;;          (l-free-tvars2 (get-all-free-tvars1 to2))
;;     ;;          (l-free-tvars1 (get-all-free-tvars tc-method1))
;;     ;;          (l-free-tvars
;;     ;;           (union-of-lists l-free-tvars1 l-free-tvars2
;;     ;;                           type-variable=?)))
;;     ;;    (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2/0")
;;     ;;    (d2wli 'gp-ap2 (debug-get-string (car l-mtc)))
;;     ;;    (deduce-type-params0 tvar-table binder
;;     ;;                         l-free-tvars
;;     ;;                         (list tc-method1)
;;     ;;                         to2
;;     ;;                         l-visited))
;;       (let* ((l-free-tvars2 (get-all-free-tvars1 to2))
;;              (l-deductions
;;               (map (lambda (tc-method)
;;                      (let* ((tc-method1
;;                              (cond
;;                                ((is-tc-simple-proc? tc-method)
;;                                 (simple->abstract-proc-type tc-method))
;;                                ((is-tc-param-proc? tc-method)
;;                                 (simple->abstract-proc-type
;;                                   (tno-field-ref tc-method 'type-contents)))
;;                                (else tc-method)))
;;                             ;; (l-old-fixed (hfield-ref binder 'fixed-tvars))
;;                             (l-free-tvars1 (get-all-free-tvars1 tc-method1))
;;                             (l-free-tvars
;;                              (union-of-lists l-free-tvars1 l-free-tvars2
;;                                              type-variable=?)))
;;                       ;;  (hfield-set! binder 'fixed-tvars
;;                       ;;                    (union-of-lists
;;                       ;;                     l-free-tvars1 l-old-fixed 
;;                       ;;                     type-variable=?))
;;                        (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2/1")
;;                        (d2wli 'gp-ap2 (debug-get-string tc-method1))
;;                        (d2wli 'gp-ap2 (debug-get-string to2))
;;                        (d2wli 'gp-ap2 (debug-get-string l-free-tvars))
;;                        (let ((result
;;                               (equal-reprs-w-deduction-fwd
;;                                binder
;;                                tc-method1 to2
;;                                l-free-tvars)))
;;                          ;; (hfield-set! binder 'fixed-tvars l-old-fixed)
;;                          result)))
;;                    l-mtc))
;;              (i-count
;;               (count not-false? l-deductions)))
;;         (d2wli 'gp-ap2 "deduce-gen-proc-abst-proc2")
;;         (d2wlin 'gp-ap2 "number of handled method classes: "
;;                 (length l-deductions))
;;         (d2wlin 'gp-ap2 "number of matching method classes: "
;;                 i-count)
;;         (d2wlin 'gp-ap2 "deductions: "
;;                 (debug-get-string l-deductions))
;;         (if (eqv? i-count 1)
;;           (let ((al-deduction
;;                  ;; We know that l-deductions contains an element not equal to #f.
;;                  (find not-false? l-deductions)))
;;             (assert (is-proc-deduction-alist-fwd? al-deduction))
;;             (d2wlin 'gp-ap2 "number of deduced type variables: "
;;                     (length al-deduction))
;;             (for-each
;;              (lambda (p)
;;                (add-deduction tvar-table binder (car p) (cdr p)))
;;              al-deduction))))))


(define (deduce-apti tvars binder
                     all-type-vars
                     t1 t2 visited)
  (let* ((apti1 (gen-car t1))
         (apti2 t2))
    (if (eqv? (tno-field-ref apti1 'type-meta)
              (tno-field-ref apti2 'type-meta))	
      (let* ((t1-new
              (let ((hd (tno-field-ref apti1 'l-type-args))
                    (tl (gen-cdr t1)))
                (cons hd tl)))
             (subreprs2 (tno-field-ref apti2 'l-type-args)))
        (deduce-type-params0 tvars
                             binder
                             all-type-vars
                             t1-new
                             subreprs2
                             visited))
      #f)))


(define (deduce-sgn-sgn tvars binder
                        all-type-vars
                        t1 t2 visited)
  (d2wli 'type-deduction "deduce-sgn-sgn")
  (assert (is-t-signature? t1))
  (assert (is-t-signature? t2))
  (let ((l-members1 (tno-field-ref t1 'l-members))
        (l-members2 (tno-field-ref t2 'l-members)))
    (do ((l-cur2 l-members2 (cdr l-cur2)))
      ((null? l-cur2))
      (let ((o-cur2 (car l-cur2)))
        (do ((l-cur1 l-members1 (cdr l-cur1)))
          ((null? l-cur1))
          (let ((o-cur1 (car l-cur1)))
            (if (eq? (car o-cur1) (car o-cur2))
              (deduce-type-params0 tvars binder all-type-vars
                                   (list (cdr o-cur1)) (cdr o-cur2)
                                   visited))))))))


(define (get-all-free-tvars2 to)
  (if (is-tc-param-proc? to)
     (get-all-free-tvars1 (tno-field-ref to 'type-contents))
    (get-all-free-tvars1 to)))


(define (deduce-gen-proc-sgn-member tvars binder t1 sgn-member l-all-tvars2 visited)
  (d2wli 'sgn1 "deduce-gen-proc-sgn-member")
  (assert (is-binder? binder))
  (assert (is-signature-member? binder sgn-member))
  (assert (is-gen-proc? (car sgn-member)))
  (assert (and (list? l-all-tvars2)
               (for-all is-t-type-variable? l-all-tvars2)))
  (let ((l-methods (tno-field-ref (car sgn-member) 'l-methods)))
    (do ((l-cur l-methods (cdr l-cur)) (i 1 (+ i 1))) ((null? l-cur))
      (d2wlin 'sgn1 "deduce-gen-proc-sgn-member method " i)
      (let* ((p-method
              (let ((p (car l-cur)))
                (assert (and (pair? p) (boolean? (cdr p))))
                p))
             (proc (car p-method))
             (to (get-entity-type2 proc))
             (to-type (cdr sgn-member))
             (to-new-type (sgn-subst-member-type binder #f to-type t1)))
        (d2wlin 'sgn1 "procedure type: " (debug-get-string to))
        (d2wlin 'sgn1 "declared type: " (debug-get-string to-type))
        (d2wlin 'sgn1 "new type: " (debug-get-string to-new-type))
        (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
          (deduce-type-params0 tvars binder l-all-tvars2 (list to) to-new-type
                               visited))))))


(define (deduce-not-sgn-sgn tvars binder
                            all-type-vars
                            t1 t2 visited)
  (d2wli 'sgn1 "deduce-not-sgn-sgn")
  (assert (not (is-t-signature? t1)))
  (assert (is-t-signature? t2))
  (d2wli 'sgn1 (debug-get-string t1))
  (debug-print-signature 'sgn1 t2)
  (d2wli 'sgn1 "deduce-not-sgn-sgn/1")
  (let* ((l-new-sgn-tvars1 (get-signature-target-types t2))
         (l-new-sgn-tvars2 (get-signature-declared-types t2))
         (l-new-sgn-tvars
          (union-of-lists l-new-sgn-tvars1 l-new-sgn-tvars2 type-variable=?))
         (l-free-tvars1 (get-all-free-tvars2 t1))
         (l-all-tvars2
          (union-of-lists l-new-sgn-tvars l-free-tvars1
                          type-variable=?))
         (l-members (tno-field-ref t2 'l-members))
         (l-old-tvars (hfield-ref tvars 'l-all-tvars)))
    (hfield-set! tvars 'l-all-tvars
                 (union-of-lists l-old-tvars l-all-tvars2 type-variable=?))
    ;; (hfield-set! tvars 'l-aux-tvars
    ;;              (union-of-lists l-new-sgn-tvars
    ;;                              (hfield-ref tvars 'l-aux-tvars)
    ;;                              type-variable=?))
    (d2wli 'sgn1 "deduce-not-sgn-sgn/2")
    (d2wli 'sgn1 (debug-get-string l-old-tvars))
    (d2wli 'sgn1 (debug-get-string l-new-sgn-tvars1))
    (d2wli 'sgn1 (debug-get-string l-new-sgn-tvars2))
    (d2wli 'sgn1 (debug-get-string l-new-sgn-tvars))
    (d2wli 'sgn1 (debug-get-string l-free-tvars1))
    (d2wli 'sgn1 (debug-get-string l-all-tvars2))
    (d2wli 'sgn1 (debug-get-string (hfield-ref tvars 'l-aux-tvars)))
    (do ((l-cur l-members (cdr l-cur))) ((null? l-cur))
      (if (is-gen-proc? (caar l-cur))
        (deduce-gen-proc-sgn-member tvars binder t1 (car l-cur) l-all-tvars2
                                    visited)
        ;; get-entity-type would probably work here.
        (let* ((to (get-entity-type2 (car (car l-cur))))
               (to-type (cdr (car l-cur)))
               (to-new-type (sgn-subst-member-type binder t2 to-type t1)))
          
          (d2wli 'sgn1 "deduce-not-sgn-sgn/3")
          (set! gl-counter23 (+ gl-counter23 1))
          
          ;; TBR
          ;; (if (eqv? gl-counter23 3)
          ;;  (set! gl-l-active-debug-categories '(sgn1 gp-ap2 type-deduction2)))
          
          (d2wli 'sgn1 gl-counter23)
          (d2wli 'sgn1 (debug-get-string to))
          (d2wli 'sgn1 (debug-get-string to-type))
          (d2wli 'sgn1 (debug-get-string to-new-type))
          
          (deduce-type-params0 tvars binder l-all-tvars2 (list to) to-new-type
                               visited))))))


(define (deduce-sgn-not-sgn tvars binder
                            all-type-vars
                            t1 t2 visited)
  (d2wli 'type-deduction "deduce-sgn-not-sgn")
  (assert (is-t-signature? t1))
  (assert (not (is-t-signature? t2)))
  (let ((l-members (tno-field-ref t1 'l-members)))
    (do ((l-cur l-members (cdr l-cur))) ((null? l-cur))
      ;; get-entity-type would probably work here.
      (let* ((to (get-entity-type2 (car (car l-cur))))
             (to-type (cdr (car l-cur)))
             (to-new-type (sgn-subst-member-type binder t1 to-type t2)))
        (deduce-type-params0 tvars binder all-type-vars (list to-new-type) to
                             visited)))))


(define (deduce-tuple-uniform tvars binder all-type-vars t1 t2)
  (d2wli 'deduce-uniform-lists "deduce-tuple-uniform")
  (let ((tvar (get-uniform-list-param0 t2))
        (l-types (tuple-type->list-reject-cycles-fwd t1))
        (fixed-tvars (hfield-ref binder 'fixed-tvars)))
    (if (and
         (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?)
         (not (type-var-inquire tvars tvar))
         (not (contains-free-tvars-general0-fwd? l-types fixed-tvars '())))
      (let ((tt-union
             (get-union-of-types0-fwd binder l-types)))
        (add-deduction
         tvars binder tvar tt-union)))))


(define (deduce-neul-uniform tvars binder all-type-vars t1 t2)
  (d2wli 'type-deduction "deduce-neul-uniform")
  (let* ((tvar (get-uniform-list-param0 t2))
         (tt-comp (tt-car t1))
         (fixed-tvars (hfield-ref binder 'fixed-tvars)))
    (if (and
         (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?)
         (not (type-var-inquire tvars tvar)))
      ;; The following check is already done in do-deduce-type-params.
      ;; (not (contains-free-tvars-general0-fwd? tt-comp fixed-tvars '())))
      (begin
       (add-deduction
        tvars binder tvar tt-comp)))))


(define (deduce-twt-uniform tvars binder all-type-vars t1 t2)
  (d2wli 'type-deduction "deduce-twt-uniform")
  (let* ((tvar (get-uniform-list-param0 t2))
         (l-root-types (get-general-tuple-type-root-types t1))
         (tt-tail (get-general-tuple-type-tail t1))
         (tt-tail-component (get-uniform-list-param0 tt-tail))
         (l-types (append l-root-types (list tt-tail-component)))
         (fixed-tvars (hfield-ref binder 'fixed-tvars)))
    (if (and
         (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?)
         (not (type-var-inquire tvars tvar))
         (not (contains-free-tvars-general0-fwd? l-types fixed-tvars '())))
      (let ((tt-value
             (if (null? (cdr l-types))
               (car l-types)
               (get-union-of-types0-fwd binder l-types))))
        (add-deduction
         tvars binder tvar tt-value)))))


(define (deduce-tuple-neul tvars binder all-type-vars t1 t2)
  (d2wli 'type-deduction "deduce-tuple-neul")
  (d2wli 'type-deduction (debug-get-string t1))
  (d2wli 'type-deduction (debug-get-string t2))
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? all-type-vars)
               (for-all is-t-type-variable? all-type-vars)))
  (assert (is-tuple-type0-fwd? t1))
  ;; (assert (is-t-nonempty-uniform-list-type0? t2))
  (let* ((tvar (get-neul-param0 t2))
         (l-types (tuple-type->list-reject-cycles-fwd t1))
         (fixed-tvars (hfield-ref binder 'fixed-tvars)))
    (if (and
         (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?)
         (not (type-var-inquire tvars tvar))
         (not (contains-free-tvars0-fwd? l-types fixed-tvars '())))
      (let ((tt-union (get-union-of-types0-fwd binder l-types)))
        (add-deduction tvars binder tvar tt-union)))))


(define (deduce-twt-neul tvars binder all-type-vars t1 t2)
  (d2wli 'type-deduction "deduce-twt-neul")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? all-type-vars)
               (for-all is-t-type-variable? all-type-vars)))
  (assert (is-tuple-type-with-tail-fwd? t1))
  ;; (assert (is-t-nonempty-uniform-list-type0? t2))
  (let* ((tvar (get-neul-param0 t2))
         (l-root-types (get-general-tuple-type-root-types t1))
         (tt-tail (get-general-tuple-type-tail t1))
         (tt-tail-component (get-uniform-list-param0 tt-tail))
         (l-types (append l-root-types (list tt-tail-component)))
         (fixed-tvars (hfield-ref binder 'fixed-tvars)))
    (assert (not-null? l-types))
    (if (and
         (member tvar (hfield-ref tvars 'l-all-tvars) type-variable=?)
         (not (type-var-inquire tvars tvar))
         (not (contains-free-tvars0-fwd? l-types fixed-tvars '())))
      (let ((tt-value
             (if (null? (cdr l-types))
               (car l-types)
               (get-union-of-types0-fwd binder l-types))))
        (add-deduction tvars binder tvar tt-value)))))


(define (deduce-proc-types tvars binder all-type-vars t1 t2 l-visited)
  (d2wli 'proc-types "deduce-proc-types ENTER")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? all-type-vars)
               (for-all is-t-type-variable? all-type-vars)))
  (assert (or (is-tc-simple-proc? t1) (is-tt-procedure? t1)))
  (assert (is-tt-procedure? t2))
  (assert (and (list? l-visited) (for-all pair? l-visited)))
  (let ((tt-arglist1
         (tno-field-ref t1 'type-arglist))
        (tt-result1
         (tno-field-ref t1 'type-result))
        (tt-arglist2
         (tno-field-ref t2 'type-arglist))
        (tt-result2
         (tno-field-ref t2 'type-result)))
    (assert (is-type0? tt-arglist1))
    (assert (is-type0? tt-result1))
    (assert (is-type0? tt-arglist2))
    (assert (is-type0? tt-result2))
    (d2wlin 'proc-types "arglist 1: " (debug-get-string tt-arglist1))
    (d2wlin 'proc-types "arglist 2: " (debug-get-string tt-arglist2))
    (d2wlin 'proc-types "result 1: " (debug-get-string tt-result1))
    (d2wlin 'proc-types "result 2: " (debug-get-string tt-result2))
    (d2wli 'proc-types "deduce-proc-types/1")
    (deduce-type-params0 tvars binder
                         all-type-vars
                         (list tt-arglist1)
                         tt-arglist2
                         l-visited)
    (d2wli 'proc-types "deduce-proc-types/2")
    (deduce-type-params0 tvars binder
                         all-type-vars
                         (list tt-result1)
                         tt-result2
                         l-visited)))


(define (deduce-proc-types1 tvar-table binder l-all-tvars x1 x2 l-visited)
  (assert (hrecord-is-instance? tvar-table <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? l-all-tvars)
               (for-all is-t-type-variable? l-all-tvars)))
  ;; The types of x1 and x2 are <object> in the bootstrapped
  ;; environment.
  (assert (and (list? l-visited) (for-all pair? l-visited)))
  (d2wli 'deduce-proc-types "deduce-proc-types1")
  (let ((x22
         (if (is-tc-simple-proc? x2)
           (simple->abstract-proc-type x2)
           x2)))
    (cond
      ((and (is-tc-simple-proc? (gen-car x1))
            (is-tt-procedure? x22))
       (d2wli 'deduce-proc-types "proc types 1")
       (deduce-proc-types tvar-table binder l-all-tvars
                          (gen-car x1)
                          x22
                          l-visited)
       #t)
      ((and (is-tc-param-proc? (gen-car x1))
            (is-tt-procedure? x22))
       (d2wli 'deduce-proc-types "proc types 2")
       (d2wli 'debug140 "proc HEP")
       (let ((tt-inst
              (tno-field-ref (gen-car x1) 'type-contents)))
         (deduce-proc-types tvar-table binder l-all-tvars
                            tt-inst
                            x22
                            l-visited))
       #t)
      ((and (is-tt-procedure? (gen-car x1))
            (is-tt-procedure? x22))
       (d2wli 'deduce-proc-types "proc types 3")
       (deduce-proc-types tvar-table binder l-all-tvars
                          (gen-car x1)
                          x22
                          l-visited)
       #t)
      (else #f))))


(define (handle-general-list lst)
  (cond
    ((null? lst) '())
    ((is-null-class-entity? lst) '())
    ((is-t-type-list? lst)
     ;; Formerly there was hfield-ref here.
     (tno-field-ref lst 'l-subexprs))
    ((pair? lst)
     (cons
      (handle-general-list (car lst))
      (handle-general-list (cdr lst))))
    ((is-gen-pair? lst)
     (translate-pair-class-expression0-fwd
      (list
       (handle-general-list (gen-car lst))
       (handle-general-list (gen-cdr lst)))))
    (else lst)))


(define (handle-source-splice type)
  (assert (is-gen-pair? type))
  (let ((hd (gen-car type)))
    (if (is-t-splice? hd)
      (tno-field-ref hd 'type-component)
      type)))


(define (handle-type-list type)
  (if (is-t-type-list? type)
    (tno-field-ref type 'l-subexprs)
    type))


(define (prepare-source-type binder type)
  (d2wli 'debug156 "prepare-source-type")
  (d2wli 'debug156 (debug-get-string type))
  (handle-source-splice
   (cond
     ((pair? type)
      (d2wli 'debug156 "prepare-source-type/1")
      (cons
       (handle-static-repr binder (car type) #f #f)
       (cdr type)))
     ((is-tc-pair? type)
      (d2wli 'debug156 "prepare-source-type/2")
      (make-tpci-pair
       (handle-static-repr binder (gen-car type) #t #f)
       (gen-cdr type)))
     ((is-abstract-pair? type)
      (d2wli 'debug156 "prepare-source-type/3")
      (make-apti tc-pair
                 (list
                  (handle-static-repr binder (gen-car type) #t #f)
                  (gen-cdr type))))
     (else (raise 'internal-error)))))


;; (define (is-signature? x)
;;   (and (is-target-object? x)
;;        (is-t-signature? (get-entity-type x))))


(define (is-proper-list-type-argument? tvars type-element)
  (d2wli 'type-deduction "is-proper-list-type-argument? ENTER")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-type0? type-element))
  (let ((b-result
         (and
          (is-t-type-variable? type-element)
          (begin
           (d2wli 'type-deduction "is-proper-list-type-argument?/1")
           #t)
          (and
           (member type-element (hfield-ref tvars 'l-all-tvars) type-variable=?)
           (begin
            (d2wli 'type-deduction "is-proper-list-type-argument? ENTER")
            #t)
           (not (type-var-inquire tvars type-element))))))    
    (d2wlin 'type-deduction "is-proper-list-type-argument? EXIT " b-result)
    b-result))


(define (deduce-uniform-lists tvars binder all-type-vars tt1 tt2 new-visited)
  (let* ((proper-type1?
          (and
           (is-gen-pair? tt1)
           (not (contains-free-tvars-general0-fwd?
                 (gen-car tt1)
                 (hfield-ref binder 'fixed-tvars)
                 '()))))
         (uniform?
          (and
           proper-type1?
           (is-t-uniform-list-type3? binder tt2)
           (is-proper-list-type-argument? tvars
                                          (get-uniform-list-param0 tt2))))
         (neul?
          (and
           proper-type1?
           (is-t-nonempty-uniform-list-type? binder tt2)
           (is-proper-list-type-argument? tvars
                                          (get-neul-param0 tt2)))))
    (d2wli 'deduce-uniform-lists "deduce-uniform-lists/1")
    (d2wli 'deduce-uniform-lists proper-type1?)
    (d2wli 'deduce-uniform-lists uniform?)
    (d2wli 'deduce-uniform-lists neul?)
    (d2wli 'deduce-uniform-lists (is-nonempty-tuple-type-fwd? (gen-car tt1)))
    (d2wli 'deduce-uniform-lists (debug-get-string (gen-car tt1)))
    ;; No type can be both uniform list type and nonempty uniform
    ;; list type.
    (assert (not (and uniform? neul?)))
    (cond
      ((and
        uniform?
        (is-nonempty-tuple-type-fwd? (gen-car tt1)))
       (deduce-tuple-uniform tvars binder all-type-vars (gen-car tt1) tt2)
       #t)
      ((and
        uniform?
        (is-t-nonempty-uniform-list-type? binder (gen-car tt1)))
       (deduce-neul-uniform tvars binder all-type-vars (gen-car tt1) tt2)
       #t)
      ((and
        uniform?
        (is-t-uniform-list-type3? binder (gen-car tt1)))
       ;; Here we know that both tt2 and first element of tt1 are
       ;; uniform list types.
       (deduce-type-params0
        tvars binder all-type-vars
        (list (get-uniform-list-param0 (gen-car tt1)))
        (get-uniform-list-param0 tt2)
        new-visited)
       #t)
      ((and
        uniform?
        (is-tuple-type-with-tail-fwd? (gen-car tt1)))
       (deduce-twt-uniform tvars binder all-type-vars (gen-car tt1) tt2)
       #t)
      ((and
        neul?
        (is-nonempty-tuple-type-fwd? (gen-car tt1)))
       (deduce-tuple-neul tvars binder all-type-vars
                          (gen-car tt1)
                          tt2)
       #t)
      ((and
        neul?
        (is-t-nonempty-uniform-list-type? binder (gen-car tt1)))
       (deduce-type-params0
        tvars binder all-type-vars
        (list (get-neul-param0 (gen-car tt1)))
        (get-neul-param0 tt2)
        new-visited)
        #t)
      ((and
        neul?
        (is-tuple-type-with-tail-fwd? (gen-car tt1)))
       (deduce-twt-neul tvars binder all-type-vars
                        (gen-car tt1)
                        tt2)
       #t)
      (else #f))))
            

(define (deduce-uniform-lists-reverse tvars binder all-type-vars
                                      tt1 tt2 new-visited)
  ;; The following check is probably not necessary.
  (if (is-gen-pair? tt1)
    (let* ((tt1c (gen-car tt1))
           (proper-type2?
            (and
             (not (contains-free-tvars-general0-fwd?
                   tt2
                   (hfield-ref binder 'fixed-tvars)
                   '()))))
           (uniform?
            (and
             proper-type2?
             (is-t-uniform-list-type3? binder tt1c)
             (is-proper-list-type-argument? tvars
                                            (get-uniform-list-param0 tt1c))))
           (neul?
            (and
             proper-type2?
             (is-t-nonempty-uniform-list-type? binder tt1c)
             (is-proper-list-type-argument? tvars
                                            (get-neul-param0 tt1c)))))
      (d2wli 'deduce-uniform-lists "deduce-uniform-lists-reverse/1")
      (d2wli 'deduce-uniform-lists proper-type2?)
      (d2wli 'deduce-uniform-lists uniform?)
      (d2wli 'deduce-uniform-lists neul?)
      ;; No type can be both uniform list type and nonempty uniform
      ;; list type.
      (assert (not (and uniform? neul?)))
      (cond
        ((and
          uniform?
          (is-nonempty-tuple-type-fwd? tt2))
         (deduce-tuple-uniform tvars binder all-type-vars tt2 tt1c)
         #t)
        ((and
          uniform?
          (is-t-nonempty-uniform-list-type? binder tt2))
         (deduce-neul-uniform tvars binder all-type-vars tt2 tt1c)
         #t)
        ((and
          uniform?
          (is-t-uniform-list-type3? binder tt2))
         ;; Here we know that both tt2 and first element of tt1 are
         ;; uniform list types.
         (deduce-type-params0
          tvars binder all-type-vars
          (list (get-uniform-list-param0 tt2))
          (get-uniform-list-param0 tt1c)
          new-visited)
         #t)
        ((and
          uniform?
          (is-tuple-type-with-tail-fwd? tt2))
         (deduce-twt-uniform tvars binder all-type-vars tt2 tt1c)
         #t)
        ((and
          neul?
          (is-nonempty-tuple-type-fwd? tt2))
         (deduce-tuple-neul tvars binder all-type-vars
                            tt2
                            tt1c)
         #t)
        ((and
          neul?
          (is-t-nonempty-uniform-list-type? binder tt2))
         (deduce-type-params0
          tvars binder all-type-vars
          (list (get-neul-param0 tt2))
          (get-neul-param0 tt1c)
          new-visited)
         #t)
        ((and
          neul?
          (is-tuple-type-with-tail-fwd? tt2))
         (deduce-twt-neul tvars binder all-type-vars
                          tt2
                          tt1c)
         #t)
        (else #f)))
    #f))


(define (do-deduce-type-params tvars binder all-type-vars
          tt1 tt2 new-visited)
  (d2wli 'type-deduction "do-deduce-type-params")
  (d2wli 'type-deduction (debug-get-string (hfield-ref binder 'fixed-tvars)))
  (cond
    ((begin (d2wli 'type-deduction4 "deduction/1")
            (is-t-type-variable? tt2))
     (deduce-simple-type tvars binder
                         all-type-vars tt1 tt2
                         new-visited))
    ((begin (d2wli 'type-deduction4 "deduction/2")
            (and (is-t-type-variable? (gen-car tt1))
                 (not (contains-type-variables-fwd? tt2))))
     (deduce-simple-type tvars binder all-type-vars
                         (list tt2) (gen-car tt1)
                         new-visited))
    ((begin (d2wli 'type-deduction4 "deduction/3")
            (and (is-t-signature? (gen-car tt1)) (is-t-signature? tt2)))
     (deduce-sgn-sgn tvars binder all-type-vars (gen-car tt1) tt2
                     new-visited))
    ((begin (d2wli 'type-deduction4 "deduction/4")
     (and (not (is-t-signature? (gen-car tt1))) (is-t-signature? tt2)))
     (d2wli 'type-deduction4 "deduction/4-1")
     (deduce-not-sgn-sgn tvars binder all-type-vars (gen-car tt1) tt2
                         new-visited))
    ((begin (d2wli 'type-deduction4 "deduction/5")
            (and (is-t-signature? (gen-car tt1)) (not (is-t-signature? tt2))))
     (deduce-sgn-not-sgn tvars binder all-type-vars (gen-car tt1) tt2
                         new-visited))
    (else
     (d2wli 'type-deduction "do-deduce-type-params/1")
     (d2wli 'type-deduction (debug-get-string (hfield-ref binder 'fixed-tvars)))
     (if (not (deduce-uniform-lists
               tvars binder all-type-vars tt1 tt2 new-visited))
       (if (not (deduce-uniform-lists-reverse
                 tvars binder all-type-vars tt1 tt2 new-visited))
         (cond
           ((is-gen-pair? tt2)
            (deduce-pair-class tvars binder
                               all-type-vars tt1 tt2
                               new-visited))
           ((is-t-rest? tt2)
            (deduce-rest-expression tvars binder
                                    all-type-vars tt1 tt2
                                    new-visited))
           ((is-t-splice? tt2)
            (deduce-type-params0 tvars binder
                                 all-type-vars
                                 (list tt1)
                                 (tno-field-ref tt2
                                                'type-component)
                                 new-visited))
           ((not (is-gen-pair? tt1))
            ;; This may be an error situation.
            #f)
           ((is-t-type-loop? tt2)
            (deduce-type-loop tvars binder tt1 tt2 new-visited))
           ((and
             (is-tt-union? (gen-car tt1))
             (not (is-tt-union? tt2)))
            (deduce-union-x tvars binder
                            all-type-vars
                            (gen-car tt1) tt2
                            new-visited))
           ((and
             (not (is-tt-union? (gen-car tt1)))
             (is-tt-union? tt2))
            (deduce-x-union tvars binder
                            all-type-vars tt1 tt2
                            new-visited))
           ((and
             (is-tt-union? (gen-car tt1))
             (is-tt-union? tt2))
            (deduce-union-union tvars binder
                                all-type-vars
                                (gen-car tt1) tt2
                                new-visited))
           ;; Note the order of following two branches.
           ((and
             (is-tc-gen-proc? (gen-car tt1))
             (is-tt-procedure? tt2)
             (contains-free-tvars-fwd? (tno-field-ref tt2 'type-arglist)))
            (deduce-gen-proc-abst-proc2
             tvars binder
             all-type-vars
             (gen-car tt1)
             tt2
             new-visited))
           ((and
             (is-tc-gen-proc? (gen-car tt1))
             (is-tt-procedure? tt2))
            (deduce-gen-proc-abst-proc
             tvars binder
             all-type-vars
             (gen-car tt1)
             tt2
             new-visited))
           ((and
             (is-tt-procedure? (gen-car tt1))
             (is-tc-gen-proc? tt2))
            (deduce-abst-proc-gen-proc
             tvars binder
             all-type-vars
             (gen-car tt1) tt2
             new-visited))
           ((is-t-apti? tt2)
            (if (is-t-apti? (gen-car tt1))
              (deduce-apti tvars binder all-type-vars
                           tt1 tt2 new-visited)
              #f))
           (else
            (if (not (deduce-proc-types1 tvars binder all-type-vars
                                         tt1 tt2 new-visited))
              (deduce-subreprs tvars binder
                               all-type-vars tt1 tt2
                               new-visited)))))))))
  

(define (deduce-type-params0 tvars binder all-type-vars
                             t1 t2 visited)
  (d2wli 'type-deduction0 "deduce-type-params0 ENTER")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (list? visited))
  (let ((old-indent gl-i-indent))
    (set! gl-i-indent (+ gl-i-indent 1))
    
    (set! gl-i-ctr2 (+ gl-i-ctr2 1))
    
    (if (eqv? gl-i-ctr2 50) (d2wli 'debug141 "HEP50"))
    
    ;; (if (eqv? gl-i-ctr2 303)
    ;;   (set! gl-l-active-debug-categories '(debug130 type-deduction3 type-deduction2 type-deduction)))
    (d2wli 'type-deduction0 gl-i-ctr2)
    (d2wli 'type-deduction0 "t1:")
    (d2wli 'type-deduction0 (debug-get-string t1))
    (d2wli 'type-deduction0 "t2:")
    (d2wli 'type-deduction0 (debug-get-string t2))
    (d2wli 'type-deduction2 "type variables:")
    (d2wli 'type-deduction2
           (debug-get-string (hfield-ref tvars 'l-all-tvars)))
    ;; (d2wli 'type-deduction2 "fixed type variables:")
    ;; (d2wli 'type-deduction2
    ;;        (debug-get-string (hfield-ref binder 'fixed-tvars)))
    (d2wli 'type-deduction2 "deductions:")
    (d2wli 'type-deduction2 (debug-get-string (hfield-ref tvars 'bindings)))
    (d2wli 'type-deduction2 "fixed tvars:")
    (d2wli 'type-deduction2 (debug-get-string (hfield-ref binder 'fixed-tvars)))
    
    (cond
      ((and (is-entity? t2) (is-null-class-entity? t2))
       '())
      (else
       (cond
         ((not (is-gen-pair? t1))
          (assert (is-type0? t1))
          (d2wli 'type-deduction "deduce-type-params0/1")
          (if (is-t-splice? t2)
            (deduce-type-params0 tvars binder
                                 all-type-vars
                                 (list (handle-type-list (handle-static-repr binder t1 #f #f)))
                                 ;; Formerly we had hfield-ref here.
                                 (tno-field-ref t2 'type-component)
                                 visited)
            ;; This may be an error situation.
            #f))
         ((member (cons (gen-car t1) t2) visited eq-pairs?)
          (d2wli 'type-deduction "deduce-type-params0/2")
          '())
         ;; ((pair? t2)
         ;;  (let ((new-visited (cons (cons (gen-car t1) t2) visited)))
         ;;    (deduce-type-params0 tvars binder
         ;; 			 all-type-vars
         ;; 			 (list (gen-car t1))
         ;; 			 (gen-car t2)
         ;; 			 new-visited)
         ;;    (deduce-type-params0 tvars binder
         ;; 			 all-type-vars
         ;; 			 (list (gen-cdr t1))
         ;; 			 (gen-cdr t2)
         ;; 			 new-visited)))
         (else
          (d2wli 'type-deduction "deduce-type-params0/3")
          (let ((new-visited (cons (cons (gen-car t1) t2) visited)))
            (let* ((tt1 (handle-type-list (prepare-source-type binder t1)))
                   (tt2 (handle-type-list (handle-static-repr binder t2 #f #f))))
              (d2wli 'type-deduction "deduce-type-params0/3-1")
              (d2wli 'type-deduction (debug-get-string tt1))
              (d2wli 'type-deduction (debug-get-string tt2))
              (if (and (is-gen-pair? tt1)
                       (or
                        (contains-type-variables-fwd? tt1)
                        (contains-type-variables-fwd? tt2)))
                (begin
                 (d2wli 'type-deduction "deduce-type-params0/3-2")
                 (do-deduce-type-params
                   tvars binder all-type-vars
                   tt1 tt2 new-visited)))))))))
    (set! gl-i-indent old-indent)
    (d2wli 'type-deduction0 "deduce-type-params0 EXIT")
    (d2wli 'type-deduction0
           (debug-get-string (hfield-ref tvars 'bindings)))
    (d2wli 'type-deduction2
           (debug-get-string (hfield-ref tvars 'l-all-tvars)))))


(define (deduce-type-loop tvars binder
          src-args type-loop visited)
  (d2wli 'deduce-type-loop "deduce-type-loop ENTER")
  (d2wli 'deduce-type-loop (debug-get-string src-args))
  (d2wli 'deduce-type-loop (debug-get-string type-loop))
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (is-t-type-loop? type-loop))
  (assert (list? visited))
  (let ((iter-var (tno-field-ref type-loop 'tvar))
        (subtype-list (tno-field-ref type-loop 'x-subtypes))
        (iter-expr (tno-field-ref type-loop 'x-iter-expr))
        (all-type-vars (hfield-ref tvars 'l-all-tvars)))
    (let* ((deduced-items '())
           ;; How do we know that src-args is a general pair?
           (source-list0 (gen-car src-args))
           (source-list
            (cond
              ((list? source-list0)
               source-list0)
              ((is-t-type-list? source-list0)
               ;; Formerly we had hfield-ref here.
               (tno-field-ref source-list0 'l-subexprs))
              ((is-tuple-type-fwd? binder source-list0)
               (tuple-type->list-reject-cycles-fwd source-list0))
              (else
               #f)))
           (all-type-vars1 (cons iter-var all-type-vars))
           (l-old-tvars (hfield-ref tvars 'l-all-tvars)))
      ;; Is this needed?
      (hfield-set! tvars 'l-all-tvars all-type-vars1)
      (d2wli 'deduce-type-loop "deduce-type-loop/1")
      (d2wli 'deduce-type-loop (debug-get-string all-type-vars1))
      (cond
        ((and (is-t-type-loop? source-list0)
              (is-t-type-variable? subtype-list))
         (d2wli 'deduce-type-loop "deduce-type-loop/2")
         (let ((target-tvar subtype-list)
               (src-subtype-list (tno-field-ref source-list0 'x-subtypes))
               (fixed-tvars (hfield-ref binder 'fixed-tvars)))
           (if (and (equal-reprs2-fwd? 
                     binder
                     iter-expr
                     (tno-field-ref source-list0 'x-iter-expr)
                     iter-var
                     (tno-field-ref source-list0 'tvar))
                    (memv target-tvar all-type-vars)
                    (not (type-var-inquire tvars target-tvar))
                    (not (contains-free-tvars-general0-fwd? 
                          src-subtype-list fixed-tvars '())))
             (begin
              (d2wl 'debug39 "add/1")
              ;; The value of the binding may not be a normal
              ;; list consisting of types.
              (if (not (list? src-subtype-list))
                (type-var-add-new-binding!
                 tvars binder
                 target-tvar src-subtype-list)
                ;; It might be good to check src more accurately
                ;; in the following.
                (type-var-add-new-binding!
                 tvars binder target-tvar
                 (construct-toplevel-type-repr-fwd
                  binder src-subtype-list)))))))
        ((and (is-t-uniform-list-type? binder source-list0)
              (is-t-type-variable? subtype-list))
         (d2wli 'deduce-type-loop "deduce-type-loop/3")
         (if (not (type-var-inquire tvars subtype-list))
           (let ((new-deductions (make-hrecord <type-var-assoc-table>
                                               (hfield-ref tvars 'bindings)
                                               '() all-type-vars1 '() '()))
                 (x-new-src
                  (list (get-uniform-list-param binder source-list0))))
             (deduce-type-params0 new-deductions binder all-type-vars1
                                  x-new-src iter-expr visited)
             (let ((p-new-guess (type-var-inquire new-deductions iter-var)))
               (if (not (eq? p-new-guess #f))
                 (let ((tt-list (make-tt-uniform-list (cdr p-new-guess))))
                   (d2wl 'debug39 "add/1-2")
                   (type-var-add-new-binding! tvars binder
                                              subtype-list
                                              tt-list)))))))
        ((and (is-t-type-variable? subtype-list)
              (list? source-list)
              (eqv? (length source-list) 1)
              (is-t-splice? (car source-list))
              (is-t-uniform-list-type0?
               (tno-field-ref (car source-list) 'type-component)))
         (d2wli 'loop "deduce-type-loop/3")	
         (if (not (type-var-inquire tvars subtype-list))
           (let* ((new-tvar-values
                   (make-hrecord <type-var-assoc-table>
                                 (hfield-ref tvars 'bindings)
                                 '() all-type-vars1 '() '()))
                  (ul (tno-field-ref (car source-list) 'type-component))
                  (x-new-src
                   (list (get-uniform-list-param0 ul))))
             (deduce-type-params0 new-tvar-values binder
                                  all-type-vars1
                                  x-new-src iter-expr visited)
             (let ((new-deduction (type-var-inquire new-tvar-values iter-var)))
               (if new-deduction
                 (let ((tt-list
                        (make-tt-uniform-list
                         (cdr new-deduction))))
                   (d2wli 'loop "deduce-type-loop/3-1")
                   (d2wli 'loop (debug-get-string subtype-list))
                   (type-var-add-new-binding! tvars binder subtype-list tt-list)))))))
        ((and (not (or (eqv? source-list '()) (eqv? source-list #f))))
         (d2wli 'deduce-type-loop "deduce-type-loop/4")
         (set! gl-counter19 (+ gl-counter19 1))
         (d2wli 'deduce-type-loop gl-counter19)
         ;;  (set! gl-l-active-debug-categories
         ;;    (append gl-l-active-debug-categories '(type-deduction type-deduction2)))
         (do ((cur-src source-list (cdr cur-src)))
           ((null? cur-src))
           (let* ((new-deductions (make-hrecord <type-var-assoc-table>
                                                (hfield-ref tvars 'bindings)
                                                '() all-type-vars1 '() '())))
             (deduce-type-params0 new-deductions binder all-type-vars1
                                  cur-src iter-expr visited)
             (let ((new-guess (type-var-inquire new-deductions iter-var)))
               (set! deduced-items
                 (append deduced-items (list new-guess))))))
         (d2wli 'deduce-type-loop "deduce-type-loop/4-1")
         (d2wli 'deduce-type-loop (debug-get-string deduced-items))
         (let ((result
                (cond
                  ((memq #f deduced-items)
                   '())
                  ((and (is-t-type-variable? subtype-list)
                        (not (type-var-inquire tvars subtype-list)))
                   (d2wl 'debug39 "add/2")
                   (type-var-add-new-binding! tvars binder
                                              subtype-list
                                              (map cdr deduced-items)))
                  (else
                   (let ((types
                          (map* (lambda (guess-item)
                                  (let* ((bindings
                                          (append (hfield-ref tvars 'bindings)
                                                  (list guess-item)))
                                         ;; Should we have type-check? = #f here?
                                         (repr (bind-type-vars-fwd
                                                binder bindings
                                                iter-expr)))
                                    repr))
                                deduced-items)))
                     ;; It should be the same to use all-type-vars or
                     ;; all-type-vars1 here since the occurrences of
                     ;; iter-var have been bound by the map* call above.
                     (deduce-type-params0 tvars binder
                                          all-type-vars src-args types
                                          visited))))))
           result))
        ((eqv? source-list '())
         (d2wli 'deduce-type-loop "deduce-type-loop/5")
         (if (and (is-t-type-variable? subtype-list)
                  (not (type-var-inquire tvars subtype-list)))
           (type-var-add-new-binding! tvars binder subtype-list '())))
        (else
         '())))))
  

(define (deduce-rest-expression tvars binder
                                all-type-vars src-args target-type 
                                visited)
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (list? all-type-vars))
  (assert (and-map? is-t-type-variable? all-type-vars))
  (assert (is-t-rest? target-type))
  (assert (list? visited))
  ;; Formerly we had hfield-ref here.
  (let* ((target-item-type (tno-field-ref target-type 'type-component))
         (result
          (deduce-type-params0 tvars binder
                               all-type-vars
                               src-args target-item-type
                               visited)))
    result))


(define (update-tvar-assoc! p-binding binder tvar-new x-new-src)
  (assert (and (pair? p-binding) (is-t-type-variable? (car p-binding))))
  (if (contains-specified-tvars-fwd? (cdr p-binding) (list tvar-new))
    (let* ((l-assoc (list (cons tvar-new x-new-src)))
           (x-new-value
            (bind-type-vars-no-check-fwd binder
                                         l-assoc
                                         (cdr p-binding))))
      (set-cdr! p-binding x-new-value))))


(define (update-tvar-table! tvars binder tvar-new x-new-src)
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (d2wlin 'update-tvar-table "tvar: " (debug-get-string tvar-new))
  (let ((bindings (hfield-ref tvars 'bindings)))
    (d2wli 'update-tvar-table "update-tvar-table! old bindings:")
    (d2wli 'update-tvar-table (debug-get-string bindings))
    (for-each (lambda (p-binding)
                (update-tvar-assoc! p-binding binder tvar-new x-new-src))
              bindings)
    (d2wli 'update-tvar-table "update-tvar-table! new bindings:")
    (d2wli 'update-tvar-table (debug-get-string bindings))))


(define (check-new-tvar tvars binder tvar-new x-new-src)
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (is-t-type-variable? tvar-new))
  (let ((l-new-tvars (hfield-ref tvars 'l-new-tvars)))
    (if (contains-specified-tvars-fwd? x-new-src l-new-tvars)
      (let* ((l-bindings (hfield-ref tvars 'bindings))
             (l-new-bindings
              (map (lambda (tvar)
                     (let ((p (assoc tvar l-bindings type-variable=?)))
                       (if (not p)
                         (my-raise1 'type-variable-binding-not-found
                                    (list (cons 'tvar-new tvar-new)
                                          (cons 'l-new-tvars l-new-tvars)
                                          (cons 'x-new-src x-new-src)
                                          (cons 'l-bindings l-bindings))))
                       p))
                   l-new-tvars)))
        (bind-type-vars-no-check-fwd binder l-new-bindings x-new-src))
      x-new-src)))


(define (add-deduction tvars binder tvar src)
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (is-t-type-variable? tvar))
  ;; The value of the binding may not be a normal
  ;; list consisting of types.
  (let ((x-src-value
         (if (not (list? src))
           src
           ;; It might be good to check src more accurately
           ;; in the following.
           (construct-toplevel-type-repr-fwd
            binder src))))
    (update-tvar-table! tvars binder
                        tvar x-src-value)
    (d2wli 'add-deduction "add/4")
    (let ((x-src-value2 (check-new-tvar tvars binder
                                        tvar
                                        x-src-value)))
      (d2wli 'add-deduction "add/5")
      (d2wli 'add-deduction (debug-get-string x-src-value))
      (d2wli 'add-deduction (debug-get-string x-src-value2))
      (type-var-add-new-binding!
       tvars binder
       tvar x-src-value2))))


(define (deduce-simple-type tvars binder all-type-vars			  
                            source-list target-type visited) 
  (d2wli 'add-deduction "deduce-simple-type ENTER")
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? all-type-vars)
               (and-map? is-t-type-variable? all-type-vars)))
  (assert (is-t-type-variable? target-type))
  (assert (list? visited))
  
  (d2wli 'add-deduction (debug-get-string target-type))
  ;; (d2wli 'add-deduction
  ;;        (debug-get-string (hfield-ref binder 'fixed-tvars)))
  
  (let ((result
         (if (is-gen-pair? source-list)
           (let ((src (gen-car source-list))
                 (fixed-tvars (hfield-ref binder 'fixed-tvars)))
             (d2wli 'add-deduction "deduce-simple-type/1")
             (d2wli 'add-deduction (debug-get-string src))
             (d2wli 'add-deduction (debug-get-string fixed-tvars))
             (if (and
                  (member target-type (hfield-ref tvars 'l-all-tvars)
                          type-variable=?)
                  (begin 
                   (d2wli 'add-deduction "deduce-simple-type/1-1")
                   #t)
                  (not (hrecord-is-instance? src <normal-variable>))
                  (begin 
                   (d2wli 'add-deduction "deduce-simple-type/1-2")
                   #t)
                  (not (and (is-t-type-variable? src)
                            (type-variable=? src target-type)))
                  (begin 
                   (d2wli 'add-deduction "deduce-simple-type/1-3")
                   #t)
                  (not (type-var-inquire tvars target-type))
                  (begin 
                   (d2wli 'add-deduction "deduce-simple-type/1-4")
                   #t)
                  (not (contains-free-tvars-general0-fwd? src fixed-tvars
                                                          '()))
                  (begin 
                   (d2wli 'add-deduction "deduce-simple-type/1-5")
                   #t))
               (begin
                (add-deduction tvars binder target-type src)))))))
    (d2wli 'add-deduction "deduce-simple-type EXIT")
    result))


;; Should we use tvars.l-all-tvars in the following three procedures?


(define (deduced-all-type-vars? tvars all-type-vars)
  (let ((bindings (hfield-ref tvars 'bindings)))
    (and-map? (lambda (tvar) (not (eqv? (assoc tvar bindings type-variable=?)
                                        #f)))
              all-type-vars)))


(define (tvar-values-correct? tvars all-type-vars)
  (let ((bindings (hfield-ref tvars 'bindings)))
    (and-map? (lambda (binding)
                (let ((val (cdr binding)))
                  (not (contains-specified-tvars-fwd?
                        val all-type-vars))))
              bindings)))


(define (all-tvars-correct? tvars all-type-vars)
  (and (deduced-all-type-vars? tvars all-type-vars)
       (tvar-values-correct? tvars all-type-vars)))


(define (all-tvars-correct1? tvars)
  (let ((all-type-vars
         (list-set-diff (hfield-ref tvars 'l-all-tvars)
                        (hfield-ref tvars 'l-aux-tvars)
                        type-variable=?)))
    (and (deduced-all-type-vars? tvars all-type-vars)
         (tvar-values-correct? tvars all-type-vars))))


(define (get-tvar tvar-list var)
  (if (and
       (is-t-type-variable? var)
       (not (member var (singleton-get-element tvar-list)
                    type-variable=?)))
    (begin
     (d2wlin 'free-tvars "new free tvar: " (debug-get-string var))
     (singleton-set-element! tvar-list
                             (cons var (singleton-get-element tvar-list))))))


(define (get-all-tvars0 tvar-list item visited)
  (let ((new-visited (cons item visited)))
    (cond
      ((null? item) '())
      ((memv item visited) '())
      ((and (is-target-object? item) (is-incomplete-object? item)) '())
      ((pair? item)
       (get-all-tvars0 tvar-list (car item) new-visited)
       (get-all-tvars0 tvar-list (cdr item) new-visited))
      ((is-t-type-variable? item)
       (get-tvar tvar-list item))
      ((is-entity? item)
       (let ((subexprs (get-subexpressions-fwd item)))
         (if (not-null? subexprs)
           (for-each (lambda (subexpr)
                       (get-all-tvars0 tvar-list subexpr new-visited))
                     subexprs)
           '())))
      (else '()))))


(define (get-all-tvars item)
  (let ((tvar-list (make-singleton '())))
    (get-all-tvars0 tvar-list item '())
    ;; Reversion of the list is probably not necessary.
    (reverse (singleton-get-element tvar-list))))


(set! get-all-tvars-fwd get-all-tvars)


(define (get-all-free-tvars0 tvar-list item bound visited)
  (d2wli 'free-tvars "get-all-free-tvars0")
  (d2wli 'free-tvars (debug-get-string item))
  (fluid-let ((gl-i-indent (+ gl-i-indent 1)))
    (let ((new-visited (cons item visited)))
      (cond
        ((null? item) '())
        ((memv item visited) '())
        ((pair? item)
         (get-all-free-tvars0 tvar-list (car item) bound new-visited)
         (get-all-free-tvars0 tvar-list (cdr item) bound new-visited))
        ((is-t-type-variable? item)
         (if (not (member item bound type-variable=?))
           (get-tvar tvar-list item)
           '()))
        ((is-t-type-loop? item)
         (let ((new-bound (append bound (list (tno-field-ref item 'tvar)))))
           (get-all-free-tvars0 tvar-list (tno-field-ref item 'x-subtypes)
                                new-bound new-visited)
           (get-all-free-tvars0 tvar-list (tno-field-ref item 'x-iter-expr)
                                new-bound new-visited)))
        ((is-entity? item)
         (let ((subexprs (get-subexpressions-fwd item)))
           (if (not-null? subexprs)
             (for-each (lambda (subexpr)
                         (get-all-free-tvars0 tvar-list subexpr bound new-visited))
                       subexprs)
             '())))
        (else '())))))


(define (get-all-free-tvars item)
  (let ((tvar-list (make-singleton '())))
    (get-all-free-tvars0 tvar-list item '() '())
    ;; Reversion of the list is probably not necessary.
    (reverse (singleton-get-element tvar-list))))


(set! get-all-free-tvars-fwd get-all-free-tvars)


(define (get-all-free-tvars01 tvar-list item bound visited)
  (let ((new-visited (cons item visited)))
    (cond
      ((null? item) '())
      ((memv item visited) '())
      ((pair? item)
       (get-all-free-tvars01 tvar-list (car item) bound new-visited)
       (get-all-free-tvars01 tvar-list (cdr item) bound new-visited))
      ((is-t-type-variable? item)
       (if (not (member item bound type-variable=?))
         (get-tvar tvar-list item)
         '()))
      ((is-tc-param-proc? item)
       (let ((new-bound (append bound (tno-field-ref item 'l-tvars))))
         (get-all-free-tvars01 tvar-list (tno-field-ref item 'type-contents)
                               new-bound new-visited)))
      ((is-t-type-loop? item)
       (let ((new-bound (append bound (list (tno-field-ref item 'tvar)))))
         (get-all-free-tvars01 tvar-list (tno-field-ref item 'x-subtypes)
                               new-bound new-visited)
         (get-all-free-tvars01 tvar-list (tno-field-ref item 'x-iter-expr)
                               new-bound new-visited)))
      ((is-entity? item)
       (let ((subexprs (get-subexpressions-fwd item)))
         (if (not-null? subexprs)
           (for-each (lambda (subexpr)
                       (get-all-free-tvars01 tvar-list subexpr bound
                                             new-visited))
                     subexprs)
           '())))
      (else '()))))


(define (get-all-free-tvars1 item)
  (let ((tvar-list (make-singleton '())))
    (get-all-free-tvars01 tvar-list item '() '())
    ;; Reversion of the list is probably not necessary.
    (reverse (singleton-get-element tvar-list))))


(set! get-all-free-tvars1-fwd get-all-free-tvars1)


(define (get-bound-tvars0 tvar-list item l-visited)
  (set! gl-counter33 (+ gl-counter33 1))
  (let ((l-new-visited (cons item l-visited)))
    (cond
      ((null? item) '())
      ((memq item l-visited) '())
      ((and (is-target-object? item) (is-incomplete-object? item)) '())
      ((pair? item)
       (get-bound-tvars0 tvar-list (car item) l-new-visited)
       (get-bound-tvars0 tvar-list (cdr item) l-new-visited))
      ((is-tc-param-proc? item)
       (for-each (lambda (tvar) (get-tvar tvar-list tvar))
                 (tno-field-ref item 'l-tvars))
       (get-bound-tvars0 tvar-list (tno-field-ref item 'type-contents)
                         l-new-visited))
      ((is-t-type-loop? item)
       (get-tvar tvar-list (tno-field-ref item 'tvar))
       (get-bound-tvars0 tvar-list (tno-field-ref item 'x-subtypes)
                         l-new-visited)
       (get-bound-tvars0 tvar-list (tno-field-ref item 'x-iter-expr)
                         l-new-visited))
      ((is-entity? item)
       (let ((subexprs (get-subexpressions-fwd item)))
         (if (not-null? subexprs)
           (for-each (lambda (subexpr)
                       (get-bound-tvars0 tvar-list subexpr l-new-visited))
                     subexprs)
           '())))
      (else '())))
  (dummy #f)) ;; for profiling


(define (get-bound-tvars item)
  (set! gl-i-counter100 (+ gl-i-counter100 1))
  (let ((tvar-list (make-singleton '())))
    (get-bound-tvars0 tvar-list item '())
    ;; Reversion of the list is probably not necessary.
    (reverse (singleton-get-element tvar-list))))


(define (deduce-step-forward tvars binder
                             cur-src cur-target
                             old-count old-state)
  (d2wli 'deduce-argument-types "deduce-step-forward ENTER")
  ;; The all-type-vars argument of deduce-type-params0 is not used.
  (deduce-type-params0 tvars binder '()
                       cur-src cur-target '())
  (d2wli 'deduce-argument-types "deduce-step-forward/1")
  (let ((new-count (length (hfield-ref tvars 'bindings)))
        (all-type-vars
         (list-set-diff (hfield-ref tvars 'l-all-tvars)
                        (hfield-ref tvars 'l-aux-tvars)
                        type-variable=?)))
    (dvar1-set! tvars)
    (dvar2-set! all-type-vars)
    (dvar3-set! cur-src)
    (dvar4-set! cur-target)
    ;; (assert (<= new-count (length all-type-vars)))
    (let ((result
           (cond
             ((deduced-all-type-vars? tvars all-type-vars)
              (list -1 new-count))
             ((= old-count new-count)
              (list (- old-state 1) new-count))
             (else
              (list 2 new-count)))))
      (d2wli 'deduce-argument-types "deduce-step-forward EXIT")
      result)))


(define (deduce-step-backward tvars binder
                              cur-src cur-target
                              old-count old-state)
  (d2wli 'deduce-argument-types "deduce-step-backward ENTER")
  ;; The all-type-vars argument of deduce-type-params0 is not used.
  (deduce-type-params0 tvars binder '()
                       cur-target cur-src '())
  (d2wli 'deduce-argument-types "deduce-step-backward/1")
  (let ((new-count (length (hfield-ref tvars 'bindings)))
        (all-type-vars
         (list-set-diff (hfield-ref tvars 'l-all-tvars)
                        (hfield-ref tvars 'l-aux-tvars)
                        type-variable=?)))
    ;; (assert (<= new-count (length all-type-vars)))
    (let ((result
           (cond
             ((deduced-all-type-vars? tvars all-type-vars)
              (list -1 new-count))
             ((= old-count new-count)
              (list (- old-state 1) new-count))
             (else
              (list 2 new-count)))))
      (d2wli 'deduce-argument-types "deduce-step-backward EXIT")
      result)))


(define (compute-new-tvars l-all-tvars-old l-old-tvars l-new-tvars)
  (union-of-lists
   (list-set-diff l-all-tvars-old l-old-tvars type-variable=?)
   l-new-tvars
   type-variable=?))


;; It is essential that the old and new type variables are sorted so that
;; they match each other.
(define (replace-tvars! tvar-table binder l-old-tvars l-new-tvars)
  (assert (hrecord-is-instance? tvar-table <type-var-assoc-table>))
  (assert (is-binder? binder))
  (assert (and (list? l-old-tvars)
               (for-all is-t-type-variable? l-old-tvars)))
  (assert (and (list? l-new-tvars)
               (for-all is-t-type-variable? l-new-tvars)))
  (assert (eqv? (length l-old-tvars) (length l-new-tvars)))
  (let ((l-all-new-tvars
         (compute-new-tvars (hfield-ref tvar-table 'l-all-tvars)
                            l-old-tvars l-new-tvars))
        (al-replace (map cons l-old-tvars l-new-tvars))
        (al-bindings (hfield-ref tvar-table 'bindings))
        (l-old-tvars (hfield-ref tvar-table 'l-all-tvars)))
    (hfield-set! tvar-table 'l-all-tvars l-all-new-tvars)
    (for-each (lambda (p-binding)
                (let* ((tvar (car p-binding))
                       (p-match (assoc tvar al-replace type-variable=?))
                       (x-new-value
                        (bind-type-vars-no-check-fwd binder
                                                     al-replace
                                                     (cdr p-binding))))
                  (if p-match (set-car! p-binding (cdr p-match)))
                  (set-cdr! p-binding x-new-value)))
              al-bindings)
    (hfield-set! tvar-table 'l-all-tvars l-old-tvars)))


(define (is-tvar-assoc-list? x)
  (and (list? x)
       (for-all (lambda (p-binding)
                  (and (pair? p-binding)
                       (is-t-type-variable? (car p-binding))
                       (is-t-type-variable? (cdr p-binding))))
                x)))


(define (is-sgt-al-tvar? x)
  (and (is-singleton? x)
       (is-tvar-assoc-list? (singleton-get-element x))))


(define (get-original-binding sgt-al-original tvar-old)
  (assert (is-t-type-variable? tvar-old))
  (let* ((al-original (singleton-get-element sgt-al-original))
         (p (assoc tvar-old al-original type-variable=?)))
    (if p (cdr p) tvar-old)))


(define (add-original-binding! sgt-al-original tvar-new tvar-old)
  (let ((tvar-old2 (get-original-binding sgt-al-original tvar-old)))
    (singleton-set-element! sgt-al-original
                            (cons (cons tvar-new tvar-old2)
                                  (singleton-get-element sgt-al-original)))))


(define (update-original-bindings! sgt-al-original al-tvars)
  (assert (is-sgt-al-tvar? sgt-al-original))
  (assert (is-tvar-assoc-list? al-tvars))
  (d2wl 'unique2 "update-original-bindings!")
  (d2wl 'unique2 (debug-get-string al-tvars))
  (for-each (lambda (p)
              ;; Note the ordering of (cdr p) and (car p).
              (add-original-binding! sgt-al-original (cdr p) (car p)))
            al-tvars))


(define (get-original-bindings sgt-al-original al-new-bindings)
  (assert (is-sgt-al-tvar? sgt-al-original))
  (map (lambda (p-binding)
         (let ((tvar-old-value (get-original-binding sgt-al-original (car p-binding))))
           (cons (cdr p-binding) tvar-old-value)))
       al-new-bindings))


(define (update-arg-tvar-bindings tvar-table sgt-al-original)
  (let* ((al-bindings (hfield-ref tvar-table 'bindings)))
    (map (lambda (p-binding)
           (cons (get-original-binding sgt-al-original (car p-binding))
                 (let ((x-tail (cdr p-binding)))
                   (if (is-t-type-variable? x-tail)
                     (get-original-binding sgt-al-original x-tail)
                     x-tail))))
         al-bindings)))


(define (update-arg-tvar-bindings! tvar-table sgt-al-original)
  (hfield-set! tvar-table 'bindings
               (update-arg-tvar-bindings tvar-table sgt-al-original)))


(define (deduce-argument-types binder tvar-table
                               all-tvars src target)
  (d2wli 'deduce-argument-types "deduce-argument-types ENTER")
  ;; (d2wli 'deduce-argument-types gl-l-active-debug-categories)
  ;; (d2wli 'type-deduction (debug-get-string all-tvars))
  ;; (disp src target)
  
  (set! gl-counter28 (+ gl-counter28 1))
  (d2wl 'type-deduction3 gl-counter28)
  ;; (if (eqv? gl-counter28 4)
  ;;    (set! gl-l-active-debug-categories
  ;;      '(sgn1 type-deduction4 type-deduction2 add-deduction)))
  (d2wli 'deduce-argument-types (debug-get-string src))
  (d2wli 'deduce-argument-types (debug-get-string target))
  (d2wli 'deduce-argument-types (debug-get-string all-tvars))
  (d2wli 'type-deduction3
         (debug-get-string (hfield-ref tvar-table 'l-aux-tvars)))
  
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? tvar-table <type-var-assoc-table>))
  (assert (and (list? all-tvars) 
               (and-map? is-t-type-variable? all-tvars)))
  (assert (null? (hfield-ref tvar-table 'bindings)))
  
  (hfield-set! tvar-table 'l-all-tvars all-tvars)
  
  (fluid-let ((*sgt-al-original* (make-singleton '())))
    (let ((old-count-src 0)
          (old-count-target 0)
          (cur-src src)
          (cur-target target)
          (state 2)
          (dir-fwd? #t))
      (do ((i 0 (+ i 1))) ((<= state 0))
        (d2wlin 'deduce-argument-types  "deduce-argument-types: starting step " i)
        (if dir-fwd?
          (if (> state 0)
            (begin
             (d2wli 'debug1003 "deduce-argument-types/1-1")
             (hfield-set! tvar-table 'l-new-tvars '())
             (d2wli 'debug1003 "deduce-argument-types/1-2")
             (let* ((res
                     (deduce-step-forward tvar-table binder
                                          (list cur-src) cur-target
                                          old-count-target state))
                    (cur-target2
                     (fluid-let ((*b-param->simple* #f))
                       (bind-type-vars-no-check-fwd
                        binder
                        (hfield-ref tvar-table 'bindings)
                        cur-target)))
                    (cur-src2
                     (fluid-let ((*b-param->simple* #f))
                       (bind-type-vars-no-check-fwd
                        binder
                        (hfield-ref tvar-table 'bindings)
                        cur-src))))
               (set! state (car res))
               (set! old-count-target (cadr res))
               (d2wli 'deduce-argument-types
                      "deduce-argument-types: bound tvars (fwd)")
               (d2wli 'deduce-argument-types "old source:")
               (d2wli 'deduce-argument-types (debug-get-string cur-src))
               (d2wli 'deduce-argument-types "old target:")
               (d2wli 'deduce-argument-types (debug-get-string cur-target))
               (set! cur-target cur-target2) 
               (set! cur-src cur-src2) 
               (disp cur-src cur-target)
               (d2wli 'deduce-argument-types
                      (debug-get-string (tvar-table-get-final-tvars tvar-table)))
               (d2wli 'deduce-argument-types "new bindings:")
               (d2wli 'deduce-argument-types
                      (debug-get-string (hfield-ref tvar-table 'bindings)))
               ;; (d2wli 'type-deduction state)
               ;; (d2wli 'type-deduction
               ;; 	 (debug-get-string
               ;; 	  (map car (hfield-ref tvar-table 'bindings))))
               #f)))
          (if (> state 0)
            (begin
             (hfield-set! tvar-table 'l-new-tvars '())
             (let* ((res
                     (deduce-step-backward tvar-table binder
                                           cur-src (list cur-target)
                                           old-count-src state))
                    (cur-target2
                     (fluid-let ((*b-param->simple* #f))
                       (bind-type-vars-no-check-fwd
                        binder
                        (hfield-ref tvar-table 'bindings)
                        cur-target)))
                    (cur-src2
                     (fluid-let ((*b-param->simple* #f))
                       (bind-type-vars-no-check-fwd
                        binder
                        (hfield-ref tvar-table 'bindings)
                        cur-src))))
               (set! state (car res))
               (set! old-count-src (cadr res))
               (d2wli 'deduce-argument-types
                      "deduce-argument-types: bound tvars (bwd)")
               (d2wli 'deduce-argument-types "old source:")
               (d2wli 'deduce-argument-types (debug-get-string cur-src))
               (d2wli 'deduce-argument-types "old target:")
               (d2wli 'deduce-argument-types (debug-get-string cur-target))
               (set! cur-target cur-target2)
               (set! cur-src cur-src2)
               (disp cur-src cur-target)
               (d2wli 'deduce-argument-types
                      (debug-get-string (tvar-table-get-final-tvars tvar-table)))
               (d2wli 'deduce-argument-types "bindings:")
               (d2wli 'deduce-argument-types
                      (debug-get-string (hfield-ref tvar-table 'bindings)))
               ;; (d2wli 'type-deduction state)
               ;; (d2wli 'type-deduction
               ;; 	 (debug-get-string
               ;; 	  (map car (hfield-ref tvar-table 'bindings))))
               #f))))
        (set! dir-fwd? (not dir-fwd?)))
      (begin
       (hfield-set! tvar-table 'l-final-tvars
                    (list-set-diff (hfield-ref tvar-table 'l-all-tvars)
                                   (hfield-ref tvar-table 'l-aux-tvars)
                                   type-variable=?))
       (update-arg-tvar-bindings! tvar-table *sgt-al-original*)
       (d2wli 'deduce-argument-types "sgt-al-original:")
       (d2wli 'deduce-argument-types
              (debug-get-string (singleton-get-element *sgt-al-original*)))
       (d2wlin 'deduce-argument-types "deduce-argument-types EXIT " (= state -1))
       (d2wli 'deduce-argument-types (debug-get-string (hfield-ref tvar-table 'bindings)))
       (eqv? state -1)))))


(set! deduce-argument-types-fwd deduce-argument-types)


;; Maybe we should make the following procedure safe for cycles.
;; (define (get-expr-type expr)
;;   (cond
;;     ((null? expr) tc-nil)
;;     ((pair? expr)
;;      (translate-pair-class-expression0-fwd
;;       (list (get-expr-type (car expr))
;;             (get-expr-type (cdr expr)))))
;;     (else
;;      (get-entity-type expr))))


;; Maybe we should make the following procedure safe for cycles.
;; (define (get-expr-type2 expr)
;;   (cond
;;     ((null? expr) tc-nil)
;;     ((pair? expr)
;;      (translate-pair-class-expression0-fwd
;;       (list (get-expr-type2 (car expr))
;;             (get-expr-type2 (cdr expr)))))
;;     (else
;;      (get-entity-type2 expr))))


(define get-expr-type get-entity-type)


(define get-expr-type2 get-entity-type2)


;; (define (type-variable-equal-addresses? tvar1 tvar2)
;;   (address=? (hfield-ref tvar1 'address) (hfield-ref tvar2 'address)))


;; (define (order-type-variable-bindings bindings type-variables)
;;   ;; Kutsujärjestys on olennaista.
;;   (map* (lambda (tvar)
;; 	  (assoc tvar bindings type-variable-equal-addresses?))
;; 	type-variables))


;; (define (order-deductions! assoc-table type-variables)
;;   (assert (hrecord-is-instance? assoc-table <type-var-assoc-table>))
;;   (assert (list? type-variables))
;;   (assert (and-map? is-t-type-variable? type-variables))
;;   (hfield-set! assoc-table 'bindings
;; 	       (order-type-variable-bindings
;; 		(hfield-ref assoc-table 'bindings)
;; 		type-variables)))


;; Note: The following procedure may return #t also for
;; simple procedures.
(define (proc-appl-is-abstract? binder repr)
  (assert (is-binder? binder))
  (let ((type (get-entity-type (hfield-ref repr 'proc))))
    (is-t-instance? binder type tmt-procedure)))


(define (proc-appl-is-simple? binder repr)
  (assert (is-binder? binder))
  (let ((type (get-entity-type (hfield-ref repr 'proc))))
    (is-t-instance? binder type tpc-simple-proc)))


(define (proc-appl-is-param? binder repr)
  (let ((type (get-entity-type (hfield-ref repr 'proc))))
    (is-t-instance? binder type tpc-param-proc)))


;; Argument binder is not used.
(define (proc-appl-is-generic? binder repr)
  (assert (is-binder? binder))
  (let ((type (get-entity-type (hfield-ref repr 'proc))))
    (is-tc-gen-proc? type)))


(define (is-type-repr? binder repr)
  (is-t-instance? binder (get-entity-value repr) tt-type))


(define (is-type-repr2? binder repr)
  (is-t-subtype? binder (get-entity-type repr) tt-type))


(define (is-signature-member? binder r-member)
  (and
   (pair? r-member)
   ;; Not sure if incomplete objects work here.
   (is-target-object? (car r-member))
   (is-target-object? (cdr r-member))))


(define (match-signature-to-args binder to-sgn to-proc to-arg-list-type)
  (assert (is-target-object? to-sgn))
  (assert (is-target-object? to-proc))
  (assert (is-target-object? to-arg-list-type))
  (dvar1-set! to-sgn)
  (let ((lst-members (tno-field-ref to-sgn 'l-members))
        (expr-result '())
        (proc-encountered? #f))
    (do ((lst-cur lst-members (cdr lst-cur)))
      ((or (null? lst-cur) (not-null? expr-result)))
      (if (eq? (car (car lst-cur)) to-proc)
        (begin
         (set! proc-encountered? #t)
         (let* ((expr-type (cdr (car lst-cur)))
                (to-decl-type0 (tno-field-ref expr-type
                                              'type-arglist))
                (to-decl-type (rebind-object binder to-decl-type0
                                             to-this to-sgn)))
           
           ;; TBR
           (d2wl 'debug74 "match-signature-to-args/1")
           (d2wl 'debug74 (debug-get-string expr-type))
           (d2wl 'debug74 (debug-get-string to-decl-type))
           (d2wl 'debug74 (debug-get-string to-arg-list-type))
           
           (if (is-t-subtype? binder to-arg-list-type to-decl-type)
             (set! expr-result (rebind-object binder expr-type
                                              to-this to-sgn)))))))
    (cons expr-result proc-encountered?)))


(define (compute-arg-types0 l-args)
  (map get-entity-type2 l-args))


(define (compute-arg-types1 binder l-args l-target-types)
  (map (lambda (ent-arg tt)
         ;; If the target type contains free type
         ;; variables we want the class of an
         ;; atomic object.
         (if (contains-free-tvars-fwd? tt)
           (begin
            (d2wli 'compute-arg-types "compute-arg-types/4-1")
            (get-entity-type1 ent-arg))
           (begin
            (d2wli 'compute-arg-types "compute-arg-types/4-2")
            (get-entity-type2 ent-arg))))
       l-args l-target-types))


(define (compute-arg-types binder l-args tt-arg-list)
  (d2wli 'compute-arg-types "compute-arg-types")
  (d2wli 'debug114 (debug-get-string (map get-entity-type2 l-args)))
  (d2wli 'debug114 (debug-get-string tt-arg-list))
  (assert (and (list? l-args) (for-all is-entity? l-args)))
  (assert (is-target-object? tt-arg-list))
  (let ((l-result
         (cond
           ((is-t-type-variable? tt-arg-list)
            (d2wli 'compute-arg-types "compute-arg-types/1")
            (map get-entity-type1 l-args))
           ((is-t-type-loop? tt-arg-list)
            (if (contains-free-tvars-fwd? tt-arg-list)
              (begin
               (d2wli 'compute-arg-types "compute-arg-types/2")
               (map get-entity-type1 l-args))
              (begin
               (d2wli 'compute-arg-types "compute-arg-types/3")
               (compute-arg-types0 l-args))))
           ((is-tuple-type0-fwd? tt-arg-list)
            (d2wli 'compute-arg-types "compute-arg-types/4")
            (let ((l-target-types
                   (tuple-type->list-reject-cycles-fwd tt-arg-list)))
              (d2wli 'debug1069 (debug-get-string l-target-types))
              (d2wli 'debug1069 (length l-target-types))
              (d2wli 'debug1069 (length l-args))
              (if (eqv? (length l-args) (length l-target-types))
                (compute-arg-types1 binder l-args l-target-types)
                (compute-arg-types0 l-args))))
           ((is-t-type-list? tt-arg-list)
            (let ((l-target-types
                   (tno-field-ref tt-arg-list 'l-subtypes)))
              (cond
                ;; ((eqv? (length l-args) (length l-target-types))
                ;;  (compute-arg-types1 binder l-args l-target-types))
                ((contains-free-tvars-fwd? l-target-types)
                 (map get-entity-type1 l-args))
                (else
                 (compute-arg-types0 l-args)))))
           ((is-tuple-type-with-tail-fwd? tt-arg-list)
            (let* ((i-args (length l-args))
                   (l-tt-fixed
                    (get-general-tuple-type-root-types tt-arg-list))
                   (tt-tail (get-general-tuple-type-tail tt-arg-list))
                   (tt-rest (get-uniform-list-param0 tt-tail))
                   (i-fixed (length l-tt-fixed)))
              (if (>= i-args i-fixed)
                (let ((l-target-types
                       (append l-tt-fixed
                               (make-list (- i-args i-fixed) tt-rest))))
                  (assert (eqv? i-args (length l-target-types)))
                  (compute-arg-types1 binder l-args l-target-types))
                (compute-arg-types0 l-args))))
           (else
            (raise2 'compute-arg-types:invalid-target-type
                    (cons 'tt-arg-list tt-arg-list))))))
    (assert (and (list? l-result)
                 (for-all is-type0? l-result)))
    l-result))


(define compute-arg-types2 compute-arg-types)


;; Argument l-arg-types0 is used only if l-args is a single entity.
(define (match-signature-to-args2 binder to-sgn to-proc l-args l-arg-types0)
  (d2wl 'debug13 "match-signature-to-args2 ENTER")
  (assert (is-binder? binder))
  (assert (and (is-target-object? to-sgn) (is-signature? to-sgn)))
  (assert (and (is-target-object? to-proc)
               (is-t-proc-type? (get-entity-type to-proc))))
  (assert (or (is-entity? l-args)
              (and (list? l-args) (for-all is-entity? l-args))))
  (assert (and (list? l-arg-types0)
               (for-all is-target-object? l-arg-types0)))
  (let ((to-result '())
        (proc-encountered? #f))
    (let ((l-members (tno-field-ref to-sgn 'l-members)))
      (assert (and (list? l-members)
                   (for-all (lambda (x)
                              (is-signature-member? binder x))
                            l-members)))
      (iterate-list-with-break
        (p-cur l-members (not-null? to-result))
        ;; Target objects can be compared with eq?.
        (if (eq? (car p-cur) to-proc)
          (begin
           (d2wl 'debug13 "match-signature-to-args2/2")
           (set! proc-encountered? #t)
           (let* ((to-type (cdr p-cur))
                  (to-decl-type0 (tno-field-ref to-type
                                                'type-arglist))
                  ;; We could use to-decl-type here, too.
                  (l-arg-types
                   (if (list? l-args)
                     (compute-arg-types binder l-args to-decl-type0)
                     (process-static-arg-type-list l-arg-types0
                                                   to-decl-type0)))
                  (to-arg-list-type (apply make-tuple-type-fwd l-arg-types))
                  (to-decl-type
                   (rebind-object binder to-decl-type0
                                  to-this to-sgn)))
             (d2wl 'debug13 "match-signature-to-args2/3")
             (if (is-t-subtype? binder to-arg-list-type to-decl-type)
               (set! to-result
                 (rebind-object binder to-type to-this
                                to-sgn))))))))
    (cons to-result proc-encountered?)))


(define (pick-signatures lst-argtypes)
  (let ((lst-result '()))
    (do ((cur-lst lst-argtypes (cdr cur-lst)))
      ((null? cur-lst))
      (let ((to-cur-type (car cur-lst)))
        (if (is-signature? to-cur-type)
          (set! lst-result (append lst-result (list to-cur-type))))))
    lst-result))


(define (match-call-with-signatures binder proc
                                    lst-argtypes lst-signatures)
  (assert (is-binder? binder))
  (assert (is-procedure-object? proc))
  (assert (and (list? lst-argtypes)
               (for-all is-target-object? lst-argtypes)))
  (assert (and (list? lst-signatures)
               (for-all is-signature? lst-signatures)))
  (let* ((arg-list-type (apply make-tuple-type-fwd
                          lst-argtypes))
         (expr-result '())
         (proc-encountered? #f))
    (do ((lst-cur lst-signatures (cdr lst-cur)))
      ((or (null? lst-cur) (not-null? expr-result)))
      (let ((p-result (match-signature-to-args binder
                                               (car lst-cur)
                                               proc
                                               arg-list-type)))
        (if (cdr p-result) (set! proc-encountered? #t))
        (set! expr-result (car p-result))))
    (cons expr-result proc-encountered?)))


(define (match-call-with-signatures2 binder to-proc l-args l-signatures)
  (d2wl 'debug13 "match-call-with-signatures2 ENTER")
  (assert (is-binder? binder))
  (assert (is-procedure-object? to-proc))
  (assert (or (is-entity? l-args)
              (and (list? l-args)
                   (for-all is-entity? l-args))))
  (assert (and (list? l-signatures)
               (for-all is-signature? l-signatures)))
  (let ((to-result '())
        (proc-encountered? #f)
        ;; Variable l-arg-types0 is used in match-signature-to-args2
        ;; only if l-args is an entity.
        (l-arg-types0
         (if (is-entity? l-args)
           (get-applied-type-list l-args)
           '())))
    (iterate-list-with-break (to-cur l-signatures (not-null? to-result))
      (let ((p-result (match-signature-to-args2
                       binder
                       to-cur
                       to-proc
                       l-args
                       l-arg-types0)))
        (if (cdr p-result) (set! proc-encountered? #t))
        (set! to-result (car p-result))))
    (cons to-result proc-encountered?)))


(define (is-t-nonempty-uniform-list-type0? to)
  (and
   (is-tc-pair? to)
   (let ((to-tail (tt-cdr to)))
     (and
      (is-t-uniform-list-type0? to-tail)
      (let ((l-members (tno-field-ref to-tail 'l-member-types)))
        (eq? (tt-car (car l-members)) (tt-car to)))))))


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


(define (get-neul-param0 to)
  ;; (assert (is-t-nonempty-uniform-list-type0? to))
  (tt-car to))


(define (valid-main-proc-type? binder to-type)
  (and (target-object=? (theme-class-of to-type) tpc-simple-proc)
       (let ((type-arglist (tno-field-ref to-type 'type-arglist))
             (type-result (tno-field-ref to-type 'type-result)))
         (and
          (or (equal-types? binder type-arglist tc-nil)
              (equal-types? binder
                            type-arglist
                            (make-tpci-pair
                             (make-tt-uniform-list tc-string)
                             tc-nil)))
          (or (equal-types? binder type-result tt-none)
              (equal-types? binder type-result tc-integer))))))


(define (convert-to-class tt)
  (d2wl 'debug1024 "convert-to-class")
  (cond
    ((is-t-atomic-object? tt) (theme-class-of tt))
    ((is-tc-pair? tt)
     (make-tpci-pair
      (convert-to-class (tt-car tt))
      (convert-to-class (tt-cdr tt))))
    (else tt)))


(set! convert-to-class-fwd convert-to-class)


(define (convert-arglist-to-classes x-arglist)
  (cond
    ((list? x-arglist)
     (map convert-to-class x-arglist))
    ((is-tuple-type0? x-arglist)
     ;; Converting the result to a tuple may not be strictly necessary here.
     (apply make-tuple-type
       (map convert-to-class (tuple-type->list-reject-cycles x-arglist))))
    ((is-tuple-type-with-tail-fwd? x-arglist)
     (let* ((l-fixed (get-general-tuple-type-root-types x-arglist))
            (tt-tail (get-general-tuple-type-tail x-arglist))
            (tt-rest (get-uniform-list-param0 tt-tail))
            (l-fixed-new (map convert-to-class l-fixed))
            (tt-fixed-new (apply make-tuple-type l-fixed-new))
            (tt-rest-new (convert-to-class tt-rest))
            (tt-tail-new (make-tt-uniform-list tt-rest-new))
            (tt-new-arglist
             (translate-tuple-type-with-tail-fwd tt-fixed-new tt-tail-new)))
       tt-new-arglist))
    (else (raise-simple 'convert-arglist-to-classes:invalid-argument))))


(define (process-static-arg-types1 l-arg-types l-target-types)
  (d2wl 'debug1024 "process-static-arg-types1")
  (map (lambda (tt-arg tt-target)
         (if (contains-free-tvars-fwd? tt-target)
           (convert-to-class tt-arg)
           tt-arg))
       l-arg-types l-target-types))


(define (arg-list-type->list x-arg-types)
  (cond
    ((list? x-arg-types) x-arg-types)
    ((is-tuple-type0? x-arg-types)
     (tuple-type->list-reject-cycles x-arg-types))
    (else
     (raise-simple
      'internal-error-with-argument-types))))


(define (convert-twt tt-arg-types tt-target-types)
  (let ((l-fixed1 (get-general-tuple-type-root-types tt-arg-types))
        (l-fixed2 (get-general-tuple-type-root-types tt-target-types)))
    (if (eqv? (length l-fixed1) (length l-fixed2))
      (let* ((l-result-fixed
              (process-static-arg-types1 l-fixed1 l-fixed2))
             (tt-result-fixed (apply make-tuple-type l-result-fixed))
             (tt-tail1 (get-general-tuple-type-tail tt-arg-types))
             (tt-rest1 (get-uniform-list-param0 tt-tail1))
             (tt-tail2 (get-general-tuple-type-tail tt-target-types))
             (tt-rest2 (get-uniform-list-param0 tt-tail2))
             (tt-result-tail
              (if (contains-free-tvars-fwd? tt-rest2)
                (make-tt-uniform-list
                 (convert-to-class tt-rest1))
                tt-tail1))
             (tt-result
              (translate-tuple-type-with-tail-fwd
               tt-result-fixed tt-result-tail)))
        tt-result)
      tt-arg-types)))


(define (process-static-arg-types x-arg-types tt-arg-list)
  (d2wl 'debug1024 "process-static-arg-types ENTER")
  (cond
    ((is-t-type-variable? tt-arg-list)
     (convert-arglist-to-classes x-arg-types))
    ((is-t-type-loop? tt-arg-list)
     (if (contains-free-tvars-fwd? tt-arg-list)
       (convert-arglist-to-classes x-arg-types)
       x-arg-types))
    ((is-tuple-type0? tt-arg-list)
     (if (is-tuple-type-with-tail-fwd? x-arg-types)
       x-arg-types
       (let ((l-arg-types
              (arg-list-type->list x-arg-types))
             (l-target-types
              (tuple-type->list-reject-cycles tt-arg-list)))
         (if (eqv? (length l-arg-types) (length l-target-types))
           (process-static-arg-types1 l-arg-types l-target-types)
           x-arg-types))))
    ((is-t-type-list? tt-arg-list)
     (let ((l-target-types
            (tno-field-ref tt-arg-list 'l-subtypes)))
       (if (contains-free-tvars-fwd? l-target-types)
         (convert-arglist-to-classes x-arg-types)
         x-arg-types)))
    ((is-tuple-type-with-tail-fwd? tt-arg-list)
     (if (is-tuple-type-with-tail-fwd? x-arg-types)
       (convert-twt x-arg-types tt-arg-list)
       (let* ((l-arg-types
               (arg-list-type->list x-arg-types))
              (i-args (length l-arg-types))
              (l-tt-fixed
               (get-general-tuple-type-root-types tt-arg-list))
              (tt-tail (get-general-tuple-type-tail tt-arg-list))
              (tt-rest (get-uniform-list-param0 tt-tail))
              (i-fixed (length l-tt-fixed)))
         (if (>= i-args i-fixed)
           (let ((l-target-types
                  (append l-tt-fixed
                          (make-list (- i-args i-fixed) tt-rest))))
             (assert (eqv? i-args (length l-target-types)))
             (process-static-arg-types1 l-arg-types l-target-types))
           l-arg-types))))
    (else
     (raise2 'process-static-arg-types:invalid-target-type
             (cons 'tt-arg-list tt-arg-list)))))


(set! process-static-arg-types-fwd process-static-arg-types)


(define (process-static-arg-type-list l-arg-types tt-arg-list)
  (d2wl 'debug1024 "process-static-arg-types ENTER")
  (cond
    ((is-t-type-variable? tt-arg-list)
     (map convert-to-class l-arg-types))
    ((is-t-type-loop? tt-arg-list)
     (if (contains-free-tvars-fwd? tt-arg-list)
       (map convert-to-class l-arg-types)
       l-arg-types))
    ((is-tuple-type0? tt-arg-list)
     (let ((l-target-types
            (tuple-type->list-reject-cycles tt-arg-list)))
       (if (eqv? (length l-arg-types) (length l-target-types))
         (process-static-arg-types1 l-arg-types l-target-types)
         l-arg-types)))
    ((is-t-type-list? tt-arg-list)
     (let ((l-target-types
            (tno-field-ref tt-arg-list 'l-subtypes)))
       (if (contains-free-tvars-fwd? l-target-types)
         (map convert-to-class l-arg-types)
         l-arg-types)))
    ((is-tuple-type-with-tail-fwd? tt-arg-list)
     (let* ((i-args (length l-arg-types))
            (l-tt-fixed
             (get-general-tuple-type-root-types tt-arg-list))
            (tt-tail (get-general-tuple-type-tail tt-arg-list))
            (tt-rest (get-uniform-list-param0 tt-tail))
            (i-fixed (length l-tt-fixed)))
       (if (>= i-args i-fixed)
         (let ((l-target-types
                (append l-tt-fixed
                        (make-list (- i-args i-fixed) tt-rest))))
           (assert (eqv? i-args (length l-target-types)))
           (process-static-arg-types1 l-arg-types l-target-types))
         l-arg-types)))
    (else
     (raise2 'process-static-arg-type-list:invalid-target-type
             (cons 'tt-arg-list tt-arg-list)))))


