;; -*-scheme-*-

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



;; *** Linker and parametrized classes ***


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


(define gl-cur-call-number 0)
(define gl-cur-max-call-number 0)
(define gl1 '())
(define gl2 '())
(define gl3 '())
(define gl4 '())
(define gl-break? #f)
(define gl-ctr1 0)
(define gl-ctr13 0)
(define gl-ctr14 0)
(define gl-flag3? #f)


(define bind-type-loop-fwd '())
(define bind-type-join-fwd '())
(define bind-type-vars-param-proc-fwd '())
(define bind-type-vars-param-proc-runtime-fwd '())
(define bind-type-vars-param-proc-instance-fwd '())
(define bind-type-vars-param-proc-dispatch-fwd '())
(define bind-type-vars-param-class-fwd '())
(define bind-type-vars-pair-class-fwd '())
(define bind-type-vars-param-ltype-fwd '())
(define inst-make-param-proc-instance-fwd '())
(define inst-make-param-proc-instance-w-params-fwd '())
(define inst-set-param-proc-instance-contents-fwd '())
(define inst-make-param-class-instance-fwd! '())
(define cwb-param-proc-appl-fwd '())
(define translate-simple-proc-appl-expression1-fwd '())
(define get-subexprs-normal-variable-fwd '())
(define cwb-location-fwd '())
(define get-type-var-values-from-deductions2-fwd '())
(define rebind-local-variables-no-check-fwd '())
(define rebind-local-variables1-fwd '())
(define make-tvars-unique3-fwd '())
(define create-fwd-ref-for-instance-fwd '())


(define tp-apply-fwd '())
(define tp-apply-nonpure-fwd '())


(define (check-bindings bindings)
  (assert (and-map? (lambda (binding)
		      (and (pair? binding)
			   (or
			    (and
			     (is-t-type-variable? (car binding))
			     (is-target-object? (cdr binding)))
			    (and
			     (is-normal-variable? (car binding))
			     (or
			      (is-normal-variable? (cdr binding))
			      (is-target-object? (cdr binding)))))))
		    bindings)))


(define (get-param-cache binder)
  (assert (is-binder? binder))
  (hfield-ref binder 'param-cache))


(define (ref? expr name)
  (and (hrecord-is-instance? expr <variable-reference>)
       (eq? (hfield-ref (hfield-ref (hfield-ref expr 'variable)
				    'address)
			'source-name)
	    name)))


(define (get-param-proc-name to-pc)
  (let* ((address (hfield-ref to-pc 'address))
	 (s-name
	  (cond
	   ((and (not-null? address)
		 (not-null? (hfield-ref address 'source-name)))
	    (hfield-ref address 'source-name))
	   ((is-tc-param-proc? (get-entity-type to-pc))
	    (tno-field-ref to-pc 's-name))
	   (else '()))))
    s-name))


(define (set-cur-param-proc! binder to-pc)
  (assert (is-binder? binder))
  (hfield-set! binder 's-cur-toplevel (get-param-proc-name to-pc)))

  
(define (do-bind-type-vars-apti binder type-vars repr visited)
  (assert (is-t-apti? repr))
  (let* ((l-inst '())
	 (l-subexprs (get-subexpressions repr))
	 (l-translated
	  (map (lambda (subexpr)
		 (if (not-null? subexpr)
		     (let ((bind-result
			    (do-bind-type-vars0
			     binder type-vars subexpr
			     visited)))
		       (set! l-inst
			     (append l-inst
				     (cdr bind-result)))
		       (car bind-result))
		     '()))
	       l-subexprs))
	 (param-type (car l-translated))
	 (type-args (cdr l-translated))
	 (pr (translate-param-ltype-instance-expr3
	      binder param-type type-args visited))
	 (repr-new (car pr)))
    (set! l-inst (append l-inst (cdr pr)))
    (if (eq? repr repr-new)
	;; Should we have l-inst in the following?
	(cons repr '())
	(let ((a (assq repr-new visited)))
	  (if a
	      (begin
		(cons (cdr a) l-inst))
	      (begin
		(cons repr-new l-inst)))))))


;; Should we handle abstract parametrized types and signatures, too?
(define (handle-apti-result binder obj)
  (if (and (is-t-apti? obj) (is-t-param-class? (tno-field-ref obj 'type-meta))
	   (not (equal? (tno-field-ref obj 'l-type-args) '(()))))
      (let ((type-args (tno-field-ref obj 'l-type-args)))
	(if (not (contains-type-modifiers? type-args))
	    ;; (binder-get-instance-fwd binder
	    ;; 			     (tno-field-ref obj 'param-type)
	    ;; 			     type-args
	    ;; 			     #t)
	    (begin
	      (translate-param-class-instance-expr
	       binder
	       (tno-field-ref obj 'type-meta)
	       type-args
	       #f #t))
	    (begin
	      obj)))
      (begin
	obj)))


(define (type-variable2=? x1 x2)
  (if (and
       (is-t-type-variable? x1)
       (is-t-type-variable? x2))
      (type-variable=? x1 x2)
      (eqv? x1 x2)))


(define (do-bind-repr binder type-vars repr new-visited i-counter)
  (let* ((instantiations '())
	 (subexprs (get-subexpressions-fwd repr))
	 (translated-subexprs
	  (map (lambda (subexpr)
		 (if (not-null? subexpr)
		     (let ((bind-result
			    (do-bind-type-vars0
			     binder type-vars subexpr
			     new-visited)))
		       (set! instantiations
			     (append instantiations
				     (cdr bind-result)))
		       (car bind-result))
		     '()))
	       subexprs))
	 (res2
	  (if (null? subexprs)
	      repr
	      (begin
		(clone-with-branches-fwd
		 binder
		 repr
		 translated-subexprs
		 (hfield-ref binder 'type-check?))))))
    (cons res2 instantiations)))


(define (do-bind-type-vars00 binder type-vars repr visited)
  (let ((a (assq repr visited))
	(i-counter gl-counter14))
    (if (not (eq? a #f))
	(begin
	  (if (or (pair? repr) (is-expression? repr))
	      (raise 'illegal-cycle-2)
	      (cons (cdr a) '())))
	(let ((result
	       (cond
		((null? repr)
		 (cons '() '()))
		((hrecord-is-instance? repr <normal-variable>)
		 (let ((binding (assq repr type-vars)))
		   (if binding
		       (cons (cdr binding) '())
		       (do-bind-repr binder type-vars repr visited
				     i-counter))))
		((is-t-type-variable? repr)
		 (let ((res1
			(let ((binding
			       (assoc repr type-vars type-variable2=?)))
			  (if (not (eqv? binding #f))
			      (begin
				(cdr binding))
			      repr))))
		   (cons res1 '())))
		((and (is-t-apti? repr)
		      (is-t-param-logical-type?
		       (tno-field-ref repr 'type-meta)))
		 (do-bind-type-vars-apti binder type-vars repr
					 visited))
		((pair? repr)
		 (let* ((l-new-visited (cons (cons repr #f) visited))
			(pair-inst '())
			(new-car
			 (let ((b1
				(do-bind-type-vars0 binder type-vars
						    (car repr)
						    l-new-visited)))
			   (set! pair-inst (append pair-inst (cdr b1)))
			   (car b1)))
			(new-cdr
			 (let ((b2
				(do-bind-type-vars0 binder type-vars
						    (cdr repr)
						    l-new-visited)))
			   (set! pair-inst (append pair-inst (cdr b2)))
			   (car b2))))
		   (if (and (eq? new-car (car repr))
			    (eq? new-cdr (cdr repr)))
		       (cons repr '())
		       (cons (cons new-car new-cdr) pair-inst))))
		((is-expression? repr)
		 (let ((l-new-visited (cons (cons repr #f) visited)))
		   (cond
		    ((hrecord-is-instance? repr <let-expression>)
		     (inst-bind-let-expression binder type-vars repr
					       l-new-visited))
		    ((hrecord-is-instance? repr <procedure-expression>)
		     (inst-bind-procedure binder type-vars repr l-new-visited))
		    ((and
		      (hrecord-is-instance? repr <proc-appl>)
		      (proc-appl-is-param? binder repr)
		      (let ((obj-proc-value
			     (get-entity-value (hfield-ref repr 'proc))))
			(and (not-null? obj-proc-value)
			     (is-known-object? obj-proc-value)
			     (let ((repr-value
				    (tno-field-ref obj-proc-value
						   'x-value-expr)))
			       (and (not-null? repr-value)
				    (or (hrecord-is-instance? repr-value
							      <prim-proc-ref>)
					(hrecord-is-instance? repr-value
							      <checked-prim-proc>))
				    (is-t-instance? binder
						    (get-entity-type repr-value)
						    tpc-param-proc))))))
		     (bind-param-prim-proc-appl binder type-vars repr l-new-visited))
		    ((and (hrecord-is-instance? repr <expr-param-proc-instance>)
			  (is-known-object?
			   (hfield-ref repr 'param-proc)))
		     (bind-type-vars-param-proc-instance-fwd
		      binder type-vars repr l-new-visited))
		    ((hrecord-is-instance? repr <expr-param-proc-dispatch>)
		     (bind-type-vars-param-proc-dispatch-fwd
		      binder type-vars repr l-new-visited))
		    ((and (hrecord-is-instance? repr <proc-appl>)
			  (proc-appl-is-param? binder repr)
			  (is-target-object? (hfield-ref repr 'proc))
			  ;; Only toplevel parametrized procedures are
			  ;; optimized by copying.
			  (not-null? (hfield-ref (hfield-ref repr 'proc)
						 'address))
			  (hfield-ref (hfield-ref (hfield-ref repr 'proc)
						  'address)
				      'toplevel?))
		     (if (and
			  (hfield-ref repr 'runtime-arglist-typecheck?)
			  (or (hfield-ref binder 'inside-param-proc?)
			      (null? (hfield-ref repr 'static-arg-types))))
			 (bind-type-vars-param-proc-runtime-fwd
			  binder type-vars repr l-new-visited)
			 (bind-type-vars-param-proc-fwd
			  binder type-vars repr l-new-visited)))
		    (else
		     (let ((var-def?
			    (hrecord-is-instance? repr <variable-definition>))
			   (inside-old?
			    (hfield-ref binder 'inside-param-proc?)))
		       (if (hrecord-is-instance? repr <param-proc-expr>)
			   (hfield-set! binder 'inside-param-proc? #t))
		       (if var-def? (hfield-set! binder 'visited-in-binding
						 (hfield-ref repr 'variable)))
		       (let ((result2
			      (do-bind-repr binder type-vars repr
					    l-new-visited i-counter)))
			 (hfield-set! binder 'inside-param-proc?
				      inside-old?)
			 result2))))))
		((is-target-object? repr)
		 (let* ((sgt (make-cycle-object repr))
			(new-visited (cons (cons repr sgt) visited))
			(result1
			 (cond
			  ((is-pair-class? repr)
			   (bind-type-vars-pair-class-fwd binder type-vars
			  				  repr new-visited))
			  ((is-tc-param-proc? repr)
			   (inst-bind-param-proc-class binder type-vars repr
						       new-visited))
			  ((is-tc-gen-proc? repr)
			   (inst-bind-gen-proc-class binder type-vars repr
						     new-visited))
			  ((is-t-param-class-instance? repr)
			   (let ((res
				  (bind-type-vars-param-class-fwd binder
								  type-vars
								  repr
								  new-visited)))
			     res))
			  ((is-t-type-loop? repr)
			   (let ((loop-result
				  (bind-type-loop-fwd
				   binder
				   (lambda (tvars1 repr1)
				     (let ((inst-result
					    (do-bind-type-vars0
					     binder tvars1 repr1 new-visited)))
				       inst-result))
				   type-vars
				   repr
				   new-visited)))
			     ;; We shall not overwrite singleton with <null>.
			     (if (eq? (car loop-result) tc-nil)
				 (cons (make-union-expression0 (list tc-nil))
				       (cdr loop-result))
				 loop-result)))
			  ((is-t-type-join? repr)
			   (let* ((join-instances '())
				  (join-result
				   (bind-type-join-fwd
				    binder
				    (lambda (repr1)
				      (let ((inst-result
					     (do-bind-type-vars0
					      binder type-vars repr1 new-visited)))
					(set! join-instances
					      (append join-instances
						      (cdr inst-result)))
					(car inst-result)))
				    repr)))
			     (cons join-result join-instances)))
			  (else
			   (do-bind-repr binder type-vars repr
					 new-visited i-counter)))))
	 	   (let ((res1 (car result1)))
		     (cond
		      ((eq? res1 repr)
		       result1)
		      ((is-normal-variable? res1)
		       result1)
		      ((and
			(is-target-object? res1)
			(hfield-ref res1 'incomplete?)
			(memq res1 (hfield-ref binder 'l-overwrite)))
		       result1)
		      (else
		       (let ((result2 (handle-apti-result binder
							  (car result1))))
			 (update-cycle-object! sgt result2)
			 (cons sgt (cdr result1))))))))
		(else
		 (raise 'do-bind-type-vars00:invalid-input)))))
	  result))))


(define (do-bind-type-vars0 binder type-vars repr visited)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (or (null? repr) (list? repr) (is-entity? repr)
	      (hrecord-is-instance? repr <normal-variable>)))
  ;; (set! gl-counter8 (+ gl-counter8 1))
  ;; (dwi "d0 ")
  ;; (dwc gl-counter8)
  ;; (dwc " ")
  ;; (dwc gl-indent)
  ;; (dwc " ")
  ;; (if (is-target-object? repr)
  ;;     (dwc (debug-get-string repr))
  ;;     (if (hrecord? repr)
  ;; 	  (dwc (hrecord-type-name-of repr))
  ;; 	  (dwc "?")))
  ;; (dwli-newline)  
  (let ((old-indent gl-indent)
	(i-counter gl-counter8))
    (set! gl-indent (+ gl-indent 1))
    (let ((prev-repr (hfield-ref binder 'current-repr-to-bind)))
      (hfield-set! binder 'current-repr-to-bind repr)
      ;; (d2wli 'tvar-binding "do-bind-type-vars0/1")
      (let* ((result
	      (cond
	       ((and (is-entity? repr)
	       	     (let ((address (hfield-ref repr 'address)))
	       	       (and (not-null? address)
	       		    (= (hfield-ref address 'number)
	       		       address-number-builtin)))
		     (let ((type (get-entity-type repr)))
		       (or (is-tc-simple-proc? type)
			   (is-tc-param-proc? type))))
	       	(cons repr '()))
	       (else
		(do-bind-type-vars00 binder type-vars repr
				     visited)))))

	(hfield-set! binder 'current-repr-to-bind prev-repr)

	;; (let ((repr-result (car result)))
	;;   (dwi "d0 exit ")
	;;   (dwli i-counter)
	;;   (dwi "result hash: ")
	;;   (dwc (hashq repr-result 1000000))
	;;   (dwli-newline)
	;;   (if (is-target-object? repr)
	;;       (dwli (debug-get-string repr-result))
	;;       (if (hrecord? repr-result)
	;; 	  (dwli (hrecord-type-name-of repr-result))
	;; 	  (dwli "?"))))
	(set! gl-indent old-indent)
	result))))


(define do-bind-type-vars1 do-bind-type-vars0)


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


(define do-bind-type-vars2 do-bind-type-vars1)


(define (do-bind-type-vars binder type-vars repr)
  (let ((result
	 (do-bind-type-vars1 binder type-vars repr '())))
    result))


(define (inst-bind-type-vars binder type-vars repr)
  (let ((old-instantiation? (hfield-ref binder 'instantiation?))
	(old-make-instances? (hfield-ref binder 'make-instances?))
	(old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'instantiation? #t)
    (hfield-set! binder 'make-instances? #t)
    (hfield-set! binder 'type-check? #t)
    (let ((result
	   (do-bind-type-vars1 binder type-vars repr '())))
      (hfield-set! binder 'instantiation? old-instantiation?)
      (hfield-set! binder 'make-instances? old-make-instances?)
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(define (inst-bind-type-vars0 binder type-vars repr)
  (let ((old-instantiation? (hfield-ref binder 'instantiation?))
	(old-make-instances? (hfield-ref binder 'make-instances?))
	(old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'instantiation? #t)
    (hfield-set! binder 'make-instances? #t)
    (hfield-set! binder 'type-check? #f)
    (let ((result
	   (do-bind-type-vars1 binder type-vars repr '())))
      (hfield-set! binder 'instantiation? old-instantiation?)
      (hfield-set! binder 'make-instances? old-make-instances?)
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(define (bind-type-vars binder type-vars repr)
  (let ((old-make-instances? (hfield-ref binder 'make-instances?))
	(old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'make-instances? #f)
    (hfield-set! binder 'type-check? #t)
    (let ((result
	   (car (do-bind-type-vars0 binder type-vars repr '()))))
      (hfield-set! binder 'make-instances? old-make-instances?)
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(set! bind-type-vars-fwd bind-type-vars)


(define (bind-type-vars3 binder type-vars repr)
  (let ((old-make-instances? (hfield-ref binder 'make-instances?))
	(old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'make-instances? #f)
    (hfield-set! binder 'type-check? #t)
    (let ((br (do-bind-type-vars0 binder type-vars repr '())))
      (hfield-set! binder 'make-instances? old-make-instances?)
      (hfield-set! binder 'type-check? old-type-check?)
      br)))


(set! bind-type-vars3-fwd bind-type-vars3)


(define (bind-type-vars-no-check binder type-vars repr)
  (let ((old-make-instances? (hfield-ref binder 'make-instances?))
	(old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'make-instances? #f)
    (hfield-set! binder 'type-check? #f)
    (let ((result
	   (car (do-bind-type-vars0 binder type-vars repr '()))))
      (hfield-set! binder 'make-instances? old-make-instances?)
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(set! bind-type-vars-no-check-fwd bind-type-vars-no-check)


(define (bind-type-loop binder bind tvars repr visited)
  (assert (is-binder? binder))
  (assert (procedure? bind))
  (check-bindings tvars)
  (assert (is-t-type-loop? repr))
  (assert (list? visited))
  (let ((iter-var (tno-field-ref repr 'tvar))
	(subtype-list0 (tno-field-ref repr 'x-subtypes))
	(iter-expr (tno-field-ref repr 'x-iter-expr)))
    (let* ((br
	    (do-bind-type-vars2 binder tvars subtype-list0 visited))
	   (subtype-list (car br)))
      (cond
       ((is-t-type-variable? subtype-list)
	(if (eqv? subtype-list subtype-list0)
	    (begin
	      (cons repr (cdr br)))
	    (begin
	      (let* ((br1 (do-bind-type-vars2 binder tvars iter-expr visited))
		     (iter-expr1 (car br1)))
		(cons
		 (make-type-loop-object iter-var subtype-list iter-expr1)
		 (append (cdr br) (cdr br1)))))))
       ((is-t-uniform-list-type? binder subtype-list)
	(let* ((tt-param (get-uniform-list-param binder subtype-list))
	       (l-tvars2 (cons (cons iter-var tt-param) tvars))
	       (br3 (do-bind-type-vars2 binder l-tvars2 iter-expr visited)))
	  (cons (make-tt-uniform-list (car br3))
		(append (cdr br) (cdr br3)))))
       (else
	(let ((subexprs
	       (cond
		((is-t-type-list? subtype-list)
		 ;; Formerly we had hfield-ref in the following.
		 (tno-field-ref subtype-list 'l-subtypes))
		((list? subtype-list) subtype-list)
		((is-tuple-type1? binder subtype-list)
		 (tuple-type->list-reject-cycles subtype-list))
		(else
		 (dvar1-set! tvars)
		 (dvar2-set! repr)
		 (dvar3-set! subtype-list)
		 (raise 'internal-error-in-type-loop-type-list)))))
	  (let* ((br2
		  (do-bind-loop bind tvars iter-var
				subexprs
				iter-expr))
		 (result
		  (construct-normal-type-list-repr (car br2))))
	    (cons result (append (cdr br) (cdr br2))))))))))


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


(define (bind-type-join binder bind repr)
  (assert (procedure? bind))
  (assert (is-t-type-join? repr))
  (let ((subexprs (tno-field-ref repr 'l-subtypes)))
    (cond
     ((list? subexprs)
      (let ((subexprs1 (map* bind subexprs)))
	(construct-type-join-repr binder
				  (make-type-join-object subexprs1))))
     ;; (if (or (eqv? subexprs1 subexprs)
     ;; 	(and
     ;; 	 (= (length subexprs1) (length subexprs))
     ;; 	 (and-map? eqv? subexprs1 subexprs)))
     ;;     repr
     ;;     (make-type-join-expression0 subexprs1))))
     ((is-t-type-variable? subexprs)
      (let ((bound-args (bind subexprs)))
	(strong-assert (is-tuple-type1? binder bound-args))
	(let ((arg-list (tuple-type->list-reject-cycles bound-args)))
	  (make-type-join-object arg-list))))
     (else
      (dvar1-set! repr)
      (raise 'internal-error-with-joining-types)))))


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


(define (make-raw-param-class-instance address param-class)
  (assert (or (null? address) (is-address? address)))
  (assert (is-target-object? param-class))
  (let ((obj
	 (make-target-object
	  param-class #t #t address
	  #f #t #f '())))
    obj))


;; This procedure does not accept generic procedure class arguments.
(define (is-t-pure-proc-class? pc)
  (cond
   ((or (is-tc-simple-proc? pc) 
	(is-tt-procedure? pc))
    (tno-field-ref pc 'pure-proc?))
   ((is-tc-param-proc? pc)
    (tno-field-ref (tno-field-ref pc 'type-contents)
		   'pure-proc?))
   (else
    (raise 'invalid-procedure-class))))


(define (handle-apply-expr binder deductions repr expr-proc args
			   new-arg-types inst-type tvars cycles)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? deductions <type-var-assoc-table>))
  (assert (is-entity? expr-proc))
  (assert (and (list? args) (and-map? is-entity? args)))
  (assert (and (list? new-arg-types) (and-map? is-entity? new-arg-types)))
  (assert (is-target-object? inst-type))
  (assert (and (list? tvars) (and-map? is-t-type-variable? tvars)))
  (assert (list? cycles))
  (let* ((applied-proc (car args))
	 (to-proc-type (get-entity-type applied-proc))
	 ;; It might be sufficient to check only if
	 ;; expr-proc equals tp-apply.
	 (pure-appl?
	  (and
	   (eqv? expr-proc tp-apply-fwd)
	   (and-map? is-pure-entity? args)
	   (if (is-tc-gen-proc? to-proc-type)
	       (is-pure-entity? repr)
	       (is-t-pure-proc-class? to-proc-type))))
	 (new-tvar-values (get-type-var-values-from-deductions2-fwd
			   tvars deductions))
	 (tvar-bindings (map cons tvars new-tvar-values))
	 (bind-result1 (do-bind-type-vars2
			binder tvar-bindings
			inst-type
			cycles))
	 (to-inst-type (car bind-result1))
	 (new-instantiations (cdr bind-result1))
	 ;; (l-new-args (map* (lambda (arg)
	 ;; 		     (let ((p (do-bind-type-vars2
	 ;; 			       binder
	 ;; 			       tvar-bindings
	 ;; 			       arg
	 ;; 			       cycles)))
	 ;; 		       (set! new-instantiations
	 ;; 			     (append new-instantiations
	 ;; 				     (cdr p)))
	 ;; 		       (car p)))
	 ;; 		   args))
	 (l-new-args args)
	 (l-new-arg-types2
	  (map* (lambda (arg-type)
		  (let ((p (do-bind-type-vars2
			    binder
			    tvar-bindings
			    arg-type
			    cycles)))
		    (set! new-instantiations
			  (append new-instantiations
				  (cdr p)))
		    (car p)))
		new-arg-types))
	 (tt-actual-arglist
	  (get-arglist-type-from-list l-new-arg-types2))
	 (arg-list-type (tno-field-ref to-inst-type 'type-arglist))
	 (result-type (tno-field-ref to-inst-type 'type-result))
	 (always-returns?
	  (and-map? entity-always-returns? l-new-args))
	 (never-returns?
	  (or-map? entity-never-returns? l-new-args))
	 (type-dispatched? (entity-type-dispatched? applied-proc)))
    (cond
     ((and (hfield-ref binder 'type-check?)
	   (not (check-arglist-types? binder tt-actual-arglist
				      arg-list-type)))
      (dvar1-set! new-arg-types)
      (dvar2-set! tt-actual-arglist)
      (dvar3-set! arg-list-type)
      (dvar4-set! tvar-bindings)
      (raise 'type-mismatch-in-apply-expression))
     ((is-tc-param-proc? to-proc-type)
      (let ((result
	     (let* ((old-arg-types
		     (map get-entity-type l-new-args))
		    (old-tvars (get-all-free-tvars old-arg-types))
		    (new-tvars (get-all-free-tvars new-arg-types)))
	       (strong-assert
		(= (length old-tvars) (length new-tvars)))
	       (let* ((arg-tvar-values
		       (get-type-var-values-from-deductions2-fwd
			new-tvars deductions))
		      (arg-bindings
		       (map cons old-tvars arg-tvar-values))
		      (arg-tvars
		       (tno-field-ref to-proc-type 'l-tvars))
		      (arg-tvar-values1
		       (map
			(lambda (tvar)
			  (let ((pr (assoc tvar arg-bindings
					   type-variable=?)))
			    (if (pair? pr)
				(cdr pr)
				(raise 'internal-error-with-apply-expression-1))))
			arg-tvars))
		      (pp-inst
		       (make-hrecord 
			<expr-param-proc-instance>
			
			result-type
			type-dispatched?
			(is-final-class? binder
					 result-type)
			'()

			pure-appl?
			#t
			#f
			'()

			applied-proc
			arg-tvar-values1))
		      (bind-result2
		       (do-bind-type-vars2
			binder '() pp-inst cycles))
		      (new-proc (car bind-result2)))
		 (set! new-instantiations
		       (append new-instantiations
			       (cdr bind-result2)))
		 new-proc))))
	(cons
	 (make-hrecord <proc-appl>
		       result-type
		       type-dispatched?
		       (is-final-class? binder
					result-type)
		       '()

		       pure-appl? #f #f '()

		       always-returns?
		       never-returns?

		       expr-proc
		       (cons result (cdr args))
		       '()
		       (map get-entity-type
			    (cons result (cdr args)))
		       #f
		       '())
	 new-instantiations)))
     (else
      (let ((result
	     (cons
	      (make-hrecord <proc-appl>
			    result-type
			    type-dispatched?
			    (is-final-class? binder
					     result-type)
			    '()

			    pure-appl? #f #f '()

			    always-returns?
			    never-returns?

			    expr-proc
			    args
			    '()
			    (map get-entity-type args)
			    #f
			    '())
	      '())))
	result)))))


(define (make-param-proc-appl binder proc arglist inst-type r-type-var-values)
  (let* ((result-type
	  (tno-field-ref inst-type 'type-result))
	 (exact-type? (is-final-class? binder result-type))
	 (static-arg-types (map get-entity-type arglist))
	 (always-returns?
	  (and
	   (tno-field-ref inst-type 'appl-always-returns?)
	   (entity-always-returns? proc)
	   (and-map? entity-always-returns? arglist)))
	 (never-returns?
	  (or
	   (tno-field-ref inst-type 'appl-never-returns?)
	   (entity-never-returns? proc)
	   (or-map? entity-never-returns? arglist)))
	 (pure-proc? (tno-field-ref inst-type 'pure-proc?))
	 (pure-args?
	  (and-map? is-pure-entity? arglist))
	 (pure? (and pure-proc? pure-args?))
	 (repr-proc-instance
	     (make-hrecord
	      <expr-param-proc-instance>
	      inst-type
	      #t
	      #f
	      '()
	      #t
	      #t
	      #f
	      '()
	      proc
	      r-type-var-values)))
    ;; The arguments of an optimized procedure application need
    ;; to be typechecked runtime.
    (make-hrecord <proc-appl>
		  result-type
		  #t exact-type? '()
		  pure? #f #f '()
		  always-returns? never-returns?
		  repr-proc-instance arglist '()
		  static-arg-types #t '())))


(define (make-param-proc-appl1 binder proc arglist ppc r-type-var-values)
  (let* ((inst-type (tno-field-ref ppc 'type-contents))
	 (result-type
	  (tno-field-ref inst-type 'type-result))
	 (exact-type? (is-final-class? binder result-type))
	 (static-arg-types (map get-entity-type arglist))
	 (always-returns?
	  (and
	   (tno-field-ref inst-type 'appl-always-returns?)
	   (entity-always-returns? proc)
	   (and-map? entity-always-returns? arglist)))
	 (never-returns?
	  (or
	   (tno-field-ref inst-type 'appl-never-returns?)
	   (entity-never-returns? proc)
	   (or-map? entity-never-returns? arglist)))
	 (pure-proc? (tno-field-ref inst-type 'pure-proc?))
	 (pure-args?
	  (and-map? is-pure-entity? arglist))
	 (pure? (and pure-proc? pure-args?)))
    (make-hrecord <proc-appl>
		  result-type
		  #t exact-type? '()
		  pure? #f #f '()
		  always-returns? never-returns?
		  proc arglist r-type-var-values
		  static-arg-types #f '())))


(define (make-proc-instances binder obj inst-expr)
  (assert (not-null? binder))
  (if (hfield-ref binder 'optimize-raw-proc-inst?)
      (let ((address (hfield-ref obj 'address)))
	(assert (is-address? address))
	(let* ((allocate-variable (hfield-ref binder 'allocate-variable))
	       (addr-raw (allocate-variable 'raw-proc #t)))
	  (address-hash-set! (hfield-ref binder 'ht-raw-procs)
			     address
			     addr-raw)
	  (list (list 'proc obj inst-expr)
		(list 'raw-proc obj addr-raw))))
      (list (list 'proc obj inst-expr))))


(define (do-bind-type-vars-param-proc binder deductions new-tvar-values
				      repr param-proc
				      bound-args new-arg-types inst-type
				      new-type-vars all-tvars fixed-tvars
				      cycles
				      counter)
  (let ((instantiations '())
	(i-counter gl-counter11))
    (if (and (is-pure-entity? param-proc)
	     (memv (get-entity-value param-proc)
		   (list tp-apply-fwd
			 tp-apply-nonpure-fwd)))
	(let* ((result0
		(handle-apply-expr binder deductions repr param-proc
				   bound-args
				   new-arg-types
				   inst-type
				   all-tvars cycles))
	       (result1
		(cons (car result0)
		      (append instantiations (cdr result0)))))
	  result1)
	(if (not-null? fixed-tvars)
	    (let* ((type-var-bindings (map cons new-type-vars new-tvar-values))
	    	   (bind-result1 (do-bind-type-vars2
	    			  binder type-var-bindings
	    			  inst-type
	    			  cycles))
	    	   (new-inst-type (car bind-result1))
		   (repr-appl (make-param-proc-appl
			       binder param-proc bound-args
			       new-inst-type new-tvar-values)))
	      (cons repr-appl (append instantiations (cdr bind-result1))))
	    ;; (let ((repr-appl (make-param-proc-appl binder param-proc bound-args
	    ;; 					   inst-type new-tvar-values)))
	    ;;   (cons repr-appl '()))
	    (let* ((param-cache (get-param-cache binder))
		   ;; It is essential that new-tvar-values is in the same order
		   ;; as new-type-vars.
		   (old-binding (param-cache-fetch2
				 param-cache binder param-proc new-tvar-values))
		   (old-instance (if old-binding (cdr old-binding) #f))
		   (new-instance
		    (if old-instance
			old-instance
			(let* ((alloc
				(hfield-ref binder 'allocate-variable))
			       ;; Parametrized procedure instances are
			       ;; toplevel.
			       (address (alloc 'par #t))
			       (name
				(if (not-null?
				     (hfield-ref param-proc 'address))
				    (hfield-ref
				     (hfield-ref param-proc 'address)
				     'source-name)
				    '()))
			       (proc-instance
				(if #f
				    (inst-make-param-proc-instance-w-params-fwd
				     binder address name inst-type new-type-vars
				     new-tvar-values fixed-tvars cycles)
				    (inst-make-param-proc-instance-fwd
				     binder address inst-type new-type-vars
				     new-tvar-values cycles)))
			       (obj (car proc-instance))
			       (subinst (cadr proc-instance)))
			  (param-cache-add-binding! param-cache
						    param-proc
						    new-tvar-values obj)
			  (set! instantiations
				(append instantiations subinst))
			  (if (and
			       (is-known-object? param-proc)
			       (not (hfield-ref param-proc 'incomplete?)))
			      (begin
				(let* ((contents
					(inst-set-param-proc-instance-contents-fwd
					 binder obj param-proc
					 new-tvar-values name cycles))
				       (inst-expr (car contents))
				       (subinst2 (cadr contents)))
				  (if (hfield-ref binder 'optimize-copying?)
				      (if #f
					  (set! instantiations
						(append instantiations
							subinst2))
					  (set! instantiations
						(append instantiations
							subinst2
							(make-proc-instances
							 binder
							 obj
							 inst-expr)))))))
			      (if (hfield-ref binder 'make-instances?)
				  (hfield-set!
				   binder 'decl-proc-instances
				   (cons (list obj param-proc new-tvar-values)
					 (hfield-ref binder 'decl-proc-instances)))))
			  obj)))
		   (new-repr
		    (begin
		      (if (hfield-ref binder 'optimize-copying?)
			  (translate-simple-proc-appl-expression1-fwd
			   binder
			   new-instance bound-args #f
			   (hfield-ref binder 'type-check?)
			   (or
			    (hfield-ref binder 'tcomp-inside-param-proc?)
			    (hfield-ref binder 'inside-param-proc?))
			   #f)
			  (make-param-proc-appl1
			   binder param-proc bound-args
			   (get-entity-type new-instance)
			   new-tvar-values)))))
	      (cons new-repr instantiations))))))


(define (bind-type-vars-param-proc binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (list? cycles))
  (let ((old-indent gl-indent)
	(i-counter gl-counter9))
    (set! gl-indent (+ gl-indent 1))
    (let* ((instantiations '())
	   (args (hfield-ref repr 'arglist))
	   (bound-args
	    (map (lambda (arg)
		   (let ((subresult (do-bind-type-vars2 binder type-vars arg
							cycles)))
		     (set! instantiations
			   (append instantiations (cdr subresult)))
		     (car subresult)))
		 args))
	   (arg-types (map get-entity-type bound-args))
	   (l-bound-default-params
	    (map (lambda (arg)
		   (let ((subresult (do-bind-type-vars2 binder type-vars arg
							cycles)))
		     (set! instantiations
			   (append instantiations (cdr subresult)))
		     (car subresult)))
		 (hfield-ref repr 'l-default-params)))
	   (result
	    (begin
	      ;; We don't check the procedure expression for parametrized definitions
	      ;; (occurrences of type variables in type-vars).
	      (let* ((param-proc (hfield-ref repr 'proc))
		     (subresult-pp (cons '() '())))
		;; (subresult-pp (do-bind-type-vars binder type-vars param-proc))
		;; (bound-param-proc (car subresult-pp))
		;; (param-proc-value (get-expr-value bound-param-proc)))
		(assert (is-target-object? param-proc))
		(set! instantiations (append instantiations (cdr subresult-pp)))
		(let* ((to-ppc (get-entity-type param-proc))
		       (inst-type0 (tno-field-ref to-ppc 'type-contents))
		       (new-type-vars0 (tno-field-ref to-ppc 'l-tvars))
		       (uniq (make-tvars-unique-fwd binder new-type-vars0 inst-type0))
		       (inst-type (car uniq))
		       (new-type-vars (cdr uniq))
		       (new-arg-types (make-tvars-unique2 binder arg-types))
		       ;;	     (src-tvars (get-all-tvars new-arg-types))
		       (arg-list-desc0
			(tno-field-ref inst-type 'type-arglist)))

		  (let* ((deductions (get-new-type-var-assoc-table))
			 (src-tvars (get-all-free-tvars new-arg-types))
			 (fixed-tvars
			  (if (hfield-ref binder 'inside-param-proc?)
			      (get-all-free-tvars1 new-arg-types)
			      '()))
			 (all-tvars 
			  (append src-tvars new-type-vars))
			 (old-fixed-tvars (hfield-ref binder 'fixed-tvars)))
		    (hfield-set! binder 'fixed-tvars fixed-tvars)
		    (deduce-argument-types binder deductions all-tvars
					   new-arg-types arg-list-desc0)
		    (hfield-set! binder 'fixed-tvars old-fixed-tvars)
		    (cond
		     ((all-tvars-correct? deductions new-type-vars)
		      (let* ((new-tvar-values
			      (get-type-var-values-from-deductions2-fwd
			       new-type-vars deductions))
			     (res
			      (do-bind-type-vars-param-proc
			       binder deductions new-tvar-values
			       repr param-proc
			       bound-args
			       new-arg-types
			       inst-type
			       new-type-vars
			       all-tvars
			       fixed-tvars
			       cycles
			       i-counter))
			     (lst-inst (append instantiations (cdr res))))
			(cons (car res) lst-inst)))
		      ((not-null? l-bound-default-params)
		       (let* ((res
			       (do-bind-type-vars-param-proc
				binder deductions l-bound-default-params
				repr param-proc
				bound-args
				new-arg-types
				inst-type
				new-type-vars
				all-tvars
				fixed-tvars
				cycles
				i-counter))
			      (lst-inst (append instantiations (cdr res))))
			(cons (car res) lst-inst)))
		      (else
		       (raise (list 'did-not-deduce-all-type-vars-2
				    (get-proc-name repr)
				    (cons 'actual-type new-arg-types)
				    (cons 'declared-type arg-list-desc0)
				    (cons
				     'bindings
				     (hfield-ref deductions 'bindings))
				    (cons 'needed new-type-vars)))))))))))
      (set! gl-indent old-indent)
      result)))


(set! bind-type-vars-param-proc-fwd bind-type-vars-param-proc)


(define (bind-type-vars-param-proc-runtime binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (list? cycles))
  (let* ((instantiations '())
	 (args (hfield-ref repr 'arglist))
	 (bound-args
	  (map (lambda (arg)
		 (let ((subresult (do-bind-type-vars2 binder type-vars arg
						      cycles)))
		   (set! instantiations
			 (append instantiations (cdr subresult)))
		   (car subresult)))
	       args))
	 (arg-types (map get-entity-type bound-args))
	 (result-instance
	  (make-hrecord <proc-appl>
			(hfield-ref repr 'type)
			(hfield-ref repr 'type-dispatched?)
			(hfield-ref repr 'exact-type?)
			(hfield-ref repr 'address)
			(hfield-ref repr 'pure?)
			(hfield-ref repr 'static?)
			#f
			'()
			(hfield-ref repr 'always-returns?)
			(hfield-ref repr 'never-returns?)
			(hfield-ref repr 'proc)
			bound-args
			(hfield-ref repr 'params)
			'()
			#t
			'())))
    (cons result-instance instantiations)))


(set! bind-type-vars-param-proc-runtime-fwd bind-type-vars-param-proc-runtime)


(define (inst-make-param-proc-instance2 binder address param-proc
					type-var-values cycles)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? address <address>))
  (assert (is-target-object? param-proc))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (let* ((instantiations '())
	 (to-ppc (get-entity-type param-proc))
	 (tvars (tno-field-ref to-ppc 'l-tvars)))
    (if (not (= (length type-var-values) (length tvars)))
	(begin
	  (raise (list 'param-proc-inst:invalid-number-of-parameters
		       (tno-field-ref param-proc 's-name)
		       (length type-var-values)))))
    (let* ((type-var-bindings (map cons tvars type-var-values))
	   (bind-result1 (do-bind-type-vars2
			  binder type-var-bindings
			  (tno-field-ref to-ppc 'type-contents)
			  cycles)))
      (set! instantiations (append instantiations (cdr bind-result1)))
      (let* ((new-inst-type (car bind-result1))
	     ;; Should we have exact-type? = #t?
	     (obj (make-incomplete-object-with-address
		   address new-inst-type #f)))
	(list obj instantiations)))))


(define (make-param-proc-instance-w-params binder param-proc params cycles)
  (let* ((instantiations '())
	 (to-ppc (get-entity-type param-proc))
	 (tvars (tno-field-ref to-ppc 'l-tvars)))
    (if (not (= (length params) (length tvars)))
	(begin
	  (raise (list 'param-proc-inst:invalid-number-of-parameters
		       (tno-field-ref param-proc 's-name)
		       (length type-var-values)))))
    (let* ((type-var-bindings (map cons tvars params))
	   (bind-result1 (do-bind-type-vars2
			  binder type-var-bindings
			  (tno-field-ref to-ppc 'type-contents)
			  cycles))
	   (new-inst-type (car bind-result1)))
      (set! instantiations (append instantiations (cdr bind-result1)))
      (let ((repr-result
	     (make-hrecord
	      <expr-param-proc-instance>
	      new-inst-type
	      #t
	      #f
	      '()
	      #t
	      #t
	      #f
	      '()
	      param-proc
	      params)))
	(cons repr-result instantiations)))))


;; The following procedure works for both <expr-param-proc-instance>
;; and <expr-param-proc-dispatch>.
(define (do-bind-type-vars-param-proc-instance binder type-vars
					       bound-param-proc params cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (is-entity? bound-param-proc))
  (assert (and-map? is-target-object? params))
  (assert (list? cycles))
  (assert (and-map? is-target-object? params))
  (if (and (hfield-ref binder 'inside-param-proc?)
	   (or-map contains-free-tvars-general? params))
      (make-param-proc-instance-w-params binder bound-param-proc params
					 cycles)
      (let* ((instantiations '())
	     (param-cache (get-param-cache binder))
	     (old-binding (param-cache-fetch2
			   param-cache binder bound-param-proc params))
	     (old-instance (if old-binding (cdr old-binding) #f))
	     (new-instance
	      (if old-instance
		  old-instance
		  (let* ((alloc (hfield-ref binder 'allocate-variable))
			 (address (alloc 'proc-inst #t))
			 (name (tno-field-ref bound-param-proc 's-name))
			 (proc-instance (inst-make-param-proc-instance2
					 binder address bound-param-proc
					 params cycles))
			 (obj (car proc-instance))
			 (subinst (cadr proc-instance)))
		    (param-cache-add-binding! param-cache bound-param-proc
					      params obj)
		    (set! instantiations
			  (append instantiations subinst))
		    (let* ((contents
			    (inst-set-param-proc-instance-contents-fwd
			     binder obj bound-param-proc
			     params name cycles))
			   (inst-expr (car contents))
			   (subinst2 (cadr contents)))
		      (set! instantiations
			    (append instantiations
				    subinst2
				    (list (list 'proc obj inst-expr))))
		      obj)))))
	(cons new-instance instantiations))))


(define (bind-type-vars-param-proc-instance binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <expr-param-proc-instance>))
  (assert (list? cycles))
  (let* ((instantiations '())
	 (param-proc (hfield-ref repr 'param-proc))
	 (subresult-pp (do-bind-type-vars2 binder type-vars param-proc
					   cycles))
	 (bound-param-proc (car subresult-pp)))
    ;; instantiations is initially empty here.
    (set! instantiations (cdr subresult-pp))
    (let* ((params (hfield-ref repr 'params))
	   (bound-params
	    (map (lambda (param)
		   (let ((subresult (do-bind-type-vars2 binder type-vars
							param cycles)))
		     (set! instantiations
			   (append instantiations (cdr subresult)))
		     (car subresult)))
		 params)))
      (let ((subresult-inst
	     (do-bind-type-vars-param-proc-instance binder type-vars
						    bound-param-proc
						    bound-params
						    cycles)))
	(set! instantiations (append instantiations (cdr subresult-inst)))
	(cons (car subresult-inst) instantiations)))))


(set! bind-type-vars-param-proc-instance-fwd
      bind-type-vars-param-proc-instance)


(define (bind-type-vars-param-proc-dispatch binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  (assert (list? cycles))
  (let* ((instantiations '())
	 (argument-types (hfield-ref repr 'argument-types))
	 (argument-types1
	  (map (lambda (arg-type)
		 (let ((subresult (do-bind-type-vars2
				   binder type-vars
				   (construct-argument-type-repr
				    binder arg-type)
				   cycles)))
		   (set! instantiations
			 (append instantiations (cdr subresult)))
		   (car subresult)))
	       argument-types)))
    (let* ((param-proc (hfield-ref repr 'param-proc))
	   (subresult-pp (do-bind-type-vars2 binder type-vars param-proc
					     cycles))
	   (bound-param-proc (car subresult-pp)))
      (assert (is-target-object? param-proc))
      (set! instantiations (append instantiations (cdr subresult-pp)))
      (let* ((inst-expr (tno-field-ref bound-param-proc 'x-value-expr))
	     (ppc (get-entity-type bound-param-proc))
	     (inst-type (tno-field-ref ppc 'type-contents))
	     (new-type-vars (tno-field-ref ppc 'l-tvars))
	     (arg-list-type0 (tno-field-ref inst-type 'type-arglist))
	     (new-argument-types
	      (make-tvars-unique2 binder argument-types1))
	     (src-tvars (get-all-tvars new-argument-types))
	     (all-tvars (append src-tvars new-type-vars))
	     (deductions (get-new-type-var-assoc-table)))
	(deduce-argument-types binder deductions all-tvars
			       new-argument-types arg-list-type0)
	(if (all-tvars-correct? deductions new-type-vars)
	    ;; It is essential that new-tvar-values is in the same order
	    ;; as new-type-vars.
	    (let* ((new-tvar-values (get-type-var-values-from-deductions-fwd
				     new-type-vars deductions))
		   (subresult-inst
		    (do-bind-type-vars-param-proc-instance binder type-vars
							   bound-param-proc
							   new-tvar-values
							   cycles)))
	      (set! instantiations (append instantiations (cdr subresult-inst)))
	      (cons (car subresult-inst) instantiations))
	    (begin
	      (dvar1-set! new-type-vars)
	      (dvar2-set! repr)
	      (dvar3-set! arg-list-type0)
	      (raise 'did-not-guess-all-type-vars-in-dispatch)))))))


(set! bind-type-vars-param-proc-dispatch-fwd
      bind-type-vars-param-proc-dispatch)


(define (bind-param-prim-proc-appl binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (list? cycles))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let* ((proc (hfield-ref repr 'proc))
	   (arglist (hfield-ref repr 'arglist))
	   (l-default-params (hfield-ref repr 'l-default-params))
	   (instantiations '())
	   (do-inst (lambda (subexpr)
		      (if (not-null? subexpr)
			  (let ((bind-result
				 (do-bind-type-vars2
				  binder type-vars subexpr
				  cycles)))
			    (set! instantiations
				  (append instantiations (cdr bind-result)))
			    (car bind-result))
			  '())))
	   (new-arglist (map* do-inst arglist))
	   (l-new-default-params (map* do-inst l-default-params))
	   (new-subreprs (list proc new-arglist l-new-default-params))
	   (new-repr (cwb-param-proc-appl binder repr new-subreprs #t)))
      (set! gl-indent old-indent)
      (cons new-repr instantiations))))


(define (bind-type-vars-normal-param-class binder bound-param-class params
					   repr cycles)
  (let* ((param-cache (hfield-ref binder 'param-cache))
	 (old-binding (param-cache-fetch param-cache
					 bound-param-class
					 params))
	 (old-instance
	  (if old-binding (cdr old-binding) #f)))
    (if (eq? old-instance #f)
	(let* ((alloc (hfield-ref binder 'allocate-variable))
	       (address (if (hfield-ref binder 'make-instances?)
			    (alloc 'b1 #t) '()))
	       (instance (create-fwd-ref-for-instance-fwd
			  bound-param-class address))
	       (l-old-overwrite (hfield-ref binder 'l-overwrite)))
	  (hfield-set! binder 'l-overwrite
		       (cons instance l-old-overwrite))
	  (param-cache-add-binding! param-cache bound-param-class params
				    instance)
	  (let ((instantiations
		 (inst-make-param-class-instance-fwd!
		  binder instance bound-param-class
		  params #t cycles)))
	    (set! instantiations
		  (append instantiations
			  (list
			   (list 'class instance bound-param-class params))))
	    (hfield-set! binder 'l-overwrite
			 l-old-overwrite)
	    (cons instance instantiations)))
	(cons old-instance '()))))


(define (bind-type-vars-param-class binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))

  (check-bindings type-vars)

  (assert (is-t-param-class-instance? repr))

  (if gl-test7
      (raise
       (list 'param-class-inst-error
	     'could-not-handle-param-class-args
	     repr type-vars)))

  (let ((instantiations '())
	(param-class (get-entity-type repr))
	(args (tno-field-ref repr 'l-tvar-values))
	(old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((subresult-pc (do-bind-type-vars2 binder type-vars param-class
					    cycles)))
      (set! instantiations (append instantiations (cdr subresult-pc)))
      (let ((bound-param-class (car subresult-pc)))
	(let* ((bound-args
		(let ((subresult (do-bind-type-vars2 binder type-vars args
						     cycles)))
		  (set! instantiations
			(append instantiations (cdr subresult)))
		  (car subresult)))
	       (result
		(if (and-map? eq? args bound-args)
		    (cons repr '())
		    (begin
		      ;; The following test should probably be removed.
		      ;; (check-no-none-types bound-args)
		      (if (equal? bound-args '(()))
			  (cons
			   (make-apti bound-param-class bound-args)
			   instantiations)
			  (let ((param-list (construct-toplevel-type-repr
					     binder bound-args)))
			    (if (is-tuple-type1? binder param-list)
				(let ((res
				       (bind-type-vars-normal-param-class
					binder bound-param-class
					(tuple-type->list-reject-cycles
					 param-list)
					repr cycles)))
				  (cons (car res)
					(append instantiations (cdr res))))
				(if (hfield-ref binder 'type-check?)
				    (begin
				      (dvar1-set! param-list)
				      (dvar2-set! repr)
				      (dvar3-set! type-vars)
				      (raise
				       (list 'param-class-inst-error
					     'could-not-handle-param-class-args
					     repr type-vars)))
				    (cons
				     (translate-param-class-instance-expr
				      binder
				      bound-param-class
				      bound-args
				      #f #t)
				     instantiations)))))))))
	  (set! gl-indent old-indent)
	  result)))))


(set! bind-type-vars-param-class-fwd bind-type-vars-param-class)


(define (bind-type-vars-pair-class binder type-vars repr cycles)
  (let* ((pair-inst '())
	 (old-car (get-pair-first-type repr))
	 (old-cdr (get-pair-second-type repr))
	 (new-car
	  (let ((b1
		 (do-bind-type-vars0
		  binder type-vars
		  old-car
		  cycles)))
	    (set! pair-inst
		  (append pair-inst (cdr b1)))
	    (car b1)))
	 (new-cdr
	  (let ((b2
		 (do-bind-type-vars0
		  binder type-vars
		  old-cdr
		  cycles)))
	    (set! pair-inst
		  (append pair-inst (cdr b2)))
	    (car b2)))
	 (param-list (construct-toplevel-type-repr
		      binder (list new-car new-cdr)))
	 (res1
	  (if (is-tuple-type1? binder param-list)
	      (let ((new-car2 (gen-car param-list))
		    (new-cdr2 (gen-car (gen-cdr param-list))))
		(if (or (not (eq? old-car new-car2))
			(not (eq? old-cdr new-cdr2)))
		    (make-tpci-pair new-car2 new-cdr2)
		    repr))
	      (translate-param-class-instance-expr
	       binder
	       tpc-pair
	       (list new-car new-cdr)
	       #f #t))))
    (cons res1 pair-inst)))


(set! bind-type-vars-pair-class-fwd bind-type-vars-pair-class)


(define (bind-type-vars-for-field binder type-vars field cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (is-t-field? field))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let* ((inst '())
	   (to-type (tno-field-ref field 'type))
	   (has-init-value? (tno-field-ref field 'has-init-value?))
	   (to-new-type
	    (let ((bind-result (do-bind-type-vars2 binder type-vars to-type
						   cycles)))
	      (set! inst (cdr bind-result))
	      (car bind-result)))
	   (obj-init-value
	    (if has-init-value?
		(tno-field-ref field 'x-init-value)
		'()))
	   (obj-new-init-value
	    (if has-init-value?
		(let ((bind-result
		       (do-bind-type-vars2 binder type-vars obj-init-value
					   cycles)))
		  (set! inst (append inst (cdr bind-result)))
		  (car bind-result))
		'())))
      (cond
       ((entity-is-none1? binder to-new-type)
	(raise (list 'field-type-none1 (cons 's-field-name
					     (tno-field-ref field 's-name)))))
       ((and (hfield-ref binder 'type-check?)
	     has-init-value?
	     (not (contains-type-variables-fwd? to-new-type))
	     (not (is-t-instance? binder obj-new-init-value to-new-type)))
	(raise (list 'field-type-mismatch-in-param-class
		     (cons 's-field-name (tno-field-ref field 's-name))
		     (cons 'tt-field to-new-type)
		     (cons 'tt-init (get-entity-type obj-new-init-value)))))
       (else
	(let ((result
	       (if (and (eqv? to-type to-new-type)
			(eqv? obj-init-value obj-new-init-value))
		   (cons field inst)
		   (let* ((sym-name (tno-field-ref field 's-name))
			  (acc-read (tno-field-ref field 's-read-access))
			  (acc-write (tno-field-ref field 's-write-access)))
		     (cons
		      (make-field sym-name to-new-type acc-read acc-write
				  has-init-value? obj-new-init-value)
		      inst)))))
	  (set! gl-indent old-indent)
	  result))))))


(define (bind-type-vars-for-field-list binder type-vars field-list cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (list? field-list))
  (let* ((instantiations '())
	 (result
	  (map (lambda (field)
		 (let* ((bind-result
			 (bind-type-vars-for-field
			  binder type-vars field cycles))
			(new-field (car bind-result)))
		   (set! instantiations (append instantiations
						(cdr bind-result)))
		   new-field))
	       field-list)))
    (cons result instantiations)))


;; make-constructor!:ia kutsutaan compute-instantion:ista
(define (inst-make-param-class-instance! binder obj
					 param-class type-var-values
					 make-ctr? cycles)
  (assert (is-binder? binder))
  (assert (is-target-object? obj))
  (assert (is-target-object? param-class))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (assert (boolean? make-ctr?))
  (let ((instantiations '()))
    (let ((inheritable? (tno-field-ref param-class 'instances-inheritable?))
	  (immutable? (tno-field-ref param-class 'instances-immutable?))
	  (eq-by-value? (tno-field-ref param-class 'instances-eq-by-value?))
	  (ctr-access (tno-field-ref param-class 's-instance-ctr-access))
	  (superclass (tno-field-ref param-class 'cl-instance-superclass))
	  (has-zero? (tno-field-ref param-class 'instance-has-zero?))
	  (module (tno-field-ref param-class 'module))
	  (fields (tno-field-ref param-class 'l-instance-fields))
	  (all-fields (tno-field-ref param-class 'l-instance-all-fields))
	  (type-vars (tno-field-ref param-class 'l-tvars)))
      (assert (boolean? inheritable?))
      (assert (boolean? immutable?))
      (assert (boolean? eq-by-value?))
      (assert (memq ctr-access gl-access-specifiers))
					; HUOM. union ja tuple
      (assert (and-map? is-t-type-variable? type-vars))
      (let* ((type-var-bindings (map cons type-vars type-var-values))
	     (r-superclass
	      (let* ((binding-result (do-bind-type-vars2
				      binder type-var-bindings
				      superclass
				      cycles))
		     (bound-expr (car binding-result)))
		(set! instantiations (append instantiations
					     (cdr binding-result)))
		bound-expr))
	     (r-fields
	      (let* ((binding-result (bind-type-vars-for-field-list
				      binder type-var-bindings
				      fields cycles))
		     (bound-fields (car binding-result)))
		(set! instantiations (append instantiations
					     (cdr binding-result)))
		bound-fields))
	     (r-all-fields
	      (let* ((binding-result (bind-type-vars-for-field-list
				      binder type-var-bindings
				      all-fields cycles))
		     (bound-fields (car binding-result)))
		(set! instantiations (append instantiations (cdr binding-result)))
		bound-fields)))
	(cond
	 ((not (tno-field-ref r-superclass 'inheritable?))
	  (raise 'noninheritable-superclass))
	 ((contains-duplicate-field-names-fwd? r-superclass r-fields)
	  (raise 'param-duplicate-field-name))
	 (else
	  (let* ((param-class-name (tno-field-ref param-class 'str-name))
		 (instance-class-name
		  (string-append "(" param-class-name " ...)"))
		 (to
		  (make-target-object
		   param-class #t #f '()
		   #f #f
		   (list 
		    (cons 'cl-superclass r-superclass)
		    (cons 'l-fields r-fields)
		    (cons 'l-all-fields r-all-fields)
		    (cons 'inheritable? inheritable?)
		    (cons 'immutable? immutable?)
		    (cons 'eq-by-value? eq-by-value?)
		    (cons 's-ctr-access ctr-access)
		    (cons 'type-constructor '())
		    (cons 'proc-constructor '())
		    (cons 'goops? #f)
		    (cons 'has-zero? has-zero?)
		    (cons 'zero-prim? #f)
		    (cons 'x-zero-value '())
		    (cons 'module module)
		    (cons 'str-name instance-class-name)
		    (cons 'l-tvar-values type-var-values)
		    (cons 'l-param-exprs type-var-values))
		   '())))
	    (set-object1! obj to)
	    (if make-ctr?
		(make-constructor-fwd!
		 binder
		 obj))
	    instantiations)))))))


(set! inst-make-param-class-instance-fwd!
      inst-make-param-class-instance!)


(define (inst-make-param-proc-instance binder address inst-type tvars
				       type-var-values cycles)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? address <address>))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (let ((instantiations '()))
    ;; Should we have strong-assert?
    (assert (= (length type-var-values) (length tvars)))
    (let* ((type-var-bindings (map cons tvars type-var-values))
	   (bind-result1 (do-bind-type-vars2
			  binder type-var-bindings
			  inst-type
			  cycles)))
      (set! instantiations (append instantiations (cdr bind-result1)))
      (let* ((new-inst-type (car bind-result1))
	     ;; Should we have exact-type? = #t?
	     (obj (make-incomplete-object-with-address
		   address new-inst-type #f)))
	(list obj instantiations)))))


(set! inst-make-param-proc-instance-fwd
      inst-make-param-proc-instance)


;; The following procedure is apparently not used.
(define (inst-make-param-proc-instance-w-params binder address str-name
						inst-type tvars
						type-var-values fixed-tvars
						cycles)
  (assert (is-binder? binder))
  (assert (hrecord-is-instance? address <address>))
  (assert (string? str-name))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (assert (list? fixed-tvars))
  (assert (and-map? is-target-object? fixed-tvars))
  (let ((instantiations '()))
    ;; Should we have strong-assert?
    (assert (= (length type-var-values) (length tvars)))
    (let* ((type-var-bindings (map cons tvars type-var-values))
	   (bind-result1 (do-bind-type-vars2
			  binder type-var-bindings
			  inst-type
			  cycles)))
      (set! instantiations (append instantiations (cdr bind-result1)))
      (let* ((new-inst-type (car bind-result1))
	     (ppc-new (make-param-proc-class-object str-name fixed-tvars
						    new-inst-type))
	     (obj (make-param-proc-object
		   str-name ppc-new '() address)))
	(list obj instantiations)))))


(set! inst-make-param-proc-instance-w-params-fwd
      inst-make-param-proc-instance-w-params)


(define (inst-set-param-proc-instance-contents binder obj param-proc
					       type-var-values name cycles)
  (assert (is-binder? binder))
  (assert (is-target-object? param-proc))
  (assert (list? type-var-values))
  (assert (and-map? is-target-object? type-var-values))
  (assert (or (symbol? name) (null? name)))
  (let* ((instantiations '())
	 (to-ppc (get-entity-type param-proc))
	 (tvars (tno-field-ref to-ppc 'l-tvars))
	 (s-old-toplevel (hfield-ref binder 's-cur-toplevel))
	 (expr-old-cur-proc (hfield-ref binder 'expr-cur-proc)))
    ;; Ordinary assert might be enough.
    (strong-assert (= (length type-var-values) (length tvars)))
    (set-cur-param-proc! binder param-proc)
    (hfield-set! binder 'expr-cur-proc (tno-field-ref param-proc 'x-value-expr))
    (let* ((type-var-bindings (map cons tvars type-var-values))
	   ;; (inst-type (tno-field-ref to-ppc 'inst-type))
	   (value-expr (tno-field-ref param-proc 'x-value-expr))
	   (bind-result (inst-bind-type-vars
			 binder type-var-bindings
			 value-expr))
	   (new-value-expr (car bind-result))
	   ;; (bind-result2 (do-bind-type-vars2
	   ;; 		  binder type-var-bindings
	   ;; 		  inst-type cycles))
	   ;; (new-inst-type (car bind-result2))
	   (new-inst-type (get-entity-type obj))
	   (address (hfield-ref obj 'address))
	   (addr-raw-proc
	    (let ((p (assq 'addr-raw-proc
			   (hfield-ref param-proc 'al-field-values))))
	      (if p (cdr p) '())))
	   (obj-new
	    (make-procedure new-inst-type #t #f address
			    name addr-raw-proc)))
      (set-object! obj obj-new)
      ;; (set! instantiations (append instantiations
      ;; 				   (cdr bind-result)
      ;; 				   (cdr bind-result2)))
      (set! instantiations (append instantiations
				   (cdr bind-result)))
      (hfield-set! binder 's-cur-toplevel s-old-toplevel)
      (hfield-set! binder 'expr-cur-proc expr-old-cur-proc)
      (list new-value-expr instantiations))))


(set! inst-set-param-proc-instance-contents-fwd
      inst-set-param-proc-instance-contents)


(define (inst-bind-param-proc-class binder type-vars repr cycles)
  (assert (is-binder? binder))
  ;; Note: type-vars contains bindings instead of plain type variables.
  (let* ((inst-type (tno-field-ref repr 'type-contents))
	 (bound-tvars (tno-field-ref repr 'l-tvars))
	 (bind-result
	  (do-bind-type-vars2 binder type-vars inst-type cycles))
	 (new-inst-type (car bind-result))
	 (instantiations (cdr bind-result))
	 (tvars-to-bind (map car type-vars))
	 (new-bound-tvars
	  (filter (lambda (tvar)
		    (not (member tvar tvars-to-bind type-variable2=?)))
		  bound-tvars))
	 (new-ppc
	  (cond
	   ((eqv? new-inst-type inst-type)
	    repr)
	   ((null? new-bound-tvars)
	    new-inst-type)
	   (else
	    (make-param-proc-class-object
	     (tno-field-ref repr 'str-name)
	     new-bound-tvars
	     new-inst-type)))))
    (cons new-ppc instantiations)))


(define (inst-bind-gen-proc-class binder type-vars repr cycles)
  ;; Note: type-vars contains bindings instead of plain type variables.
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (let ((old-method-classes (tno-field-ref repr 'l-method-classes))
	(new-method-classes '())
	(instantiations '()))
    (do ((classes old-method-classes (cdr classes)))
	((null? classes))
      (let* ((bind-result
	      (do-bind-type-vars2 binder type-vars (car classes) cycles))
	     (new-class (car bind-result))
	     (new-inst (cdr bind-result)))
	(set! new-method-classes (append new-method-classes (list new-class)))
	(set! instantiations (append instantiations new-inst))))
    (let ((new-repr
	   (clone-with-branches-fwd 
	    binder
	    repr
	    new-method-classes
	    #t)))
      (cons new-repr instantiations))))


(define (inst-check-let-variable binder to-decl-type ent-init-expr s-name)
  (assert (is-binder? binder))
  (assert (or (null? to-decl-type) (is-target-object? to-decl-type)))
  (assert (is-entity? ent-init-expr))
  (assert (symbol? s-name))
  (let ((to-expr-type (get-entity-type ent-init-expr)))
    (cond
     ((null? to-decl-type) #t)
     ((or (contains-free-tvars-fwd? to-decl-type)
	  (contains-free-tvars-fwd? to-expr-type))
      #t)
     ((and (hfield-ref binder 'type-check?)
	   (not (is-t-subtype? binder to-expr-type to-decl-type)))
      (raise (list 'let-variable-type-mismatch-1
		   (cons 's-name s-name)
		   (cons 'tt-expr to-expr-type)
		   (cons 'tt-decl to-decl-type))))
     (else #t))))


(define (inst-make-let-variable binder read-only?
				var-old to-old-type expr-old-init
				to-new-type expr-new-init)
  (assert (is-binder? binder))
  (if (and (eq? to-old-type to-new-type)
	   (eq? expr-old-init expr-new-init))
      var-old
      (make-normal-variable6
       (hfield-ref var-old 'address)
       (if (not-null? to-new-type)
	   to-new-type
	   (get-entity-type expr-new-init))
       (or (not-null? to-new-type)
	   (entity-type-dispatched? expr-new-init))
       #f
       read-only?
       (hfield-ref var-old 'volatile?)
       #f
       (get-entity-value expr-new-init)
       '())))


(define (is-letvar? letvar)
  (and
   (list? letvar)
   (= (length letvar) 6)
   (is-target-object? (car letvar))
   (is-normal-variable? (cadr letvar))
   (is-entity? (caddr letvar))
   (or (null? (list-ref letvar 3))
       (is-target-object? (list-ref letvar 3)))
   (is-entity? (list-ref letvar 4))
   (is-t-primitive-object? (list-ref letvar 5))))


(define (inst-make-let-subst l-old-bindings l-new-bindings)
  (filter (lambda (pr) (and (or (is-t-type-variable? (car pr))
				(is-normal-variable? (car pr)))
			    (not (eqv? (car pr) (cdr pr)))))
	  (map cons l-old-bindings l-new-bindings)))


(define (inst-make-letrec-letvars binder type-vars letvars old-bindings
				  readonly? cycles)
  (assert (is-binder? binder))
  (check-bindings type-vars)
  (assert (and (list? letvars)
	       (and-map? is-letvar? letvars)))
  (assert (and (list? old-bindings)
	       (and-map? is-entity? old-bindings)))
  (assert (boolean? readonly?))
  (let ((instantiations '()))
    (if (null? old-bindings)
	(cons '() '())
	(let* ((names (map car letvars))
	       (new-vars (map cadr letvars))
	       (new-bindings (map caddr letvars))
	       (declared-types (map cadddr letvars))
	       (init-exprs (map (lambda (x) (list-ref x 4)) letvars))
	       (bind-object (map (lambda (x) (list-ref x 5)) letvars))
	       (rebind-data
		(inst-make-let-subst old-bindings new-bindings))
	       (init-exprs1
		(map (lambda (expr)
		       (rebind-local-variables1-fwd binder
						    expr
						    rebind-data))
		     init-exprs))
	       (final-init-exprs
		(map (lambda (expr)
		       (let ((result
			      (do-bind-type-vars2 binder type-vars
						  expr cycles)))
			 (set! instantiations
			       (append instantiations (cdr result)))
			 (car result)))
		     init-exprs1))
	       (bound-decl-types
		(map (lambda (expr)
		       (let ((result
			      (do-bind-type-vars2 binder type-vars
						  expr cycles)))
			 (set! instantiations
			       (append instantiations (cdr result)))
			 (car result)))
		     declared-types))
	       (result
		(cons
		 (map list names new-vars new-bindings
		      bound-decl-types final-init-exprs
		      bind-object)
		 instantiations)))
	  result))))


(define (inst-bind-let-expression binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <let-expression>))
  (let* ((i-counter gl-counter22)
	 (recursive? (hfield-ref repr 'recursive?))
	 (order? (hfield-ref repr 'order?))
	 (readonly-bindings? (hfield-ref repr 'readonly-bindings?))
	 (instantiations '())
	 (letvars (hfield-ref repr 'variables))
	 (names (map car letvars))
	 (l-s-names (map get-contents names))
	 (l-old-vars (map cadr letvars))
	 (old-bindings (map caddr letvars))
	 (declared-types (map cadddr letvars))
	 (init-exprs (map (lambda (x) (list-ref x 4)) letvars))
	 (l-bind-object-wrapped (map (lambda (x) (list-ref x 5)) letvars))
	 (l-bind-object (map get-contents l-bind-object-wrapped))
	 (bind (lambda (ent)
		 (let ((bind-result
			(do-bind-type-vars2 binder type-vars ent cycles)))
		   (set! instantiations
			 (append instantiations (cdr bind-result)))
		   (car bind-result))))
	 (l-new-init-exprs (map* bind init-exprs))
	 (l-new-declared-types (map* bind declared-types)))
    (for-each (lambda (to-decl-type ent-init-expr s-name)
		(inst-check-let-variable binder to-decl-type ent-init-expr
					 s-name))
	      l-new-declared-types l-new-init-exprs l-s-names)
    (let* ((l-new-vars
	    (map* (lambda
		      (var-old to-old-type expr-old-init to-new-type
			       expr-new-init)
		    (inst-make-let-variable binder readonly-bindings?
					    var-old to-old-type expr-old-init
					    to-new-type expr-new-init))
		  l-old-vars declared-types init-exprs
		  l-new-declared-types l-new-init-exprs))
	   (l-new-bindings (map (lambda (bind-object? var init-expr)
				  (dwl2 bind-object?)
				  (if bind-object? init-expr var))
				l-bind-object l-new-vars l-new-init-exprs))
	   (letvars1
	    (map list names l-new-vars l-new-bindings l-new-declared-types
		 l-new-init-exprs l-bind-object-wrapped))
	   (final-letvars
	    (let ((result
		   (cond
		    ((and (not recursive?) (not order?))
		     (cons letvars1 '()))
		    ((and (not recursive?) order?)
		     (raise 'let*-not-builtin))
		    ;; letrec and letrec* are handled in a similar way.
		    (recursive?
		     (inst-make-letrec-letvars binder type-vars
					       letvars1 old-bindings
					       readonly-bindings?
					       cycles))
		    (else (raise 'internal-error)))))
	      (set! instantiations (append instantiations (cdr result)))
	      (car result))))
      (if (not (check-no-none-types? binder
		(map get-entity-type l-new-bindings)))
	  (raise 'let:type-none))
;;      (if (not (check-no-none-types?
;;		(map get-entity-type l-new-init-exprs)))
;;	  (raise 'let:initializer-none))
      (let ((s-name-none (find-none-type binder
					 (map get-entity-type l-new-init-exprs)
					 l-s-names)))
	(if (not-null? s-name-none)
	    (raise (list 'let:initializer-none
			 (cons 's-name s-name-none)))))
      (let* ((old-body (hfield-ref repr 'body))
	     (l-subst (inst-make-let-subst old-bindings l-new-bindings))
	     (new-body
	      (let* ((bindings (append l-subst type-vars))
		     (result
		      (do-bind-type-vars2 binder bindings old-body cycles)))
		(set! instantiations (append instantiations (cdr result)))
		(car result)))
	     (new-body-pure? (is-pure-entity? new-body))
	     (final-init-exprs-pure?
	      (and-map? is-pure-entity? l-new-init-exprs))
	     (let-expr-pure? (and new-body-pure? final-init-exprs-pure?))
	     (always-returns?
	      (and (entity-always-returns? new-body)
		   (and-map? entity-always-returns? l-new-init-exprs)))
	     (never-returns?
	      (or (entity-never-returns? new-body)
		  (or-map? entity-never-returns? l-new-init-exprs)))
	     (result
	      (make-hrecord <let-expression>
			    ;; The type of a let expression is the type of
			    ;; its body.
			    (get-entity-type new-body)
			    (entity-type-dispatched? new-body)
			    (hfield-ref new-body 'exact-type?)
			    '()

			    let-expr-pure?
			    #f
			    #f
			    (get-entity-value new-body)

			    always-returns?
			    never-returns?

			    readonly-bindings?
			    recursive? order?
			    final-letvars
			    new-body)))
	(cons result instantiations)))))


(define (make-new-argument-variable binder alloc name type)
  (let ((address (alloc name #f))
	(exact-type?
	 (and (not (is-t-type-variable? type))
	      (is-t-instance? binder type tc-class)
	      (not (tno-field-ref type 'inheritable?)))))
    (make-normal-variable0
     address
     type
     #t
     exact-type?
     #t
     #f
     #f
     #f
     '()
     '()
     #f
     ;; Seuraavaa voi miettiä.
     #f)))


(define (make-new-argument-variables binder alloc names types)
  (map (lambda (name type)
	 (make-new-argument-variable binder alloc name type))
       names types))


(define (inst-bind-procedure binder type-vars repr cycles)
  (assert (is-binder? binder))
  (assert (list? type-vars))
  (check-bindings type-vars)
  (assert (hrecord-is-instance? repr <procedure-expression>))  
  (let* ((instantiations '())
	 (i-counter gl-counter26)
	 (old-arg-descs (hfield-ref repr 'arg-descs))
	 (new-arg-descs
	  (map (lambda (arg-desc)
		 (let ((bind-result
			(do-bind-type-vars2 binder type-vars arg-desc
					    cycles)))
		   (set! instantiations
			 (append instantiations (cdr bind-result)))
		   (car bind-result)))
	       old-arg-descs))
	 (old-result-type (hfield-ref repr 'result-type))
	 (new-result-type
	  (let ((bind-result
		 (do-bind-type-vars2 binder type-vars old-result-type
				     cycles)))
	    (set! instantiations
		  (append instantiations (cdr bind-result)))
	    (car bind-result)))
	 (impl-arg-types
	  (get-impl-arg-types binder new-arg-descs))
	 (names (hfield-ref repr 'arg-names))
	 (alloc-var (hfield-ref binder 'allocate-variable))
	 (new-arg-vars (make-new-argument-variables
			binder alloc-var names impl-arg-types))
	 (old-arg-vars (hfield-ref repr 'arg-variables))
	 (old-body (hfield-ref repr 'body))
	 (body1
	  (if (and-map? eqv? new-arg-vars old-arg-vars)
	      old-body
	      (rebind-local-variables1-fwd
	       binder old-body
	       (map cons old-arg-vars new-arg-vars))))
	 (new-body
	  ;; Field fixing? is always #f.
	  (if (hfield-ref binder 'fixing?)
	      body1
	      (let ((result (do-bind-type-vars2 binder type-vars body1 cycles)))
		(set! instantiations (append instantiations (cdr result)))
		(car result)))))
    (if (or (not (= (length old-arg-descs) (length new-arg-descs)))
	    (not (and-map? eqv? old-arg-descs new-arg-descs))
	    (not (eqv? old-result-type new-result-type))
	    (not (eqv? old-body new-body)))
	(let* ((pure-proc? (hfield-ref repr 'pure-proc?))
	       (force-pure-proc? (hfield-ref repr 'force-pure-proc?))
	       (appl-always-returns?
		(hfield-ref repr 'appl-always-returns?))
	       (appl-never-returns?
		(hfield-ref repr 'appl-never-returns?))
	       (body-always-returns? (entity-always-returns? new-body))
	       (body-never-returns? (entity-never-returns? new-body))
	       (static-method? (hfield-ref repr 'static-method?))
	       ;; An instance of a parametrized procedure is
	       ;; a simple procedure.
	       (proc-type (translate-simple-proc-class-expression
			   binder
			   new-arg-descs new-result-type
			   pure-proc?
			   appl-always-returns? appl-never-returns?
			   static-method?))
	       (typecheck? (and
			    (hfield-ref binder 'type-check?)
			    (not (contains-type-variables-fwd? proc-type))
			    (or (null? impl-arg-types)
				(not (or-map? contains-type-variables-fwd?
					      impl-arg-types))))))
	  (cond
	   ((and 
	     typecheck?
	     pure-proc? (not force-pure-proc?)
	     (not (is-pure-entity? new-body)))
	    (raise
	     (list 'purity-mismatch
		   (cons 'expr-appl repr)
		   (cons 'l-tvars type-vars)
		   (cons 'actual-type (get-entity-type new-body))
		   (cons 'declared-type new-result-type))))
	   ((and typecheck?
		 (or appl-always-returns? appl-never-returns?)
		 (or
		  (not (eq? appl-always-returns? body-always-returns?))
		  (not (eq? appl-never-returns? body-never-returns?))))
	    (raise
	     (list 'return-attr-mismatch
		   (cons 'expr-appl repr)
		   (cons 'l-tvars type-vars))))
	   (else
	    ;; Formerly we created a new binder here.
	    (let ((body-never-returns? (entity-never-returns? new-body)))
	      (if (and typecheck?
		       (not body-never-returns?)
		       (not (check-procedure-result-type?
			     binder
			     (get-entity-type new-body)
			     new-result-type)))
		  (begin
		    (raise
		     (list 'result-type-mismatch
			   (cons 'expr-appl repr)
			   (cons 'l-tvars type-vars)
			   (cons 'actual-type (get-entity-type new-body))
			   (cons 'declared-type new-result-type))))
		  (let* ((to (make-target-object
			      proc-type #t #f '()
			      #f #f #f '()))
			 (inst?
			  (let ((expr (hfield-ref binder 'expr-cur-proc)))
			    (and (not-null? expr) (eq? repr expr))))
			 (s-kind
			  (if inst?
			      'instance
			      (hfield-ref repr 's-kind)))
			 (s-name
			  (if inst?
			      (hfield-ref binder 's-cur-toplevel)
			      (hfield-ref repr 's-name)))
			 (l-module
			  (hfield-ref repr 'l-module))
			 (result-expr
			  (make-hrecord <procedure-expression>
					proc-type
					#t
					#t
					'()
					#t
					#f
					#f
					to
					names
					new-arg-descs
					new-arg-vars
					new-result-type
					new-body
					s-kind
					s-name
					l-module
					pure-proc?
					force-pure-proc?
					appl-always-returns?
					appl-never-returns?
					static-method?)))
		    (cons result-expr instantiations)))))))
	(begin
	  (cons repr instantiations)))))
