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


;; *** Type system ***


;; NOTE: all of the code is not safe
;; for recursive types.


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


(define gl-object-markers '())

(define clone-with-branches-fwd '())

(define rebind-object-fwd '())

(define contains-type-variables-fwd? '())

(define contains-specified-tvars-fwd? '())

(define rebind-local-variables-fwd '())

(define get-subexpressions-fwd '())

(define check-if-t-subtype-fwd? '())

(define construct-toplevel-type-repr-fwd '())

(define construct-argument-type-repr-fwd '())

(define make-type-list-expression-fwd '())

(define bind-type-vars-fwd '())

(define bind-type-vars-no-check-fwd '())

(define is-tuple-type-fwd? '())

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

(define gen-tuple-type->type-list-fwd '())

(define gen-tuple-type->list-fwd '())

(define translate-pair-class-expression0-fwd '())

(define make-tuple-type-fwd '())

(define deduce-type-params0-fwd '())

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

(define make-proc-type-expr-fwd '())

(define contains-free-tvars-general-fwd? '())

(define contains-free-tvars-general0-fwd? '())

(define make-tvars-unique-fwd '())

(define get-all-tvars-fwd '())

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

(define get-type-var-values-from-deductions-fwd '())

(define make-ppc-expr-fwd '())

(define equal-reprs0-fwd? '())

(define equal-reprs1-fwd? '())

(define equal-reprs2-fwd? '())

(define rebind-type-variables-no-check-fwd '())

(define make-union-expression0-fwd '())

(define is-tuple-type0-fwd? '())

(define fix-markers-fwd '())


(define gl-ctr2 0)

(define gl-guess-counter 0)

(define gl-flag4? #f)

(define gl-flag7? #f)

(define gl-stop3 #f)


(define (disp cur-src cur-target)
  (d2wli 'type-deduction "cur-src: ")
  (d2wli 'type-deduction (debug-get-string cur-src))
  (d2wli 'type-deduction "cur-target: ")
  (d2wli 'type-deduction (debug-get-string cur-target)))
;;(define (disp cur-src cur-target) #f)


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


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


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


;; This is probably wrong. Instances of parametrized signatures
;; are ordinary signatures.
(define (is-t-param-signature-instance? type)
  (is-t-param-signature? (get-entity-type type)))


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


(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-target-object? t1))
  (assert (is-target-object? 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 (hfield-ref t1 'incomplete?)
	       (hfield-ref t2 'incomplete?))
	   (raise 'cannot-type-check-incomplete-types-1))
	  ((or (not (is-known-object? t1))
	       (not (is-known-object? 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))


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


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


(define (check-if-t-param-inst-equal? binder marks t1 t2)
  ;; (d2wli 'subtyping "check-if-t-param-inst-equal?")
  (assert (is-target-object? t1))
  (assert (is-target-object? 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=? (hfield-ref t1 'type) (hfield-ref t2 'type)))
      #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* ((alloc-var (hfield-ref binder 'allocate-variable))
		   (make-tvar-address (lambda () (alloc-var 'pp1 #f)))
		   (new-tvars (make-type-variables nr-of-tvars
						   make-tvar-address))
		   (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))))))


;; Precondition: t1 and t2 have to be classes.
(define (check-if-t-param-inst-subclass? binder marks t1 t2)
  (assert (is-target-object? t1))
  (assert (is-target-object? t2))
  (cond
   ((eq? t2 tc-object) #t)
   ((eq? t1 tc-object) #f)
   ((check-if-t-param-inst-equal? binder marks t1 t2) #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 'subtyping "check-if-t-subtype-x-union?")
  (assert (is-target-object? t1))
  (assert (is-target-object? 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-fwd? 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-target-object? ut1))
  (assert (is-target-object? 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-fwd? 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-target-object? t1))
  (assert (is-target-object? t2))
  (let* ((tvar-values1 (tno-field-ref t1 'l-tvar-values))
	 (first1 (car tvar-values1))
	 (second1 (cadr tvar-values1))
	 (tvar-values2 (tno-field-ref t2 'l-tvar-values))
	 (first2 (car tvar-values2))
	 (second2 (cadr tvar-values2)))
    (and (check-if-t-subtype-fwd? binder marks
				  first1 first2)
	 (check-if-t-subtype-fwd? 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-fwd? binder marks
				  first1 first2)
	 (check-if-t-subtype-fwd? 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-target-object? t1))
  (assert (is-target-object? 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-fwd? 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-fwd?
		    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)
  ;; (d2wli 'subtyping "do-check-t-param-proc-abst-proc?")
  (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))
	 (result
	  (and
	   (or (target-type=? target-result-type tt-none)
	       (check-if-t-subtype-fwd?
		binder
		marks
		src-result-type target-result-type))
	   ;; Note the order of types in the following expression.
	   (check-if-t-subtype-fwd?
	    binder
	    marks
	    target-arg-list-type src-arg-list-type))))
    result))


(define (check-t-param-proc-abst-proc? binder marks tc-param-proc tpt-proc-type)
  ;; (d2wli 'subtyping "check-t-param-proc-abst-proc? ENTER")
  (assert (is-binder? binder))
  (assert (and (is-target-object? tc-param-proc)
	       (is-tc-param-proc? tc-param-proc)))
  (assert (and (is-target-object? tpt-proc-type)
	       (is-tt-procedure? tpt-proc-type)))
  (let* ((inst-type (tno-field-ref tc-param-proc 'type-contents))
	 (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)))
    (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.
	    (deduce-argument-types-fwd binder tvar-table all-tvars
				       inst-type tpt-proc-type)
	    (let ((result
		   (if (all-tvars-correct? tvar-table all-tvars)	
		       (do-check-t-param-proc-abst-proc?
			binder marks
			inst-type tpt-proc-type
			tvar-table
			src-tvars target-tvars)
		       #f)))
	      result))))))


(define (make-type-variables n alloc-address)
  (if (<= n 0)
      '()
      (cons (make-type-variable (alloc-address))
	    (make-type-variables (- n 1) alloc-address))))


(define (check-if-t-param-proc-subclass? binder marks ppc1 ppc2)
  ;; (d2wli 'subtyping "check-if-t-param-proc-subclass?")
  (assert (is-binder? binder))
  (assert (and (is-target-object? ppc1)
	       (is-tc-param-proc? ppc1)))
  (assert (and (is-target-object? ppc2)
	       (is-tc-param-proc? ppc2)))

  (equal-reprs1-fwd? binder ppc1 ppc2))


(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-target-object? gp)
	       (is-tc-gen-proc? gp)))
  (assert (and (is-target-object? 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 'subtyping "check-if-t-subtype-gen-abst? ENTER")
  (let ((method-classes (tno-field-ref t1 'l-method-classes))
	(result? #f))
    (do ((cur-list method-classes (cdr cur-list)))
	((or result? (null? cur-list)) result?)
      (if (check-if-t-subtype-fwd? binder marks
				   (car cur-list) t2)
	  (set! result? #t)))))


(define (check-if-t-subtype-gen-gen? binder marks t1 t2)
  ;; (d2wli 'subtyping "check-if-t-subtype-gen-gen?")
  (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-fwd? binder
						  marks
						  (car lst1)
						  (car lst2))
			 (set! result1? #t)))))
		(set! result2? #f)))))
    result))


(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-fwd? binder marks mt1 mt2)))


(define (check-if-t-value-vector-subclass? binder marks tl1 tl2)
  ;; (d2wli 'subtyping "check-if-t-value-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-fwd? 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))))


(define (sgn-subst-member-type binder sgn member-type target-type)
  (assert (is-binder? binder))
  (assert (is-target-object? sgn))
  (assert (is-target-object? member-type))
  (assert (is-target-object? target-type))
  (let ((new-type (rebind-object-fwd binder member-type
				     to-this target-type)))
    new-type))


(define (sgn-member-implemented? binder marks sgn member target-type)
  (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)
	  (check-if-t-subtype? binder marks
			       r-actual-type new-type)))))


(define (check-if-implements-signature? binder marks typ sgn)
  ;; (d2wli 'subtyping "check-if-implements-signature?")
  (assert (is-binder? binder))
  (assert (list? marks))
  (assert (is-target-object? 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)))
    result))


(define (check-if-subsignature? binder marks t1 t2)
  (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-fwd?
		  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-fwd? binder marks lst1 lst2))
   ((and (list? lst1) (list? lst2))
    (and (= (length lst1) (length lst2))
	 (and-map?
	  (lambda (t1 t2)
	    (check-if-t-subtype-fwd? 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-fwd? 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-fwd? 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-fwd? binder marks
					iter-expr1 iter-expr2)))
	(if (equal-loop-lists?
	     binder
	     (tno-field-ref loop1 'x-subtypes)
	     (tno-field-ref loop2 'x-subtypes))
	    (let* ((iter-expr1 (tno-field-ref loop1 'x-iter-expr))
		   (iter-expr2 (tno-field-ref loop2 'x-iter-expr))
		   (alloc-var (hfield-ref binder 'allocate-variable))
		   (new-tvar (make-type-variable (alloc-var 'loop-iter #f)))
		   (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-fwd? 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)
   ((target-type=? t2 tc-object) #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)
   ;; The following should be unnecessary.
   ((and (is-t-atomic-class? t1)
	 (is-t-atomic-class? t2))
    (eq? t1 t2))
   (else '())))


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


(define (do-subtyping-none-checks binder marks-new t1 t2)
  (cond
   ;; <none> inherits only from <none> and <object>.
   ((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))
   (else '())))


(define (do-pair-checks binder marks-new t1 t2)
  ;; (d2wli 'subtyping "do-pair-checks")
  (let ((p1? (is-tc-pair? t1))
	(p2? (is-tc-pair? t2)))
    (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-pair? t1))
	    (ap2? (is-abstract-pair? 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 t1 t2)
  ;; (d2wli 'subtyping "do-proc-checks")
  (let ((ap1? (is-tt-procedure? t1))
	(ap2? (is-tt-procedure? t2))
	(sp1? (is-tc-simple-proc? t1))
	(sp2? (is-tc-simple-proc? t2))
	(pp1? (is-tc-param-proc? t1))
	(pp2? (is-tc-param-proc? t2))
	(gp1? (is-tc-gen-proc? t1))
	(gp2? (is-tc-gen-proc? t2)))
    (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
      '()))))


(define (do-vector-checks binder marks-new t1 t2)
  ;; (d2wli 'subtyping "do-vector-checks")
  (let ((uv1? (is-tc-vector? t1))
	(uv2? (is-tc-vector? t2)))
    (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
      (let ((vv1? (is-tc-value-vector? t1))
	    (vv2? (is-tc-value-vector? t2)))
	(cond
	 ((and vv1? vv2?)
	  (check-if-t-value-vector-subclass?
	   binder marks-new t1 t2))
	 ((and vv1? (not vv2?))
	  #f)
	 ((and (not vv1?) vv2?)
	  #f)
	 (else '())))))))


(define (do-signature-checks binder marks-new t1 t2)
  ;; (d2wli 'subtyping "do-signature-checks")
  (let ((sgn1? (is-signature? t1))
	(sgn2? (is-signature? t2)))
    (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))
     ;; We already know that t2 is not
     ;; <object>.
     ((and sgn1? (not sgn2?))
      #f)
     (else '()))))


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


(define (do-apti-checks binder marks-new t1 t2)
  ;; (d2wli 'subtyping "do-apti-checks")
  (let ((apti1? (is-t-apti? t1))
	(apti2? (is-t-apti? t2)))
    (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 t1 t2)
  ;; (d2wli 'subtyping "do-rest-checks")
  (let ((inst1? (is-t-param-class-instance? t1))
	(inst2? (is-t-param-class-instance? t2))
	(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?))))
    (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)
  ;; (d2wli 'subtyping "check-if-t-subtype?")
  (assert (is-target-object? t1))
  (assert (is-target-object? t2))
  (let ((old-indent gl-indent))

    (set! gl-indent (+ gl-indent 1))

    ;; (d2wli 'subtyping "t1:")
    ;; (d2wli 'subtyping (debug-get-string t1))
    ;; (d2wli 'subtyping "t2:")
    ;; (d2wli 'subtyping (debug-get-string t2))

    (cond
     ((or (hfield-ref t1 'incomplete?)
	  (hfield-ref t2 'incomplete?))
      ;;      (raise 'cannot-type-check-incomplete-types-2))
      (set! gl-indent old-indent)
      (eq? t1 t2))
     ((or (not (is-known-object? t1))
	  (not (is-known-object? t2)))
      (raise 'cannot-type-check-unknown-types-2))
     (else
      (if (member (cons t1 t2) marks equal-pairs?)
	  (begin
	    (set! gl-indent old-indent)
	    #t)
	  (begin
	    (let* ((marks-new (cons (cons t1 t2) marks))
		   (res1 (do-subtyping-basic-checks binder marks-new t1 t2))
		   (res2 (if (boolean? res1)
			     res1
			     (do-signature-checks binder marks-new t1 t2)))
		   (res3 (if (boolean? res2)
			     res2
			     (do-union-checks binder marks-new t1 t2)))
		   (res4 (if (boolean? res3)
			     res3
			     (do-subtyping-none-checks binder marks-new
						       t1 t2)))
		   (res5 (if (boolean? res4)
			     res4
			     (do-pair-checks binder marks-new t1 t2)))
		   (res6 (if (boolean? res5)
			     res5
			     (do-proc-checks binder marks-new t1 t2)))
		   (res7 (if (boolean? res6)
			     res6
			     (do-vector-checks binder marks-new t1 t2)))
		   (res8 (if (boolean? res7)
			     res7
			     (do-apti-checks binder marks-new t1 t2)))
		   (res9 (if (boolean? res8)
			     res8
			     (do-modifier-checks binder marks-new t1 t2)))
		   (res10 (if (boolean? res9)
			      res9
			      (do-rest-checks binder marks-new t1 t2))))
	      (set! gl-indent old-indent)
	      res10)))))))


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


(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 (eqv? (vector-ref v i) #t)
	  (set! count (+ count 1))))))


;; The following procedure is allowed to return #f
;; also for noninheritable types.
(define (is-final-class? binder typ)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? typ <target-object>))
  (let ((result
	 (and
	  (is-t-instance? binder typ tc-class)
	  (not (tno-field-ref typ 'inheritable?)))))
    result))


(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
			(assert (is-general-tuple-type-fwd? binder
							    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))
  (let ((n (vector-length v-arg-list-types)))
    (assert (= (vector-length vb-included) n))
    (do ((i 0 (+ i 1))) ((>= i n))
      ;; Testataan aluksi vb-included, jotta vältetään turhia
      ;; funktion is-t-subtype? kutsuja.
      (if (or (not (vector-ref vb-included i))
	      (not (is-t-subtype? binder
				  argl-type
				  (vector-ref v-arg-list-types i))))
	  (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-type-fwd? binder 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)
  (my-vector-map (lambda (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 (my-vector-map
		      (lambda (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 obj)
  (assert (or (pair? obj) (boolean? obj)))
  (if (eq? obj #f) #f (car obj)))


(define (cdr1 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 (my-vector-map car1 argl))
	 (v-rest-args (my-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-classes)
  (assert (is-binder? binder))
  (let* ((v-argl (list->vector argl))
	 (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 argl)))
    (let* ((argcount (vector-length v-argl))
	   (m-count (vector-length v-arg-list-types))
	   (vb-included (make-vector m-count #t)))
      (reject-incompatible-param method-classes vb-included)
      (reject-by-length binder argcount v-arg-list-types
			vb-included)
      (reject-mismatches binder argl-type v-arg-list-types vb-included)
      (do-select-best-methods binder
			      vb-included
			      v-argl
			      v-arg-list-types)
      (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)
  (assert (is-binder? binder))
  (assert (and (list? argl) (and-map? is-target-object? argl)))
  (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))
	 (mtc2 (make-tvars-unique2 binder mtc))
	 (mtc2-tvars (get-all-free-tvars-fwd mtc2))
	 (all-tvars (append arg-tvars mtc2-tvars))
	 (tvar-table (get-new-type-var-assoc-table))
	 (arg-list-type (tno-field-ref (tno-field-ref mtc2 'type-contents)
				       'type-arglist)))
    (deduce-argument-types-fwd binder tvar-table all-tvars
			       argl arg-list-type)
    (if (all-tvars-correct? tvar-table all-tvars)
	(let* ((tvar-bindings (hfield-ref tvar-table 'bindings))
	       (inst-type (tno-field-ref mtc2 'type-contents))
	       (result-mtc (bind-type-vars-fwd
			    binder tvar-bindings inst-type)))
	  result-mtc)
	(begin
	  #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)
  (assert (is-binder? binder))
  (assert (and (list? argl) (and-map? is-target-object? argl)))
  (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))
	 (selection
	  (select-best-method0 binder argl processed-classes)))
	 ;; (sel2
	 ;;  (if (and (contains-simple-methods? method-classes)
	 ;; 	   (contains-param-methods? method-classes))
	 ;;      (reject-param-methods selection method-classes)
	 ;;      selection)))
    (map (lambda (index) (list-ref processed-classes index))
	 selection)))


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


(define (select-best-method binder argl mts)
  (assert (is-binder? binder))
  (assert (and (list? argl) (and-map? is-target-object? argl)))
  (assert (and (list? mts) (and-map? is-method-record? 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 processed-classes)))
	 ;; (sel2
	 ;;  (if (and (contains-simple-methods? method-classes)
	 ;; 	   (contains-param-methods? method-classes))
	 ;;      (reject-param-methods selection method-classes)
	 ;;      selection)))
    (map (lambda (index) (cons (list-ref mts index)
			       (list-ref processed-classes index)))
	 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 (is-param-expr-subtype? binder expr1 tvars1 expr2 tvars2)
  (assert (is-binder? binder))
  (assert (is-target-object? expr1))
  (assert (and (list? tvars1) (and-map? is-t-type-variable? tvars1)))
  (assert (is-target-object? 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* ((alloc-var (hfield-ref binder 'allocate-variable))
	       (make-tvar-address (lambda () (alloc-var 'pp3 #f)))
	       (new-tvars (make-type-variables nr-of-tvars make-tvar-address))
	       (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-fwd? 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?)))))
	#f)))


(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-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-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-covariant-typing-for-method-type? binder genproc
						 method-type)
  (assert (is-binder? binder))
  (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-hrecord-type <type-var-assoc-table> ()
  bindings l-new-tvars)


(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)
  (assert (hrecord-is-instance? tvars <type-var-assoc-table>))
  (assert (is-t-type-variable? tvar))
  (assert (hrecord-is-instance? type <target-object>))
  (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
   ((is-target-object? type)
    (type-var-do-add-new-binding!
     tvars tvar
     (construct-argument-type-repr-fwd binder type)))
   ((and (list? type)
	 (and-map? is-target-object? 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?)
  (assert (is-binder? binder))
  (assert (list? visited))
  (assert (boolean? use-tuples?))
  (let* ((new-visited (cons type visited))
	 (result
	  (cond
	   ((memv type visited) type)
	   ((is-tc-param-proc? type)
	    (tno-field-ref type 'type-contents))
	   ((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?)
  (let ((result
	 (do-handle-static-repr binder type '() use-tuples?))) 
    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)))
    (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)
       (eqv? (tno-field-ref obj 'type-meta) tpc-pair)
       (= (length (tno-field-ref obj '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)))))


;; The result value of the following procedure has no significance.
(define (deduce-gen-proc-abst-proc-result tvars binder
					  all-type-vars
					  gp target-arg-list target-result
					  visited)
  (assert (is-tc-gen-proc? gp))
  (let* ((method-classes (tno-field-ref gp 'l-method-classes))
	 (best (select-best-method-class binder target-arg-list
					 method-classes)))
    (if (= (length best) 1)
	;; Maybe we should also handle the case where the
	;; dispatch result is ambiguous.
	(let* ((best-method-class (car best))
	       (best-result-type (tno-field-ref best-method-class
						'type-result)))
	  (deduce-type-params0 tvars binder
			       all-type-vars
			       (list best-result-type) target-result
			       visited)))))


(define (deduce-gen-proc-abst-proc-arg-list tvars binder all-type-vars
					    gp target-arg-list target-result
					    visited)
  (assert (is-tc-gen-proc? gp))
  (let* ((method-classes (tno-field-ref gp 'l-method-classes))
	 (best (select-best-method-class binder target-arg-list
					 method-classes)))
    (if (= (length best) 1)
	;; Maybe we should also handle the case where the
	;; dispatch result is ambiguous.
	(let* ((best-method-class (car best))
	       (best-arg-list-type (tno-field-ref best-method-class
						  'type-arglist)))
	  (deduce-type-params0 tvars binder
			       all-type-vars
			       (list best-arg-list-type) target-arg-list
			       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 '())))


;; NOTE: We don't handle the case where t1 has a rest argument.
(define (deduce-gen-proc-abst-proc tvars binder
				   all-type-vars
				   t1 t2 visited)
  (assert (is-tc-gen-proc? t1))
  (assert (is-tt-procedure? t2))
  (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)))
     (if tvars1?
	 (deduce-gen-proc-abst-proc-arg-list tvars binder
					     all-type-vars
					     t1 target-arg-list target-result
					     visited))
     (if tvars2?
	 (deduce-gen-proc-abst-proc-result tvars binder
					   all-type-vars
					   t1 target-arg-list target-result
					   visited))))


(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 (deduce-not-sgn-sgn tvars binder
			    all-type-vars
			    t1 t2 visited)
  ;; (d2wli 'type-deduction "deduce-not-sgn-sgn")
  (assert (not (is-t-signature? t1)))
  (assert (is-t-signature? t2))
  (let ((l-members (tno-field-ref t2 'l-members)))
    (do ((l-cur l-members (cdr l-cur))) ((null? l-cur))
      (let* ((to (get-entity-type (car (car l-cur))))
	     (to-type (cdr (car l-cur)))
	     (to-new-type (sgn-subst-member-type binder t2 to-type t1)))
	(deduce-type-params0 tvars binder all-type-vars (list to) to-new-type
			     visited)))))


(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 (prepare-source-type binder type)
  (dvar1-set! type)
  (handle-source-splice
   (cond
    ((pair? type)
     (cons
      (handle-static-repr binder (car type) #f)
      (cdr type)))
    ((is-tc-pair? type)
     (make-tpci-pair
      (handle-static-repr binder (gen-car type) #t)
      (gen-cdr type)))
    ((is-abstract-pair? type)
     (make-apti tpc-pair
		(list
		 (handle-static-repr binder (gen-car type) #t)
		 (gen-cdr type))))
    (else (raise 'internal-error)))))


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


(define (do-deduce-type-params tvars binder all-type-vars
			       tt1 tt2 new-visited)
  ;; (d2wli 'type-deduction "do-deduce-type-params")
  (cond
   ((is-t-type-variable? tt2)
    (deduce-simple-type tvars binder
			all-type-vars tt1 tt2
			new-visited))
   ((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))
   ((and (not (is-t-signature? (gen-car tt1))) (is-t-signature? tt2))
    (deduce-not-sgn-sgn tvars binder all-type-vars (gen-car tt1) tt2
			new-visited))
   ((and (is-t-signature? (gen-car tt1)) (not (is-t-signature? tt2)))
    #f)
   ((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
		      all-type-vars 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))
   ((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))
   ((is-t-apti? tt2)
    (if (is-t-apti? (gen-car tt1))
	(deduce-apti tvars binder all-type-vars
		     tt1 tt2 new-visited)
	#f))
   (else
    (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-deduction "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-indent))
    (set! gl-indent (+ gl-indent 1))
    ;; (d2wli 'type-deduction "t1:")
    ;; (d2wli 'type-deduction (debug-get-string t1))
    ;; (d2wli 'type-deduction "t2:")
    ;; (d2wli 'type-deduction (debug-get-string t2))
    (cond
     ((and (is-entity? t2) (is-null-class-entity? t2))
      '())
     (else
	(cond
	 ((not (is-gen-pair? t1))
	  (assert (is-target-object? t1))
	  (if (is-t-splice? t2)
	      (deduce-type-params0 tvars binder
				   all-type-vars
				   (list (handle-static-repr binder t1 #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 equal-pairs?)
	  '())
	 (else
	  (let ((new-visited (cons (cons (gen-car t1) t2) visited)))
	    (let* ((tt1 (prepare-source-type binder t1))
		   (tt2 (handle-static-repr binder t2 #f)))
	      (if (and (is-gen-pair? tt1)
		       (contains-type-variables-fwd? tt2))
		  (begin
		    (do-deduce-type-params
		     tvars binder all-type-vars
		     tt1 tt2 new-visited)))))))))
    (set! gl-indent old-indent)))


(set! deduce-type-params0-fwd deduce-type-params0)


(define (deduce-type-loop tvars binder all-type-vars
			  src-args type-loop visited)
  ;; (d2wli 'type-deduction "deduce-type-loop")  
  (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-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)))
    (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)))
      (cond
       ((and (is-t-type-loop? source-list0)
	     (is-t-type-variable? subtype-list))
	(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 '())))
	      ;; 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))
	(let ((new-deductions (make-hrecord <type-var-assoc-table>
					    (hfield-ref tvars 'bindings)
					    '()))
	      (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))))
		  (type-var-add-new-binding! tvars binder
					     subtype-list
					     tt-list))))))
       ((and (not (or (eqv? source-list '()) (eqv? source-list #f))))
	(do ((cur-src source-list (cdr cur-src)))
	    ((null? cur-src))
	  (let ((new-deductions (make-hrecord <type-var-assoc-table>
					      (hfield-ref tvars 'bindings)
					      '())))
	    (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))))))
	(let ((result
	       (cond
		;; TBD: Change memv to memq
		((memv #f deduced-items)
		 '())
		((and (is-t-type-variable? subtype-list)
		      (not (type-var-inquire tvars subtype-list)))
		 (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 '())
	(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? (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))
  (let ((bindings (hfield-ref tvars 'bindings)))
    (for-each (lambda (p-binding)
		(update-tvar-assoc! p-binding binder tvar-new x-new-src))
	      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? x-new-src l-new-tvars)
	(let* ((l-bindings (hfield-ref tvars 'bindings))
	       (l-new-bindings
		(map (lambda (tvar)
		       (assoc tvar l-bindings type-variable=?))
		     l-new-tvars)))
	  (bind-type-vars-no-check-fwd binder l-new-bindings x-new-src))
	x-new-src)))

	
(define (deduce-simple-type tvars binder all-type-vars			  
			    source-list target-type visited) 
  ;; (d2wli 'type-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))
  (let ((result
	 (if (is-gen-pair? source-list)
	     (let ((src (gen-car source-list))
		   (fixed-tvars (hfield-ref binder 'fixed-tvars)))
	       (if (and
		    (member target-type all-type-vars type-variable=?)
		    (not (hrecord-is-instance? src <normal-variable>))
		    (not (type-var-inquire tvars target-type))
		    (not (contains-free-tvars-general0-fwd? src fixed-tvars
							    '())))
		   (begin
		     ;; 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
					       target-type x-src-value)
			   (let ((x-src-value2 (check-new-tvar tvars binder
							       target-type
							       x-src-value)))
			     (hfield-set!
			      tvars 'l-new-tvars
			      (cons target-type
				    (hfield-ref tvars 'l-new-tvars)))
			     (type-var-add-new-binding!
			      tvars binder
			      target-type x-src-value2)))))))))
    result))


(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 (get-tvar tvar-list var)
  (if (and
       (is-t-type-variable? var)
       (not (member var (hfield-ref tvar-list 'element)
		    type-variable=?)))
      (hfield-set! tvar-list 'element
		   (cons var (hfield-ref tvar-list 'element)))))


(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) (hfield-ref item 'incomplete?)) '())
     ((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-hrecord <singleton> '())))
    (get-all-tvars0 tvar-list item '())
    ;; Reversion of the list is probably not necessary.
    (reverse (hfield-ref tvar-list 'element))))


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


(define (get-all-free-tvars0 tvar-list item bound visited)
  (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-hrecord <singleton> '())))
    (get-all-free-tvars0 tvar-list item '() '())
    ;; Reversion of the list is probably not necessary.
    (reverse (hfield-ref tvar-list 'element))))


(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-hrecord <singleton> '())))
    (get-all-free-tvars01 tvar-list item '() '())
    ;; Reversion of the list is probably not necessary.
    (reverse (hfield-ref tvar-list 'element))))


(define (get-bound-tvars0 tvar-list item l-visited)
  (let ((l-new-visited (cons item l-visited)))
    (cond
     ((null? item) '())
     ((memq item l-visited) '())
     ((and (is-target-object? item) (hfield-ref item 'incomplete?)) '())
     ((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 '()))))


(define (get-bound-tvars item)
  (let ((tvar-list (make-hrecord <singleton> '())))
    (get-bound-tvars0 tvar-list item '())
    ;; Reversion of the list is probably not necessary.
    (reverse (hfield-ref tvar-list 'element))))


(define (deduce-step-forward tvars binder all-type-vars		   
			     cur-src cur-target
			     old-count old-state)
  (deduce-type-params0 tvars binder all-type-vars
		       cur-src cur-target '())
  (let ((new-count (length (hfield-ref tvars 'bindings))))
    (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)))))
      result)))


(define (deduce-step-backward tvars binder all-type-vars
			      cur-src cur-target
			      old-count old-state)
  (deduce-type-params0 tvars binder all-type-vars
		       cur-target cur-src '())
  (let ((new-count (length (hfield-ref tvars 'bindings))))
    (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)))))
      result)))


(define (deduce-argument-types binder tvar-table
			       all-tvars src target)
  ;; (d2wli 'type-deduction "deduce-argument-types")
  (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)))

  ;; (disp src target)

  (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))
      ;; (d2wli 'type-deduction "deduce-argument-types: starting a step")
      ;; (d2wli 'type-deduction i)
      (if dir-fwd?
	  (if (> state 0)
	      (begin
		(hfield-set! tvar-table 'l-new-tvars '())
		(let ((res
		       (deduce-step-forward tvar-table binder all-tvars
					    (list cur-src) cur-target
					    old-count-target state)))
		  (set! state (car res))
		  (set! old-count-target (cadr res))
		  (set! cur-target (bind-type-vars-no-check-fwd
				    binder
				    (hfield-ref tvar-table 'bindings)
				    target))

		  (set! cur-src (bind-type-vars-no-check-fwd
				 binder
				 (hfield-ref tvar-table 'bindings)
				 src)))))
		  ;; (d2wli 'type-deduction
		  ;; 	 "deduce-argument-types: bound tvars (fwd)")
		  ;; (disp cur-src cur-target))))
	  (if (> state 0)
	      (begin
		(hfield-set! tvar-table 'l-new-tvars '())
		(let ((res
		       (deduce-step-backward tvar-table binder all-tvars
					     cur-src (list cur-target)
					     old-count-src state)))
		  (set! state (car res))
		  (set! old-count-src (cadr res))
		  (set! cur-src (bind-type-vars-no-check-fwd
				 binder
				 (hfield-ref tvar-table 'bindings)
				 src))
		  (set! cur-target (bind-type-vars-no-check-fwd
				    binder
				    (hfield-ref tvar-table 'bindings)
				    target))))))
		  ;; (d2wli 'type-deduction 
		  ;; 	 "deduce-argument-types: bound tvars (bwd)")
		  
		  ;; (disp cur-src cur-target)))))
      (set! dir-fwd? (not dir-fwd?)))
    (and (= 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))))


(define (make-tvars-unique200 binder repr tvar-bindings lst-visited)
  (cond
   ((null? repr)
    (begin
      '()))
   ((eqv? repr tc-nil)
    (begin
      tc-nil))
   ((is-t-type-variable? repr)
    (let ((binding (assoc repr tvar-bindings
			  type-variable=?)))
      (if (eqv? binding #f)
	  repr
	  (cdr binding))))
   ((pair? repr)
    (let ((lst-new-visited (cons (cons repr #f) lst-visited)))
      (cons
       (make-tvars-unique20 binder (car repr)
			    tvar-bindings lst-new-visited)
       (make-tvars-unique20 binder (cdr repr)
			    tvar-bindings lst-new-visited))))
   ((hrecord-is-instance? repr <variable-reference>)
    repr)
   ((is-target-object? repr)
    (let* ((sgt (make-cycle-object repr))
	   (lst-new-visited (cons (cons repr sgt) lst-visited))
	   (result
	    (cond
	     ((is-tc-pair? repr)
	      (translate-pair-class-expression0-fwd
	       (list
		(make-tvars-unique20 binder
				     (get-pair-first-type repr)
				     tvar-bindings lst-new-visited)
		(make-tvars-unique20 binder
				     (get-pair-second-type repr)
				     tvar-bindings lst-new-visited))))
	     (else
	      (let* ((new-bindings
		      (cond
		       ((is-tc-param-proc? repr)
			(let ((old-tvars (tno-field-ref repr 'l-tvars))
			      (alloc-loc
			       (hfield-ref binder 'allocate-variable)))
			  (map* (lambda (old-tvar)
				  (cons old-tvar
					(make-type-variable
					 (alloc-loc 'g2 #f))))
				old-tvars)))
		       (else '())))
		     (bindings (append new-bindings tvar-bindings))
		     (subexprs (get-subexpressions-fwd repr))
		     (processed-subexprs
		      (map*
		       (lambda (subexpr)
			 (make-tvars-unique20 binder subexpr
					      bindings
					      lst-new-visited))
		       subexprs))
		     ;; We probably don't need type checking here.
		     (new-repr
		      (if (is-tc-param-proc? repr)
			  (make-param-proc-class-object
			   (tno-field-ref repr 'str-name)
			   (map cdr bindings)
			   (car processed-subexprs))
			  (clone-with-branches-fwd binder repr
						   processed-subexprs
						   #f))))
		new-repr)))))
      (if (eq? repr result)
	  repr
	  (begin
	    (update-cycle-object! sgt result)
	    sgt))))
   (else
    (raise 'make-tvars-unique200:invalid-arguments))))


(define (make-tvars-unique20 binder repr tvar-bindings lst-visited)
  (assert (is-binder? binder))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let* ((result
	    (let ((a (assq repr lst-visited)))
	      (if (not (eq? a #f))
		  (if (or (pair? repr) (is-expression? repr))
		      (raise 'illegal-cycle-3)
		      (cdr a))
		  (make-tvars-unique200 binder repr
					tvar-bindings
					lst-visited)))))

      (set! gl-indent old-indent)
      result)))


(define (make-tvars-unique2 binder obj)
  (let ((old-type-check? (hfield-ref binder 'type-check?))
	(old-debug? gl-show-indented-debug-info?))
    (set! gl-show-indented-debug-info? #f)
    (hfield-set! binder 'type-check? #f)
    (let ((result (make-tvars-unique20 binder obj '() '())))
      (hfield-set! binder 'type-check? old-type-check?)
      (set! gl-show-indented-debug-info? old-debug?)
      result)))


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


(define (proc-appl-is-generic? binder repr)
  (assert (is-binder? binder))
  (let ((type (get-entity-type (hfield-ref repr 'proc))))
    (is-t-subtype? binder type tmc-gen-proc)))


(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-fwd binder to-decl-type0
						    to-this to-sgn)))
	      (dwl3 (debug-get-string to-decl-type))
	      (if (is-t-subtype? binder to-arg-list-type to-decl-type)
		  (set! expr-result (rebind-object-fwd binder expr-type
						       to-this to-sgn)))))))
    (cons expr-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)
  (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 (tt-car to)
  (assert (is-tc-pair? to))
  (car (tno-field-ref to 'l-tvar-values)))


(define (tt-cdr to)
  (assert (is-tc-pair? to))
  (cadr (tno-field-ref to 'l-tvar-values)))


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


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


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