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


;; *** Expression cloning ***


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


(define theme-target-compile-fwd '())
(define theme-target-compile-and-inst-fwd '())
(define compute-class-field-texprs-fwd '())
(define get-target-var-name-fwd '())


(define gl-debug1 '())
(define gl-debug2 '())
(define gl-linker-fwd '())
(define gl-ctr3 0)


(define (equal-let-variables? letvar1 letvar2)
  (assert (and (list? letvar1) (= (length letvar1) 6)))
  (assert (and (list? letvar2) (= (length letvar2) 6)))
  (and
   (eq? (list-ref letvar1 0) (list-ref letvar2 0))
   (eq? (list-ref letvar1 1) (list-ref letvar2 1))
   (eq? (list-ref letvar1 2) (list-ref letvar2 2))
   (eq? (list-ref letvar1 3) (list-ref letvar2 3))
   (eq? (list-ref letvar1 4) (list-ref letvar2 4))
   (eq? (list-ref letvar1 5) (list-ref letvar2 5))))


(define (contains-type-variables0? item visited)
  (let* ((new-visited (cons item visited))
	 (result
	  (cond
	   ((null? item)
	    #f)
	   ((memv item visited)
	    #f)
	   ((and (is-target-object? item)
		 (hfield-ref item 'incomplete?))
	    #f)
	   ((pair? item)
	    (or
	     (contains-type-variables0? (car item) new-visited)
	     (contains-type-variables0? (cdr item) new-visited)))
	   ;; We don't create variable references for type variables.
	   ;;	   ((hrecord-is-instance? item <variable-reference>)
	   ;;	    (dwl4 "contains-type-variables0?/4")
	   ;;	    (hrecord-is-instance? (hfield-ref item 'variable)
	   ;;				  <type-variable>))
	   ((is-t-type-variable? item)
	    #t)
	   ;; Should we return #t also in case the only type variable
	   ;; in a type loop expression is the iteration variable?
	   ((is-t-type-loop? item) #t)
	   (else
	    (let ((subexprs (get-subexpressions-fwd item)))
	      (if (null? subexprs)
		  #f
		  (or-map?
		   (lambda (subexpr)
		     (contains-type-variables0? subexpr new-visited))
		   subexprs)))))))
    result))


(define (contains-type-variables? item)
  (contains-type-variables0? item '()))


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


(define (contains-specified-tvars0? item tvars visited)
  (let ((new-visited (cons item visited)))
    (cond
     ((null? item) #f)
     ((memv item visited) #f)
     ;; We don't create variable references for type variables.
     ;;     ((hrecord-is-instance? item <variable-reference>)
     ;;    (let ((var (hfield-ref item 'variable)))
     ;;	(and
     ;;	 (hrecord-is-instance? var <type-variable>)
     ;;	 (memv var tvars))))
     ((pair? item)
      (or
       (contains-specified-tvars0? (car item) tvars new-visited)
       (contains-specified-tvars0? (cdr item) tvars new-visited)))
     ((is-t-type-variable? item)
      (if (member item tvars type-variable=?) #t #f))
     (else
      (let ((subexprs (get-subexpressions-fwd item)))
	(if (null? subexprs)
	    #f
	    (or-map? (lambda (item2) (contains-specified-tvars0? item2 tvars
								 new-visited))
		     subexprs)))))))


(define (contains-specified-tvars? item tvars)
  (contains-specified-tvars0? item tvars '()))


(set! contains-specified-tvars-fwd?
      contains-specified-tvars?)


(define (contains-free-tvars0? item tvars visited)
;;  (assert (is-entity? item))
  (assert (and (list? tvars)
	       (and-map? is-t-type-variable? tvars)))
  (let ((new-visited (cons item visited)))
    (cond
     ((null? item) #f)
     ((memv item visited) #f)
     ((list? item)
      (or-map? (lambda (item2)
		 (contains-free-tvars0? item2 tvars new-visited))
	       item))
     ;; ((hrecord-is-instance? item <variable-reference>)
     ;;  (let ((var (hfield-ref item 'variable)))
     ;; 	(and
     ;; 	 (hrecord-is-instance? var <type-variable>)
     ;; 	 (not (memv var tvars)))))
     ((is-t-type-variable? item)
      (not (member item tvars type-variable=?)))
     ((is-tc-param-proc? item)
      (let ((new-tvars (append tvars (tno-field-ref item 'l-tvars))))
	(contains-free-tvars0? (tno-field-ref item 'type-contents) new-tvars
			       new-visited)))
     (else
      (let ((subexprs (get-subexpressions-fwd item)))
	(if (null? subexprs)
	    #f
	    (or-map? (lambda (item2)
		       (contains-free-tvars0? item2 tvars new-visited))
		     subexprs)))))))


(define (contains-free-tvars? item)
  (contains-free-tvars0? item '() '()))


(set! contains-free-tvars-fwd? contains-free-tvars?)


(define (contains-free-tvars-general0? item tvars visited)
  (assert (and (list? tvars)
	       (and-map? is-t-type-variable? tvars)))
  (let ((new-visited (cons item visited)))
    (cond
     ((null? item) #f)
     ((memv item visited) #f)
     ((list? item)
      (or-map? (lambda (item2)
		 (contains-free-tvars-general0? item2 tvars new-visited))
	       item))
     ;; ((hrecord-is-instance? item <variable-reference>)
     ;;  (let ((var (hfield-ref item 'variable)))
     ;; 	(and
     ;; 	 (hrecord-is-instance? var <type-variable>)
     ;; 	 (not (memv var tvars)))))
     ((is-t-type-variable? item)
      (not (member item tvars type-variable=?)))
     ((is-tc-param-proc? item)
      (let ((new-tvars (append tvars (tno-field-ref item 'l-tvars))))
	(contains-free-tvars-general0? (tno-field-ref item 'type-contents)
				       new-tvars new-visited)))
     ((is-t-type-loop? item)
      (let ((new-tvars (append tvars (list (tno-field-ref item 'tvar)))))
	(or (contains-free-tvars-general0? (tno-field-ref item 'x-subtypes)
					   new-tvars new-visited)
	    (contains-free-tvars-general0? (tno-field-ref item 'x-iter-expr)
					   new-tvars new-visited))))
     (else
      (let ((subexprs (get-subexpressions-fwd item)))
	(if (null? subexprs)
	    #f
	    (or-map? (lambda (item2)
		       (contains-free-tvars-general0? item2 tvars
						      new-visited))
		     subexprs)))))))


(define (contains-free-tvars-general? item)
  (contains-free-tvars-general0? item '() '()))


(set! contains-free-tvars-general-fwd? contains-free-tvars-general?)


(set! contains-free-tvars-general0-fwd? contains-free-tvars-general0?)


(define (contains-only-specified-unbound-tvars0? item tvars visited)
  (let ((new-visited (cons item visited)))
    (cond
     ((null? item) #t)
     ((memv item visited) #t)
     ((pair? item)
      (or
       (contains-only-specified-unbound-tvars0? (car item) tvars new-visited)
       (contains-only-specified-unbound-tvars0? (cdr item) tvars new-visited)))
     ((is-t-type-variable? item)
      (if (member item tvars type-variable=?) #t #f))
     ;; ((hrecord-is-instance? item <variable-reference>)
     ;;  (let ((var (hfield-ref item 'variable)))
     ;; 	(if (hrecord-is-instance? var <type-variable>)
     ;; 	    (if (memv var tvars) #t #f)
     ;; 	    #t)))
     ((is-t-type-loop? item)
      (let ((new-tvars (append tvars (list (tno-field-ref item 'tvar)))))
	(and (contains-only-specified-unbound-tvars0?
	      (tno-field-ref item 'x-subtypes)
	      new-tvars new-visited)
	     (contains-only-specified-unbound-tvars0?
	      (tno-field-ref item 'x-iter-expr)
	      new-tvars new-visited))))
     (else
      (let ((subexprs (get-subexpressions-fwd item)))
	(if (null? subexprs)
	    #t
	    (and-map? (lambda (item2)
			(contains-only-specified-unbound-tvars0? item2 tvars
								 new-visited))
		      subexprs)))))))


(define (contains-only-specified-unbound-tvars? item tvars)
  (contains-only-specified-unbound-tvars0? item tvars '()))


(set! contains-only-specified-unbound-tvars-fwd? 
      contains-only-specified-unbound-tvars?)


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


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


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


(define (rebind-local-vars-let binder obj l-bindings l-visited)
  (assert (hrecord-is-instance? obj <let-expression>))
  (let* ((l-variables (apply append (hfield-ref obj 'variables)))
	 (l-new-vars0
	  (map* (lambda (repr)
		  (rebind-local-variables0 binder repr l-bindings
					   l-visited))
		l-variables))
	 (l-new-vars (get-let-variables l-new-vars0))
	 (l-old-vars (hfield-ref obj 'variables))
	 (repr-old-body (hfield-ref obj 'body))
	 (vars-changed? (not (and-map? equal-let-variables?
				       l-new-vars l-old-vars)))
	 (repr-new-body
	  (rebind-local-variables0
	   binder repr-old-body
	   (append (map cons
			(map car l-old-vars)
			(map car l-new-vars))
		   l-bindings)
	   l-visited)))
    (if (or vars-changed? (not (eqv? repr-new-body repr-old-body)))
	(let* ((init-exprs (map pick5th l-new-vars))
	       (pure-init?
		(and-map? is-pure-entity? init-exprs))
	       (pure-body? (is-pure-entity? repr-new-body))
	       (pure? (and pure-body? pure-init?))
	       (type-dispatched? (entity-type-dispatched? repr-new-body))
	       (always-returns?
		(and (entity-always-returns? repr-new-body)
		     (and-map? entity-always-returns? init-exprs)))
	       (never-returns?
		(or (entity-never-returns? repr-new-body)
		    (or-map? entity-never-returns? init-exprs))))
	  (make-hrecord <let-expression>
			(get-entity-type repr-new-body)
			type-dispatched?
			(hfield-ref repr-new-body 'exact-type?)
			'()
			pure?
			#f
			;; Maybe we should have need-revision? = #t.
			#f
			'()
			always-returns?
			never-returns?
			(hfield-ref obj 'readonly-bindings?)
			(hfield-ref obj 'recursive?)
			(hfield-ref obj 'order?)
			l-new-vars
			repr-new-body))
	obj)))


(define (rebind-local-variables00 binder obj bindings lst-visited
				  i-counter)
  (let ((result
	  (cond
	   ((null? obj) '())
	   ;;   ((is-t-type-variable? obj) obj)
	   ((null? bindings) obj)
	   ((is-null-class-entity? obj) tc-nil)
	   ;; The following code works for variable references as long as
	   ;; the binding of the variable is another variable.
	   ((is-normal-variable? obj)
	    (let ((binding
		   (assoc obj bindings
			  (lambda (ent1 ent2)
			    (and
			     (is-normal-variable? ent1)
			     (is-normal-variable? ent2)
			     (variable-addresses-equal? ent1 ent2))))))
	      (if binding
		  (cdr binding)
		  obj)))
	   ((is-t-type-variable? obj)
	    (let ((binding
		   (assoc obj bindings
			  (lambda (ent1 ent2)
			    (and
			     (is-t-type-variable? ent1)
			     (is-t-type-variable? ent2)
			     (type-variable=? ent1 ent2))))))
	      (cond
	       ((eqv? binding #f) obj)
	       ;;			((is-entity? (cdr binding)) (cdr binding))
	       ((is-entity? (cdr binding))
		(cdr binding))
	       (else
		(raise 'internal-error-while-rebinding)))))
	   ((pair? obj)
	    (let ((lst-new-visited (cons (cons obj #f) lst-visited)))
	      (let ((obj-head (rebind-local-variables0
			       binder (car obj)
			       bindings lst-new-visited))
		    (obj-tail (rebind-local-variables0
			       binder (cdr obj)
			       bindings lst-new-visited)))
		(if (and (eq? obj-head (car obj))
			 (eq? obj-tail (cdr obj)))
		    obj
		    (cons obj-head obj-tail)))))
	   ((hrecord-is-instance? obj <let-expression>)
	    (let ((lst-new-visited (cons (cons obj #f) lst-visited)))
	      (rebind-local-vars-let binder obj bindings
				     lst-new-visited)))
	   ((is-target-object? obj)
	    (let* ((sgt (make-cycle-object obj))
		   (lst-new-visited (cons (cons obj sgt) lst-visited))
		   (result1
		    (let* ((subexprs (get-subexpressions-fwd obj))
			   (translated-subexprs
			    (map* (lambda (subexpr)
				    (if (not-null? subexpr)
					(rebind-local-variables0
					 binder subexpr
					 bindings
					 lst-new-visited)
					'()))
				  subexprs))
			   (result3
			    (clone-with-branches-fwd
			     binder obj
			     translated-subexprs 
			     #f)))
		      result3)))
	      (if (eq? obj result1)
		  (begin
		    obj)
		  (begin
		    (update-cycle-object! sgt result1)
		    sgt))))
	   ((is-expression? obj)
	    (let* ((lst-new-visited (cons (cons obj #f) lst-visited))
		   (subexprs (get-subexpressions-fwd obj))
		   (translated-subexprs
		    (map* (lambda (subexpr)
			    (if (not-null? subexpr)
				(rebind-local-variables0
				 binder subexpr
				 bindings
				 lst-new-visited)
				'()))
			  subexprs)))
	      (clone-with-branches-fwd
	       binder obj
	       translated-subexprs 
	       #f)))
	   (else (raise 'rebind-local-variables00:invalid-arguments)))))
    result))


(define (rebind-local-variables0 binder obj bindings lst-visited)
  (assert (is-binder? binder))

  ;; (set! gl-counter5 (+ gl-counter5 1))
  ;; (dwli gl-counter5)
  ;; (dwi "r0 ")
  ;; (dwc gl-counter5)
  ;; (dwc " ")
  ;; (dwc gl-indent)
  ;; (dwc " ")
  ;; (if (is-target-object? obj)
  ;;     (dwc (debug-get-string obj))
  ;;     (if (hrecord? obj)
  ;; 	  (dwc (hrecord-type-name-of obj))
  ;; 	  (dwc "?")))
  ;; (dwli-newline)

  (let ((old-indent gl-indent)
	(i-counter gl-counter5))
    (set! gl-indent (+ gl-indent 1))
    (let ((result
	   (let ((a (assq obj lst-visited)))
	     (if (not (eq? a #f))
		 (if (or (pair? obj) (is-expression? obj))
		     (raise 'illegal-cycle-4)
		     (cdr a))
		 (if (and (is-entity? obj)
			  (let ((address (hfield-ref obj 'address)))
			    (and (not-null? address)
				 (= (hfield-ref address 'number)
				    address-number-builtin)))
			  (let ((type (get-entity-type obj)))
			    (or (is-tc-simple-proc? type)
				(is-tc-param-proc? type))))
		     obj
		     (rebind-local-variables00
		      binder obj bindings lst-visited i-counter))))))

      ;; (dwi "r0 exit ")
      ;; (dwc i-counter) 
      ;; (dwli-newline)
      ;; (dwi "result: ")
      ;; (if (is-target-object? result)
      ;; 	  (dwc (debug-get-string result))
      ;; 	  (if (hrecord? result)
      ;; 	      (dwc (hrecord-type-name-of result))
      ;; 	      (dwc "?")))
      ;; (dwli-newline)
      ;; (dwi "result hash: ")
      ;; (dwc (hashq result 1000000))
      ;; (dwli-newline)

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


(define (rebind-local-variables1 binder obj bindings)
  (let ((old-type-check? (hfield-ref binder 'type-check?))
	(old-preserve-types? (hfield-ref binder 'preserve-types?)))
    (hfield-set! binder 'type-check? #f)
    (hfield-set! binder 'preserve-types? #t)
    (let ((result
	   (rebind-local-variables0 binder obj bindings '())))
      (hfield-set! binder 'type-check? old-type-check?)
      (hfield-set! binder 'preserve-types? old-preserve-types?)
      result)))


(set! rebind-local-variables1-fwd rebind-local-variables1)


(define (rebind-local-variables binder obj bindings)
  (let ((old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'type-check? #t)
    (let ((result
	   (rebind-local-variables0 binder obj bindings '())))
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(set! rebind-local-variables-fwd rebind-local-variables)


(define rebind-local-variables-no-check rebind-local-variables1)


(set! rebind-local-variables-no-check-fwd rebind-local-variables-no-check)


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


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


(set! rebind-object-fwd rebind-object)


(define (rebind-type-variables00 binder obj bindings lst-visited)
  (let ((result
	  (cond
	   ((null? obj) '())
	   ;;   ((is-t-type-variable? obj) obj)
	   ((null? bindings) obj)
	   ((is-null-class-entity? obj) tc-nil)
	   ((is-t-type-variable? obj)
	    (let ((binding
		   (assoc obj bindings
			  (lambda (ent1 ent2)
			    (and
			     (is-t-type-variable? ent1)
			     (is-t-type-variable? ent2)
			     (type-variable=? ent1 ent2))))))
	      (cond
	       ((eqv? binding #f) obj)
	       ;;			((is-entity? (cdr binding)) (cdr binding))
	       ((is-entity? (cdr binding))
		(cdr binding))
	       (else
		(raise 'internal-error-while-rebinding)))))
	   ((pair? obj)
	    (let* ((lst-new-visited (cons (cons obj #f) lst-visited))
		   (obj-head (rebind-type-variables0
			      binder (car obj)
			      bindings lst-new-visited))
		   (obj-tail (rebind-type-variables0
			      binder (cdr obj)
			      bindings lst-new-visited)))
	      (if (and (eq? obj-head (car obj))
		       (eq? obj-tail (cdr obj)))
		  obj
		  (cons obj-head obj-tail))))
	   ((is-target-object? obj)
	    (let* ((sgt (make-cycle-object obj))
		   (lst-new-visited (cons (cons obj sgt) lst-visited))
		   (result1
		    (let* ((subexprs (get-subexpressions-fwd obj))
			   (translated-subexprs
			    (map* (lambda (subexpr)
				    (if (not-null? subexpr)
					(rebind-type-variables0
					 binder subexpr
					 bindings
					 lst-new-visited)
					'()))
				  subexprs))
			   (result3
			    (clone-with-branches-fwd
			     binder obj
			     translated-subexprs 
			     #f)))
		      result3)))
	      (if (eq? obj result1)
		  obj
		  (begin
		    (update-cycle-object! sgt result1)
		    sgt))))
	   ((is-entity? obj)
	    (let* ((lst-new-visited (cons (cons obj #f) lst-visited))
		   (subexprs (get-subexpressions-fwd obj))
		   (translated-subexprs
		    (map* (lambda (subexpr)
			    (if (not-null? subexpr)
				(rebind-type-variables0
				 binder subexpr
				 bindings
				 lst-new-visited)
				'()))
			  subexprs))
		   (result3
		    (clone-with-branches-fwd
		     binder obj
		     translated-subexprs 
		     #f)))
	      result3))
	   (else (raise 'rebind-type-variables00:invalid-arguments)))))
    result))


(define (rebind-type-variables0 binder obj bindings lst-visited)
  (assert (is-binder? binder))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((result
	   (let ((a (assq obj lst-visited)))
	     (if (not (eq? a #f))
		 (if (or (pair? obj) (is-expression? obj))
		     (raise 'illegal-cycle-6)
		     (cdr a))
		 (rebind-type-variables00
		  binder obj bindings lst-visited)))))
        (set! gl-indent old-indent)
      result)))


(define (rebind-type-variables-no-check binder obj bindings)
  (let ((old-type-check? (hfield-ref binder 'type-check?)))
    (hfield-set! binder 'type-check? #f)
    (let ((result (rebind-type-variables0 binder obj bindings '())))
      (hfield-set! binder 'type-check? old-type-check?)
      result)))


(set! rebind-type-variables-no-check-fwd rebind-type-variables-no-check)


(define (get-subexprs-default repr)
  '())


(define (get-subexprs-var-def repr)
  (list (hfield-ref repr 'variable)
	(hfield-ref repr 'value-expr)))


(define (get-subexprs-var-ref repr)
  (list (hfield-ref repr 'variable)))
;;  '())


(define (get-subexprs-prim-proc-ref repr)
  (list (get-entity-type repr)))


(define (get-subexprs-checked-prim-proc repr)
  (list (get-entity-type repr)))


;; Otetaan fields eikä all-fields ettei tule ongelmia kloonauksessa.


(define (get-subexprs-class-def repr)
  (let ((var (hfield-ref repr 'variable)))
    (if (hrecord-is-instance? var <normal-variable>)
	(let ((obj (hfield-ref var 'value)))
	  (if (not-null? obj)
	      (let ((fields (tno-field-ref obj 'l-fields)))
		(append
		 (list (tno-field-ref obj 'cl-superclass))
		 (list (tno-field-ref obj 'type-constructor))
 		 (map (lambda (field) (tno-field-ref field 'type)) fields)
		 (map (lambda (field) (tno-field-ref field 'x-init-value))
		      fields)))
	      (begin
		(dvar1-set! repr)
		(raise 'internal-invalid-class-1))))
	(begin
	  (dvar1-set! repr)
	  (raise 'internal-invalid-class-2)))))


(define (get-subexprs-param-class-def repr)
  (assert (hrecord-is-instance? repr <param-class-definition>))
  (let* ((var (hfield-ref repr 'variable))
	 (value (hfield-ref var 'value))
	 (result
	  (if (is-target-object? value)
	      (let ((instance-fields (tno-field-ref value 'l-instance-fields)))
		(append
		 (list (tno-field-ref value 'cl-instance-superclass))
 		 (map (lambda (field) (tno-field-ref field 'type))
		      instance-fields)
		 (map (lambda (field) (tno-field-ref field 'x-init-value))
		      instance-fields)))
	      (begin
		(dvar1-set! repr)
		(raise 'internal-invalid-class)))))
    result))


(define (get-subexprs-method-decl repr)
  (list (hfield-ref repr 'method)))


(define (get-subexprs-method-def repr)
  (list (hfield-ref repr 'procexpr)))


(define (get-subexprs-set repr)
  (list (hfield-ref repr 'variable)
	(hfield-ref repr 'value-expr)))


(define (get-subexprs-proc-appl repr)
  (list
   (hfield-ref repr 'proc)
   (hfield-ref repr 'arglist)
   (hfield-ref repr 'l-default-params)))


(define (get-subexprs-cast repr)
  (list (get-entity-type repr)
	(hfield-ref repr 'value-expr)
	(hfield-ref repr 'default-expr)))


(define (get-subexprs-static-cast repr)
  (list (get-entity-type repr)
	(hfield-ref repr 'ent-value)))


(define (get-subexprs-match-type repr)
  (let* ((expr-to-match (hfield-ref repr 'expr-to-match))
	 (lst-repr-clauses (hfield-ref repr 'lst-proper-clauses))
	 (expr-else (hfield-ref repr 'expr-else))
	 (lst-repr-clauses1
	  (map (lambda (l-clause) (take l-clause 3)) lst-repr-clauses)))
    (append
     (list expr-to-match)
     (apply append lst-repr-clauses1)
     (list expr-else))))


(define (get-subexprs-if repr)
  (if (not-null? (hfield-ref repr 'else-expr))
      (list
       (hfield-ref repr 'condition)
       (hfield-ref repr 'then-expr)
       (hfield-ref repr 'else-expr))
      (list
       (hfield-ref repr 'condition)
       (hfield-ref repr 'then-expr)
       empty-expression)))


(define (get-subexprs-until repr)
  (let ((condition (hfield-ref repr 'condition))
	(result (hfield-ref repr 'result))
	(body (hfield-ref repr 'body)))
    (list condition result body)))


(define (get-subexprs-compound repr)
  (hfield-ref repr 'subexprs))


(define (get-subexprs-let repr)
  (let ((variables (hfield-ref repr 'variables))
	(body (hfield-ref repr 'body)))
    (append
     (apply append variables)
     (list body))))


(define (get-subexprs-proc-expr repr)
  (let ((arg-descs (hfield-ref repr 'arg-descs))
	(result-type (hfield-ref repr 'result-type))
	(body (hfield-ref repr 'body))
	(pure-proc? (hfield-ref repr 'pure-proc?)))
    (append
     arg-descs
     (list result-type)
     (list body))))


(define (get-subexprs-field-ref repr)
  (list (hfield-ref repr 'object)))


(define (get-subexprs-field-set repr)
  (list
   (hfield-ref repr 'object)
   (hfield-ref repr 'field-value)))


(define (get-subexprs-constructor repr)
  (list (hfield-ref repr 'clas)))


(define (get-subexprs-zero repr)
  (list (hfield-ref repr 'clas)))


(define (get-subexprs-param-ltype-def repr)
  (list (hfield-ref repr 'value-expr)))


(define (get-subexprs-param-proc-instance repr)
  (assert (hrecord-is-instance? repr <expr-param-proc-instance>))
  (append
   ;;   (list (get-entity-type repr))
   (list (hfield-ref repr 'param-proc))
   (hfield-ref repr 'params)))


(define (get-subexprs-param-proc-dispatch repr)
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  (append
   (list (hfield-ref repr 'param-proc))
   (hfield-ref repr 'argument-types)))


(define (get-subexprs-param-proc repr)
  (assert (hrecord-is-instance? repr <param-proc-expr>))
  (list (get-entity-type repr) (hfield-ref repr 'body)))


(define (get-subexprs-generic-proc-dispatch repr)
  (assert (hrecord-is-instance? repr <generic-proc-dispatch>))
  (append
   (list (hfield-ref repr 'generic-proc))
   (hfield-ref repr 'arg-types)))


(define (get-subexprs-decl repr)
  (assert (hrecord-is-instance? repr <forward-declaration>))
  (list (get-entity-type (hfield-ref repr 'variable))))


(define (get-subexprs-signature-def repr)
  (assert (hrecord-is-instance? repr <signature-definition>))
  (let ((lst-members (hfield-ref repr 'lst-members)))
    (map cdr lst-members)))


(define (get-subexprs-param-sgn-def repr)
  (assert (hrecord-is-instance? repr <param-signature-definition>))
  (let ((lst-members (hfield-ref repr 'lst-members)))
    (map cdr lst-members)))


(define (get-subexprs-normal-variable repr)
  (assert (hrecord-is-instance? repr <normal-variable>))
  (let ((type (get-entity-type repr)))
    (if (not (target-type=? type tc-class))
	(list type)
	(list '()))))


(set! get-subexprs-normal-variable-fwd get-subexprs-normal-variable)


(define (get-subexprs-force-pure-expr repr)
  (assert (hrecord-is-instance? repr <force-pure-expr>))
  (list (hfield-ref repr 'repr-component)))


(define (get-subexprs-assertion repr)
  (assert (hrecord-is-instance? repr <assertion-expr>))
  (list (hfield-ref repr 'condition)))


(define (get-subexprs-empty repr)
  (assert (hrecord-is-instance? repr <empty-expression>))
  '())


(define (get-components-apti to)
  (let ((param-class (tno-field-ref to 'type-meta))
	(params (tno-field-ref to 'l-type-args)))
    (append (list param-class) params)))


(define (get-components-param-class-instance to)
  (let ((param-class (get-entity-type to))
	(params (tno-field-ref to 'l-tvar-values)))
    (append (list param-class) params)))


(define (get-components-signature to)
  (apply append (map (lambda (pr) (list (car pr) (cdr pr)))
		     (tno-field-ref to 'l-members))))


(define (get-components-proc-type to)
  (list (tno-field-ref to 'type-arglist)
	(tno-field-ref to 'type-result)))


(define (get-components-param-proc-class to)
  (list (tno-field-ref to 'type-contents)))


(define (get-components-gen-proc-class to)
  (tno-field-ref to 'l-method-classes))


(define (get-components-type-list to)
  (tno-field-ref to 'l-subtypes))


(define (get-components-rest to)
  (list (tno-field-ref to 'type-component)))


(define (get-components-splice to)
  (list (tno-field-ref to 'type-component)))


(define (get-components-type-loop to)
  (list (tno-field-ref to 'x-subtypes) (tno-field-ref to 'x-iter-expr)))


(define (get-components-type-join repr)
  (list (tno-field-ref repr 'l-subtypes)))


(define (get-components-field repr)
  (list (tno-field-ref repr 'type)
	(tno-field-ref repr 'x-init-value)))


(define (get-subexprs-object to)
  (cond
   ((eq? to tc-class) '())
   ((eq? (hfield-ref to 'al-field-values) #f)
    (list (get-entity-type to)))
   ((or (is-tc-pair? to)
	(is-tc-vector? to)
	(is-tc-value-vector? to)
	(is-tc-mutable-vector? to)
	(is-tc-mutable-value-vector? to))
    (tno-field-ref to 'l-tvar-values))
   ((is-tt-union? to)
    (tno-field-ref to 'l-member-types))
   ((target-type=? (get-entity-type to) tplt-uniform-list)
    (raise 'invalid-uniform-list-type))
   ((target-type=? (get-entity-type to) tc-abstract-param-type-inst)
    (get-components-apti to))
   ((is-t-param-class-instance? to)
    (get-components-param-class-instance to))
;;   ((is-t-param-signature-instance? to)
;;    (get-components-param-sgn-instance to))
   ((is-t-signature? to)
    (get-components-signature to))
   ((is-tt-procedure? to)
    (get-components-proc-type to))
   ((is-tc-simple-proc? to)
    (get-components-proc-type to))
   ((is-tc-param-proc? to)
    (get-components-param-proc-class to))
   ((is-tc-gen-proc? to)
    (get-components-gen-proc-class to))
   ((is-t-type-list? to)
    (get-components-type-list to))
   ((is-t-rest? to)
    (get-components-rest to))
   ((is-t-splice? to)
    (get-components-splice to))
   ((is-t-type-loop? to)
    (get-components-type-loop to))
   ((is-t-type-join? to)
    (get-components-type-join to))
   ((is-t-field? to)
    (get-components-field to))
   (else '())))


(define gl-get-subexprs-table
  (list
   (cons <target-object> get-subexprs-object)
   (cons <variable-definition> get-subexprs-var-def)
   (cons <variable-reference> get-subexprs-var-ref)
   (cons <prim-proc-ref> get-subexprs-prim-proc-ref)
   (cons <checked-prim-proc> get-subexprs-checked-prim-proc)
   (cons <prim-class-def> get-subexprs-default)
   (cons <class-definition> get-subexprs-class-def)
   (cons <param-class-definition> get-subexprs-param-class-def)
   (cons <set-expression> get-subexprs-set)
   (cons <proc-appl> get-subexprs-proc-appl)
   (cons <cast-expression> get-subexprs-cast)
   (cons <static-cast-expression> get-subexprs-static-cast)
   (cons <match-type-expression> get-subexprs-match-type)
   (cons <if-form> get-subexprs-if)
   (cons <until-form> get-subexprs-until)
   (cons <compound-expression> get-subexprs-compound)
   (cons <let-expression> get-subexprs-let)
   (cons <procedure-expression> get-subexprs-proc-expr)
   (cons <field-ref-expr> get-subexprs-field-ref)
   (cons <field-set-expr> get-subexprs-field-set)
   (cons <normal-variable> get-subexprs-normal-variable)
   (cons <expr-constructor> get-subexprs-constructor)
   (cons <zero-expr> get-subexprs-zero)
   ;; MIETI seuraava
   (cons <forward-declaration> get-subexprs-decl)
   (cons <generic-procedure-definition> get-subexprs-default)
   ;; MIETI seuraavat kaksi
   (cons <method-definition> get-subexprs-method-def)
   (cons <method-declaration> get-subexprs-method-decl)
   (cons <param-logical-type-def> get-subexprs-param-ltype-def)
   (cons <expr-param-proc-instance> get-subexprs-param-proc-instance)
   (cons <expr-param-proc-dispatch> get-subexprs-param-proc-dispatch)
   (cons <param-proc-expr> get-subexprs-param-proc)
   (cons <generic-proc-dispatch> get-subexprs-generic-proc-dispatch)
   (cons <signature-definition> get-subexprs-signature-def)
   (cons <param-signature-definition> get-subexprs-param-sgn-def)
   (cons <zero-setting-expr> get-subexprs-default)
   (cons <force-pure-expr> get-subexprs-force-pure-expr)
   (cons <assertion-expr> get-subexprs-assertion)
   (cons <prevent-stripping-expr> get-subexprs-default)
   (cons <expr-define-syntax> get-subexprs-default)
   (cons <debug-output-expr> get-subexprs-default)
   (cons <empty-expression> get-subexprs-empty)))


(define (get-subexpressions repr)
  (let ((proc (assv (hrecord-type-of repr) gl-get-subexprs-table)))
    (if (not (eqv? proc #f))
	((cdr proc) repr)
	(begin
	  (dvar1-set! repr)
	  (raise 'internal-subexpression-error)))))


(set! get-subexpressions-fwd get-subexpressions)


(define (cwb-var-ref binder repr subreprs type-check?)
  (assert (hrecord-is-instance? repr <variable-reference>))
  (assert (hfield-ref repr 'pure?))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-var (hfield-ref repr 'variable))
	(new-var (car subreprs)))
    ;; Do nothing for type variables.
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? old-var new-var))
	    (and (hrecord-is-instance? new-var <normal-variable>)
		 (hfield-ref new-var 'changed-in-inst?)))
	(begin
	  (make-hrecord <variable-reference>
			(get-entity-type new-var)
			(hfield-ref new-var 'type-dispatched?)
			(hfield-ref new-var 'exact-type?)
			'()
			#t
			#t
			(not type-check?)
			(hfield-ref new-var 'value)
			new-var))
	(begin
	  repr))))


;; When a variable definition or an object belonging to its subclass
;; is cloned the original variable is changed. This is OK because a
;; variable definition can occur only toplevel and it is not changed
;; in instantiation.


(define (cwb-var-def binder repr subreprs type-check?)
  ;; type-check? and need-revision? not checked here. (Why?)
  (let ((new-var (car subreprs))
	(var (hfield-ref repr 'variable))
	(new-value-expr (cadr subreprs))
	(old-value-expr (hfield-ref repr 'value-expr)))
    (let ((result
	   (if (or (not (eqv? new-value-expr old-value-expr))
		   (not (eqv? new-var var)))
	       (begin
		 (hfield-set! var 'type (get-entity-type new-var))
		 (hfield-set! var 'exact-type?
			      (hfield-ref new-var 'exact-type?))
		 (if (hfield-ref var 'read-only?)
		     (hfield-set! var 'value
				  (get-entity-value new-value-expr))
		     (hfield-set! var 'value '()))
		 (hfield-set! var 'changed-in-inst? #t)
		 (make-hrecord <variable-definition>
			       tt-none #t #t '()
			       #f
			       #f
			       (not type-check?)
;;			       (hfield-ref var 'value)
			       (hfield-ref new-var 'value)
			       var
			       (get-entity-type new-var)
			       new-value-expr
			       ;; Seuraava ei ole varma.
			       (hfield-ref repr 'declared?)
			       (hfield-ref repr 'prevent-stripping?)
			       (hfield-ref repr 'include?)))
	       repr))) 
      result)))


(define (cwb-prim-proc-ref binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-type (get-entity-type repr))
	(new-type (car subreprs)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? old-type new-type)))
	(let ((to (make-target-object
		   new-type
		   #t #f (hfield-ref repr 'address)
		   #f #f #f '())))
	  (make-hrecord <prim-proc-ref>
			new-type
			#t
			#f
			(hfield-ref repr 'address)
			#t
			#f
			(not type-check?)
			to))
	repr)))


(define (cwb-checked-prim-proc binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <checked-prim-proc>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-type (get-entity-type repr))
	(new-type (car subreprs)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? old-type new-type)))
	(let ((to (make-target-object
		   new-type #t #f '()
		   #f #f #f '())))
	  (make-hrecord <checked-prim-proc>
			new-type
			#t
			#f
			(hfield-ref repr 'address)
			#t
			#f
			(not type-check?)
			to))
	repr)))


(define (clone-field-list old-fields
			  new-field-types new-field-init-values)
  (assert (list? old-fields))
  (assert (list? new-field-types))
  (assert (list? new-field-init-values))
  (let ((len1 (length old-fields))
	(len2 (length new-field-types))
	(len3 (length new-field-init-values)))
    (assert (= len1 len2))
    (assert (= len2 len3)))
  (map (lambda (field new-type new-init-value)
	 (let ((name (tno-field-ref field 's-name))
	       (read-access (tno-field-ref field 's-read-access))
	       (write-access (tno-field-ref field 's-write-access))
	       (has-init-value? (tno-field-ref field 'has-init-value?)))
	   (make-field name new-type read-access write-access
		       has-init-value? new-init-value)))
       old-fields new-field-types new-field-init-values))


(define (cwb-class-def binder repr subreprs type-check?)
  ;; We skip the constructor type here.
  (let ((new-superclass (car subreprs))
	(fields (cddr subreprs)))
    (assert (list? fields))
    (let* ((len (length fields))
	   (half-len (/ len 2)))
      (assert (= half-len (round half-len)))
      (let ((field-types (take fields half-len))
	    (field-init-values (take-right fields half-len)))
	(let* ((var (hfield-ref repr 'variable))
	       (obj (hfield-ref var 'value))
	       (old-superclass (tno-field-ref obj 'cl-superclass))
	       (old-fields (tno-field-ref obj 'l-fields))
	       (old-field-types
		(map (lambda (field) (tno-field-ref field 'type))
		     old-fields))
	       (old-field-init-values
		(map (lambda (field) (tno-field-ref field 'x-init-value))
		     old-fields)))
	  (if (or (and type-check? (hfield-ref repr 'need-revision?))
		  (not (eqv? new-superclass old-superclass))
		  (not (= (length field-types) (length old-field-types)))
		  (not (and-map? eqv? field-types old-field-types))
		  (not (= (length field-init-values)
			  (length old-field-init-values)))
		  (not (and-map? eqv? field-init-values
				 old-field-init-values)))
	      (let* ((inh? (tno-field-ref obj 'inheritable?))
		     (imm? (tno-field-ref obj 'immutable?))
		     (ebv? (tno-field-ref obj 'eq-by-value?))
		     (ctr-access (tno-field-ref obj 's-ctr-access))
		     (name (tno-field-ref obj 'str-name))
		     (module (tno-field-ref obj 'module))
		     (new-field-list (clone-field-list
				      old-fields field-types field-init-values))
		     (address (hfield-ref obj 'address))
		     ;; The following statement has been corrected.
		     (obj2 (make-target-class address module new-superclass
					      new-field-list
					      inh? imm? ebv?
					      ctr-access))
		     (var (hfield-ref repr 'variable)))
		(make-constructor! binder obj2)
		(hfield-set! var 'value obj2)
		(hfield-set! var 'changed-in-inst? #t)
		(make-hrecord <class-definition>
			      tt-none #t #t '()
			      #f #f
			      (not type-check?)
			      '()
			      var tc-class '()
			      (hfield-ref repr 'declared?)
			      (hfield-ref repr 'prevent-stripping?)
			      (hfield-ref repr 'include?)))
	      (begin
		repr)))))))


(define (cwb-param-ltype-def binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <param-logical-type-def>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((new-value-repr (car subreprs))
	(old-value-repr (hfield-ref repr 'value-expr)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? old-value-repr new-value-repr)))
	(let ((var (hfield-ref repr 'variable)))
	  (strong-assert (not-null? (hfield-ref var 'value)))
	  (hfield-set! var 'type (get-entity-type new-value-repr))
	  (hfield-set! var 'exact-type?
		       (hfield-ref new-value-repr 'exact-type?))
	  (hfield-set! var 'value-expr new-value-repr)
	  (tno-field-set! (hfield-ref var 'value) 'x-value-expr new-value-repr)
	  (hfield-set! var 'changed-in-inst? #t)
	  (make-hrecord <param-logical-type-def>
			tt-none
			#t
			#t
			'()
			#f
			#f
			(not type-check?)
			'()
			var
			tc-logical-type
			new-value-repr
			(hfield-ref repr 'declared?)
			(hfield-ref repr 'prevent-stripping?)
			(hfield-ref repr 'include?)
			(hfield-ref repr 'type-variables)))
	repr)))


(define (cwb-param-class-def binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <param-class-definition>))
  (let ((new-superclass (car subreprs))
	(fields (cdr subreprs)))
    (assert (list? fields))
    (let* ((len (length fields))
	   (half-len (/ len 2)))
      (assert (= half-len (round half-len)))
      (let ((field-types (take fields half-len))
	    (field-init-values (take-right fields half-len)))
	(let* ((var (hfield-ref repr 'variable))
	       (obj (hfield-ref var 'value))
	       (old-superclass (tno-field-ref obj 'cl-instance-superclass))
	       (old-fields (tno-field-ref obj 'l-instance-fields))
	       (old-field-types
		(map (lambda (field) (tno-field-ref field 'type))
		     old-fields))
	       (old-field-init-values
		(map (lambda (field) (tno-field-ref field 'x-init-value))
		     old-fields)))
	  (if (or (and type-check? (hfield-ref repr 'need-revision?))
		  (not (eqv? new-superclass old-superclass))
		  (not (= (length field-types) (length old-field-types)))
		  (not (and-map? eqv? field-types old-field-types))
		  (not (= (length field-init-values)
			  (length old-field-init-values)))
		  (not (and-map? eqv? field-init-values
				 old-field-init-values)))
	      (let* ((inh? (tno-field-ref obj 'instances-inheritable?))
		     (imm? (tno-field-ref obj 'instances-immutable?))
		     (ebv? (tno-field-ref obj 'instances-eq-by-value?))
		     (ctr-access (tno-field-ref obj 's-instance-ctr-access))
		     (name (tno-field-ref obj 'str-name))
		     (module (tno-field-ref obj 'module))
		     (type-variables (tno-field-ref obj 'l-tvars))
		     (new-field-list (clone-field-list
				      old-fields field-types field-init-values))
		     (address (hfield-ref obj 'address))
		     (obj2 (make-parametrized-class-object
			    binder
			    module
			    name
			    address
			    type-variables
			    new-superclass
			    new-field-list
			    inh? imm? ebv?
			    ctr-access))
		     (var (hfield-ref repr 'variable)))
		;; Note: We are changing the old variable here
		;; instead of creating a new one.
		(hfield-set! var 'value obj2)
		(hfield-set! var 'changed-in-inst? #t)
		(make-hrecord <param-class-definition>
			      tt-none #t #t '()
			      #f #f
			      (not type-check?)
			      '()
			      var t-param-class '()
			      (hfield-ref repr 'declared?)
			      (hfield-ref repr 'prevent-stripping?)
			      (hfield-ref repr 'include?)
			      (hfield-ref repr 'type-variables)))
	      (begin
		repr)))))))


;;(define (cwb-param-ltype-instance binder repr subreprs type-check?)
;;  (do-cwb-param-type-instance binder repr subreprs #f type-check?))


(define (cwb-param-proc-instance binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <expr-param-proc-instance>))
  (assert (list? subreprs))
  (let ((old-param-proc (hfield-ref repr 'param-proc))
	(old-params (hfield-ref repr 'params))
	(new-param-proc (car subreprs))
	(new-params (cdr subreprs)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (and 
		  (eqv? old-param-proc new-param-proc)
		  (= (length old-params) (length new-params))
		  (and-map? eqv? old-params new-params))))
	(translate-param-proc-instance
	 binder new-param-proc new-params
	 (or type-check?
	     (hfield-ref binder 'preserve-types?)))
	repr)))


(define (cwb-param-proc-dispatch binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  (assert (list? subreprs))
  (let ((old-param-proc (hfield-ref repr 'param-proc))
	(old-argument-types (hfield-ref repr 'argument-types))
	(new-param-proc (car subreprs))
	(new-argument-types (cdr subreprs)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (and 
		  (eqv? old-param-proc new-param-proc)
		  (= (length old-argument-types) (length new-argument-types)))))
	(translate-param-proc-dispatch
	 binder new-param-proc
	 new-argument-types
	 (or type-check?
	     (hfield-ref binder 'preserve-types?)))
	repr)))


(define (cwb-param-proc binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <param-proc-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 2)))
  (let ((new-type (car subreprs))
	(new-body (cadr subreprs)))
    (let ((result
	   (if (or (and type-check? (hfield-ref repr 'need-revision?))
		   (not (eqv? (get-entity-type repr) new-type))
		   (not (eqv? (hfield-ref repr 'body) new-body)))
	       (make-param-proc 
		(hfield-ref repr 's-kind)
		(hfield-ref repr 's-name)
		(hfield-ref repr 'l-module)
		(hfield-ref repr 'type-variables)
		new-type
		new-body)
	       repr)))
      result)))


(define (cwb-generic-proc-dispatch binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <generic-proc-dispatch>))
  (assert (list? subreprs))
  (let ((old-generic-proc (hfield-ref repr 'generic-proc))
	(old-arg-types (hfield-ref repr 'arg-types))
	(new-generic-proc (car subreprs))
	(new-arg-types (cdr subreprs)))
    (dwl2 (hfield-ref (hfield-ref old-generic-proc 'address) 'source-name))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (and 
		  (eqv? old-generic-proc new-generic-proc)
		  (= (length old-arg-types) (length new-arg-types))
		  (and-map? eqv? old-arg-types new-arg-types))))
	(translate-generic-proc-dispatch binder
					 new-generic-proc
					 new-arg-types
					 (hfield-ref repr 'with-result?)
					 (hfield-ref repr 'appl-pure?)
					 (hfield-ref repr 'appl-always-returns?)
					 (hfield-ref repr 'appl-never-returns?)
					 type-check?)
	repr)))


(define (cwb-method-decl binder repr subreprs type-check?)
  (dvar1-set! repr)
  (dvar2-set! subreprs)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <method-declaration>))
  (assert (list? subreprs))
  (let ((new-method (car subreprs))
	(old-method (hfield-ref repr 'method)))
    (if (eqv? new-method old-method)
	repr
	(let ((gen-proc (hfield-ref repr 'gen-proc))
	      (static? (hfield-ref repr 'static-method?)))
	  (get-method-declaration-repr gen-proc new-method static?)))))


(define (cwb-method-def binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <method-definition>))
  (assert (list? subreprs))
  (let ((new-procexpr (car subreprs))
	(old-procexpr (hfield-ref repr 'procexpr)))
    (if (eqv? new-procexpr old-procexpr)
	repr
	(let ((gen-proc (hfield-ref repr 'gen-proc))
	      (declared? (hfield-ref repr 'declared?))
	      (old-address (hfield-ref repr 'old-address))
	      (static? (hfield-ref repr 'static-method?)))
	  (get-method-definition-repr gen-proc new-procexpr static?
				      declared? old-address)))))


(define (cwb-procedure-expression binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (assert (list? subreprs))
  (let* ((old-arg-descs (hfield-ref repr 'arg-descs))
	 (old-body (hfield-ref repr 'body))
	 (old-result-type (hfield-ref repr 'result-type))
	 (new-arg-descs (drop-right subreprs 2))
	 (new-result-type (car (take-right subreprs 2)))
	 (new-body (car (take-right subreprs 1))))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (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* ((param-cache (hfield-ref binder 'param-cache))
	       (arg-list-desc (construct-toplevel-type-repr
			       binder new-arg-descs))
	       (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-bindings (make-argument-bindings binder alloc-var
						     names impl-arg-types))
	       (new-arguments (map cdr new-bindings))
	       (old-arguments (hfield-ref repr 'arg-variables))
	       (arg-rebind (map cons old-arguments new-arguments))
	       (final-body (rebind-local-variables1
			    binder new-body arg-rebind))
	       (s-kind (hfield-ref repr 's-kind))
	       (s-name (hfield-ref repr 's-name))
	       (l-module (hfield-ref repr 'l-module))
	       (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-pure? (is-pure-entity? final-body))
	       (body-always-returns?
		(entity-always-returns? final-body))
	       (body-never-returns?
		(entity-never-returns? final-body))
	       (static-method? (hfield-ref repr 'static-method?))
	       (proc-type (translate-simple-proc-class-expression
			   binder
			   new-arg-descs new-result-type
			   pure-proc?
			   appl-always-returns? appl-never-returns?
			   static-method?)))
	  (if (and type-check?
		   (not (proc-attr-inherit?
			 body-pure? body-always-returns? body-never-returns?
			 static-method?
			 pure-proc? appl-always-returns? appl-never-returns?
			 static-method?)))
	      (begin
		(dvar1-set! repr)
		(dvar2-set! final-body)
		(dvar3-set! type-check?)
		(raise 'procedure-attribute-mismatch))
	      (if (and type-check?
		       (not body-never-returns?)
		       (not (check-procedure-result-type?
			     binder
			     (get-entity-type final-body)
			     new-result-type)))
		  (begin (dvar1-set! final-body)
			 (dvar2-set! old-result-type)
			 (dvar3-set! new-result-type)
			 (dvar4-set! repr)
			 (raise 'result-type-mismatch-2))
		  (begin
		    (let ((to (make-target-object
			       proc-type
			       #t #f '() #f #f
			       #f '())))
		      (make-hrecord <procedure-expression>
				    proc-type
				    #t
				    #t
				    '()
				    #t
				    #t
				    ;; MIETI seuraava
				    (not type-check?)
				    to
				    names
				    new-arg-descs
				    new-arguments
				    new-result-type
				    final-body
				    s-kind
				    s-name
				    l-module
				    pure-proc?
				    force-pure-proc?
				    appl-always-returns?
				    appl-never-returns?
				    static-method?))))))
	(begin repr))))


(define (cwb-compound-expression binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <compound-expression>))
  ;; Should we allow empty subreprs?
  (assert (and (list? subreprs) (>= (length subreprs) 1)))
  (let ((new-subreprs subreprs)
	(old-subreprs (hfield-ref repr 'subexprs)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (= (length new-subreprs) (length old-subreprs)))
	    (not (and-map? eqv? new-subreprs old-subreprs)))
	(let* ((last-repr (car (take-right new-subreprs 1)))
	       (type (get-entity-type last-repr))
	       (pure? (and-map? is-pure-entity? new-subreprs))
	       (always-returns? (and-map? entity-always-returns? new-subreprs))
	       (never-returns? (or-map? entity-never-returns? new-subreprs)))
	  (make-hrecord <compound-expression>
			type
			#t
			(hfield-ref last-repr 'exact-type?)
			'()
			pure?
			#f
			(not type-check?)
			'()
			always-returns?
			never-returns?
			new-subreprs))
	repr)))


(define (cwb-if binder repr subreprs type-check?)
  (assert (hrecord-is-instance? binder <binder>))
  (assert (hrecord-is-instance? repr <if-form>))
  (assert (and (list? subreprs) (= (length subreprs) 3)))
  (let ((new-condition (car subreprs))
	(new-then-expr (cadr subreprs))
	(new-else-expr (caddr subreprs))
	(old-condition (hfield-ref repr 'condition))
	(old-then-expr (hfield-ref repr 'then-expr))
	(old-else-expr (hfield-ref repr 'else-expr))
	(boolean-cond? (hfield-ref repr 'boolean-cond?)))
    (dvar1-set! new-condition)
    (dvar2-set! old-condition)
    (dvar3-set! new-then-expr)
    (dvar4-set! old-then-expr)
    (strong-assert (or (not type-check?)
		       (not boolean-cond?)
		       (target-type=?
			(get-entity-type new-condition)
			tc-boolean)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? new-condition old-condition))
	    (not (eqv? new-then-expr old-then-expr))
	    (not (eqv? new-else-expr old-else-expr)))
	(translate-if-expression binder
				 new-condition new-then-expr new-else-expr
				 boolean-cond?
				 type-check?)
	(begin
	  repr))))


(define (cwb-until binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <until-form>))
  (assert (and (list? subreprs) (= (length subreprs) 3)))
  (let ((new-condition (car subreprs))
	(new-result (cadr subreprs))
	(new-body (caddr subreprs))
	(old-condition (hfield-ref repr 'condition))
	(old-result (hfield-ref repr 'result))
	(old-body (hfield-ref repr 'body)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? new-condition old-condition))
	    (not (eqv? new-result old-result))
	    (not (eqv? new-body old-body)))
	(let ((type-dispatched? (and-map? entity-type-dispatched? subreprs))
	      (always-returns?
	       (and-map? entity-always-returns? subreprs))
	      (never-returns?
	       (or
		(entity-never-returns? new-condition)
		(entity-never-returns? new-result)))
	      (pure?
	       (and (is-pure-entity? new-condition)
		    (is-pure-entity? new-result)
		    (is-pure-entity? new-body))))
	  (make-hrecord <until-form>
			(get-entity-type new-result)
			type-dispatched?
			(hfield-ref new-result 'exact-type?)
			'()
			pure?
			#f
			(not type-check?)
			'()
			always-returns?
			never-returns?
			new-condition
			new-result
			new-body))
	repr)))


(define (cwb-set binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <set-expression>))
  (assert (and (list? subreprs) (= (length subreprs) 2)))
  (let ((new-variable (car subreprs))
	(new-value-expr (cadr subreprs))
	(old-variable (hfield-ref repr 'variable))
	(old-value-expr (hfield-ref repr 'value-expr)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? new-variable old-variable))
	    (not (eqv? new-value-expr old-value-expr)))
	(if (entity-type-is-none1? binder new-value-expr)
	    (raise 'set-expression-with-type-none)
	    (make-hrecord <set-expression>
			  tt-none
			  #t
			  #t
			  '()
			  #t
			  #f
			  (not type-check?)
			  '()
			  (entity-always-returns? new-value-expr)
			  (entity-never-returns? new-value-expr)
			  new-variable
			  new-value-expr))
	repr)))


(define (get-let-variables subreprs)
  (let ((i-letvar-length 6))
    (cond
     ((null? subreprs) '())
     ((>= (length subreprs) i-letvar-length)
      (append
       (list (take subreprs i-letvar-length))
       (get-let-variables (drop subreprs i-letvar-length))))
     (else
      (raise 'internal-invalid-let-variable)))))


(define (check-let-var-type? binder let-var)
  (assert (is-binder? binder))
  (assert (not-null? (caddr let-var)))
  (let* ((ent-binding (caddr let-var))
	 (tt-actual (get-entity-type ent-bindind))
	 (tt-declared (cadddr let-var)))
    (and
     (not (entity-is-none1? binder tt-actual))
     (or (null? tt-declared) (not (entity-is-none1? binder tt-declared)))
     ;; (or (contains-free-tvars? t1)
     ;; 	 (contains-free-tvars? t2)
     ;; 	 (is-t-subtype? binder r-t1 r-t2)))))
     (or
      (null? tt-declared)
      (not (entity-type-dispatched? tt-actual))
      (not (entity-type-dispatched? tt-declared))
      (is-t-subtype? binder tt-actual tt-declared)))))


(define (check-let-var-types? binder let-vars)
  (assert (is-binder? binder))
  (and-map? (lambda (let-var) (check-let-var-type? binder let-var))
	    let-vars))


(define (cwb-let binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <let-expression>))
  (assert (and (list? subreprs) (>= (length subreprs) 1)))
  (let ((old-variables (hfield-ref repr 'variables))
	(old-body (hfield-ref repr 'body))
	(new-variables (get-let-variables (drop-right subreprs 1)))
	(new-body (car (take-right subreprs 1))))
    ;; It is an error if the lengths of old-variables and new-variables
    ;; are different.
    (let* ((variables-changed?
	    (not (and-map? equal-let-variables? new-variables old-variables)))
	   (final-body
	    (if variables-changed?
		(begin
		  (rebind-local-variables1
		   binder new-body
		   (map cons
			(map caddr old-variables)
			(map caddr new-variables))))
		new-body)))
      (if (or (and type-check? (hfield-ref repr 'need-revision?))
	      (not (= (length new-variables) (length old-variables)))
	      variables-changed?
	      (not (eqv? final-body old-body)))
	  (if (or (not type-check?)
		  ;;		  (or-map? contains-free-tvars? (map car new-variables))
		  ;;		  (or-map? contains-free-tvars? (map cdr new-variables))
		  ;;		  (contains-free-tvars? final-body)
		  (check-let-var-types? binder new-variables))
	      (begin
		(let* ((init-exprs (map pick5th new-variables))
		       (pure-init?
			(and-map? is-pure-entity? init-exprs))
		       (pure-body? (is-pure-entity? final-body))
		       (pure? (and pure-body? pure-init?))
		       (always-returns?
			(and (entity-always-returns? final-body)
			     (and-map? entity-always-returns? init-exprs)))
		       (never-returns?
			(or (entity-never-returns? final-body)
			    (or-map? entity-never-returns? init-exprs))))
		  (make-hrecord <let-expression>
				(get-entity-type final-body)
				(entity-type-dispatched? final-body)
				(hfield-ref final-body 'exact-type?)
				'()
				pure?
				#f
				(not type-check?)
				'()
				always-returns?
				never-returns?
				(hfield-ref repr 'readonly-bindings?)
				(hfield-ref repr 'recursive?)
				(hfield-ref repr 'order?)
				new-variables
				final-body)))
	      (begin
		(dvar1-set! repr)
		(dvar2-set! new-variables)
		(dvar3-set! new-body)
		(dvar4-set! binder)
		(raise 'let-variable-type-mismatch)))
	  (begin
	    repr)))))


(define (cwb-cast binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <cast-expression>))
  (assert (and (list? subreprs) (= (length subreprs) 3)))
  (let* ((old-type (get-entity-type repr))
	 (old-value-expr (hfield-ref repr 'value-expr))
	 (old-default-expr (hfield-ref repr 'default-expr))
	 (new-type0 (car subreprs))
	 (new-type (construct-argument-type-repr binder new-type0))
	 (new-value-expr (cadr subreprs))
	 (new-default-expr (caddr subreprs)))
    (let ((result
;;	   (if (is-t-subtype? binder (get-entity-type new-value-expr)
;;			      new-type)
;;	       new-value-expr
	       (if (or (and type-check? (hfield-ref repr 'need-revision?))
		       (not (target-type=? new-type old-type))
		       (not (eqv? new-value-expr old-value-expr))
		       (not (eqv? new-default-expr old-default-expr)))
		   (begin
		     (assert (not (entity-is-none1? binder new-type)))
		     (assert (not (entity-type-is-none1? binder
							 new-value-expr)))
		     (make-hrecord <cast-expression>
				   new-type
				   #t
				   (is-final-class? binder new-type)
				   '()
				   (is-pure-entity? new-value-expr)
				   #f
				   (not type-check?)
				   '()
				   (entity-always-returns? new-value-expr)
				   (entity-never-returns? new-value-expr)
				   new-value-expr
				   new-default-expr))
		   repr)))
      result)))


(define (cwb-static-cast binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <static-cast-expression>))
  (assert (and (list? subreprs) (= (length subreprs) 2)))
  (let* ((tt-old (get-entity-type repr))
	 (ent-old-value (hfield-ref repr 'ent-value))
	 (tt-new0 (car subreprs))
	 (tt-new (construct-argument-type-repr binder tt-new0))
	 (ent-new-value (cadr subreprs))
	 (changed?
	  (or (not (eq? tt-old tt-new))
	      (not (eq? ent-old-value ent-new-value)))))
    (cond
     ((and type-check?
	   (or (hfield-ref repr 'need-revision?)
	       changed?)
	   ;; A nonreturning expression may be casted statically to any type.
	   (not (entity-never-returns? ent-new-value))
	   (not (is-t-instance? binder ent-new-value tt-new)))
      ;; Not sure if the type arguments work if the types are not
      ;; known objects.
      (raise (list 'static-cast-type-mismatch
		   (cons 'tt-actual (get-entity-type ent-new-value))
		   (cons 'tt-declared tt-new))))
     (changed?
      (make-hrecord <static-cast-expression>
		    tt-new
		    #t
		    (and
		     (is-known-object? tt-new)
		     (is-final-class? binder tt-new))
		    '()
		    (is-pure-entity? ent-new-value)
		    #f
		    (not type-check?)
		    '()
		    (entity-always-returns? ent-new-value)
		    (entity-never-returns? ent-new-value)
		    ent-new-value))
     (else repr))))


(define (make-match-type-clauses-from-list subreprs)
  (if (null? subreprs)
      '()
      (if (< (length subreprs) 3)
	  (raise 'internal-invalid-match-type-clauses)
	  (append
	   (list (take subreprs 3))
	   (make-match-type-clauses-from-list (drop subreprs 3))))))


(define (eqv-triplets? tp1 tp2)
  (assert (and (list? tp1) (= (length tp1) 3)))
  (assert (and (list? tp2) (= (length tp2) 3)))
  (and
   (eqv? (car tp1) (car tp2))
   (eqv? (cadr tp1) (cadr tp2))
   (eqv? (caddr tp1) (caddr tp2))))


(define (cwb-match-type binder repr subreprs type-check?)
  (assert (or (null? binder) (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <match-type-expression>))
  (assert (list? subreprs))
  (assert (boolean? type-check?))
  (assert (>= (length subreprs) 2))
  (let ((expr-to-match-new (car subreprs))
	(lst-repr-clauses-new (make-match-type-clauses-from-list
			       (drop-right (cdr subreprs) 1)))
	(expr-else-new (last subreprs))
	(expr-to-match-old (hfield-ref repr 'expr-to-match))
	(lst-repr-clauses-old
	 (map (lambda (l-clause) (take l-clause 3))
	      (hfield-ref repr 'lst-proper-clauses)))
	(expr-else-old (hfield-ref repr 'expr-else)))
    (let ((x-result
	   (if (or (and type-check? (hfield-ref repr 'need-revision?))
		   (not (eqv? expr-to-match-new expr-to-match-old))
		   (not (and-map? eqv-triplets?
				  lst-repr-clauses-new
				  lst-repr-clauses-old))
		   (not (eqv? expr-else-new expr-else-old)))
	       (let ((lst-repr-clauses-new1
		      (map (lambda (l-clause) (append l-clause (list #f)))
			   lst-repr-clauses-new)))
		 (if (or type-check? (not (hfield-ref binder 'preserve-types?)))
		     (translate-match-type-expr binder
						(hfield-ref repr 'strong?)
						expr-to-match-new
						lst-repr-clauses-new1
						expr-else-new
						type-check?)
		     (rebind-match-type-expr
		      binder repr
		      expr-to-match-new
		      lst-repr-clauses-new1
		      expr-else-new)))
	       repr)))
      x-result)))


;; The following procedure handles all but parametrized procedure
;; applications.
(define (do-cwb-proc-appl binder repr subreprs type-check? proctype)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (and (list? subreprs) (>= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (assert (memv proctype (list 'general 'simple 'generic)))
  (let* ((new-proc (car subreprs))
	 (new-arg-list (cadr subreprs))
	 (old-proc (hfield-ref repr 'proc))
	 (old-arg-list (hfield-ref repr 'arglist)))
    (let ((result
	   (if (or (and type-check? (hfield-ref repr 'need-revision?))
		   (not (eqv? new-proc old-proc))
		   (not (= (length new-arg-list) (length old-arg-list)))
		   (not (and-map? eqv? new-arg-list old-arg-list)))
	       (if (memv proctype (list 'general 'simple))
		   ;; (let ((inside-param-def?
		   ;; 	  (or (contains-free-tvars-general? new-proc)
		   ;; 	      (contains-free-tvars-general? new-arg-list))))
		   (let ((inside-param-def?
			  (hfield-ref binder 'inside-param-proc?)))
		     (do-translate-simple-proc-appl
		      new-proc new-arg-list
		      #f
		      binder
		      type-check?
		      inside-param-def?
		      (hfield-ref repr 'runtime-arglist-typecheck?)))
		   (cond
		    (type-check?
		     (translate-general-genproc-appl
		      binder
		      new-proc new-arg-list
		      #t))
		    ((hfield-ref binder 'preserve-types?)
		     (clone-gen-proc-appl binder repr new-arg-list))
		    (else
		     (make-general-gen-proc-appl binder new-proc new-arg-list
						 tc-object #f #f #f #f #f))))
	       repr)))
      result)))


(define (cwb-param-proc-appl binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (and (hrecord-is-instance? repr <proc-appl>)
	       (proc-appl-is-param? binder repr)))
  (assert (and (list? subreprs) (>= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let* ((new-proc (car subreprs))
	 (new-arg-list (cadr subreprs))
	 (new-default-params (caddr subreprs))
	 (old-proc (hfield-ref repr 'proc))
	 (old-arg-list (hfield-ref repr 'arglist))
	 (old-default-params (hfield-ref repr 'l-default-params)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? new-proc old-proc))
	    (not (= (length new-arg-list) (length old-arg-list)))
	    (not (and-map? eqv? new-arg-list old-arg-list))
	    (not (= (length new-default-params) (length old-default-params)))
	    (not (and-map? eqv? new-default-params old-default-params)))
	(let* ((ppc (get-entity-type new-proc))
	       (inst-type (tno-field-ref ppc 'type-contents))
	       (type-dispatched?
		(and
		 (entity-type-dispatched? new-proc)
		 (and-map? entity-type-dispatched? new-arg-list)))
	       (always-returns?
		(and
		 (tno-field-ref inst-type 'appl-always-returns?)
		 (entity-always-returns? new-proc)
		 (and-map? entity-always-returns? new-arg-list)))
	       (never-returns?
		(or
		 (tno-field-ref inst-type 'appl-never-returns?)
		 (entity-never-returns? new-proc)
		 (or-map? entity-never-returns? new-arg-list)))
	       (pure-proc? (tno-field-ref inst-type 'pure-proc?))
	       (pure-args? (and-map? is-pure-entity? new-arg-list))
	       (pure? (and pure-proc? pure-args?))
	       (runtime-arglist-typecheck?
		(hfield-ref repr 'runtime-arglist-typecheck?))
	       (static-arg-types
		(if (and runtime-arglist-typecheck?
			 (null? (hfield-ref repr 'static-arg-types)))
		    '()
		    (map get-expr-type new-arg-list)))
	       (result
		(cond
		 ((not type-dispatched?)
		  (make-hrecord <proc-appl>
				tc-object
				#f
				#f
				'()
				pure?
				(hfield-ref repr 'static?)
				(not type-check?)
				'()
				always-returns?
				never-returns?
				new-proc
				new-arg-list
				'()
				static-arg-types
				runtime-arglist-typecheck?
				new-default-params))
		 ((not type-check?)
		  (make-hrecord <proc-appl>
				(get-entity-type repr)
				#t
				(hfield-ref repr 'exact-type?)
				'()
				(hfield-ref repr 'pure?)
				(hfield-ref repr 'static?)
				(not type-check?)
				'()
				always-returns?
				never-returns?
				new-proc
				new-arg-list
				'()
				static-arg-types
				runtime-arglist-typecheck?
				new-default-params))
		 (else
		  (let ((result-type
			 (check-param-proc-type binder new-proc new-arg-list
						new-default-params)))
		    (make-hrecord <proc-appl>
				  result-type
				  #t
				  #f
				  '()
				  pure?
				  (hfield-ref repr 'static?)
				  (not type-check?)
				  '()
				  always-returns?
				  never-returns?
				  new-proc
				  new-arg-list
				  '()
				  static-arg-types
				  runtime-arglist-typecheck?
				  new-default-params))))))
	  result)
	(begin
	    repr))))


(set! cwb-param-proc-appl-fwd cwb-param-proc-appl)


(define (cwb-proc-appl binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (and (list? subreprs) (>= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let* ((proc (hfield-ref repr 'proc))
	 (type (get-entity-type proc))
	 (result
	  (cond
	   ((is-t-instance? binder type tmt-procedure)
	    (do-cwb-proc-appl binder repr subreprs type-check? 'general))
	   ((is-t-instance? binder type tpc-simple-proc)
	    (do-cwb-proc-appl binder repr subreprs type-check? 'simple))
	   ((is-t-instance? binder type tmc-gen-proc)
	    (do-cwb-proc-appl binder repr subreprs type-check? 'generic))
	   ((is-t-instance? binder type tpc-param-proc)
	    (cwb-param-proc-appl binder repr subreprs type-check?))
	   (else
	    (raise 'internal-error-with-procedure-type)))))
    result))


(define (cwb-constructor binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <expr-constructor>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((new-class (car subreprs))
	(old-class (hfield-ref repr 'clas)))
    (if (and
	 (or type-check? (hfield-ref binder 'preserve-types?))
	 (not (is-t-type-variable? new-class))
	 (not (is-t-apti? new-class))) 
	(begin
	  (strong-assert (is-t-instance? binder new-class tc-class))
	  ;; Is the following test correct?
	  (if (and (is-t-type-variable? old-class)
		   (not (eq? (tno-field-ref new-class 's-ctr-access)
			     'public)))
	      (raise 'tvar-constructor-access-violation))
	  (if (or (hfield-ref repr 'need-revision?)
		  (not (eqv? new-class old-class)))
	      (if (is-t-instance? binder new-class tpc-pair)
		  (begin
		    ;; We can assume that a constructor of a pair
		    ;; always returns.
		    (let ((type (translate-simple-proc-class-expression
				 binder
				 (tno-field-ref new-class 'l-tvar-values)
				 new-class #t #t #f #f)))
		      (make-hrecord <expr-constructor>
				    type
				    #t
				    #t
				    '()

				    #t
				    ;; MIETI seuraava
				    #t
				    (not type-check?)
				    '()

				    new-class)))
		  (begin
		    (make-hrecord <expr-constructor>
				  (get-constructor-type binder new-class)
				  #t
				  #t
				  '()

				  #t
				  ;; MIETI seuraava
				  #t
				  (not type-check?)
				  '()

				  new-class)))
	      repr))
	(if (not (eqv? new-class old-class))
	    (make-hrecord <expr-constructor>
			  tt-general-proc-with-value
			  #t
			  #t
			  '()

			  #t
			  #t
			  #t
			  '()

			  new-class)
	    repr))))


(define (cwb-zero binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <zero-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let ((new-class (car subreprs)))
    (if (not (target-type=? new-class (hfield-ref repr 'clas)))
	(if (or (not type-check?)
		(is-t-type-variable? new-class)
		(is-t-instance? binder new-class tc-class))
	    (let ((zero-expr
		   (make-hrecord <zero-expr>
				 new-class
				 #t
				 #t
				 '()

				 #t
				 #t
				 #f
				 '()

				 new-class)))
	      zero-expr)
	    (raise 'zero:not-a-class))
	repr)))


(define (cwb-field-ref binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <field-ref-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-object (hfield-ref repr 'object))
	(new-object (car subreprs))
	(field-name (hfield-ref repr 'field-name)))
    (if (or (and type-check? (hfield-ref repr 'need-revision?))
	    (not (eqv? old-object new-object)))
	(translate-const-field-ref-fwd
	 binder new-object field-name)
	repr)))


(define (cwb-field-set binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <field-set-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 2)))
  (let* ((old-object (hfield-ref repr 'object))
	 (old-field-value (hfield-ref repr 'field-value))
	 (new-object (car subreprs))
	 (new-field-value (cadr subreprs))
	 (field-name (hfield-ref repr 'field-name))
	 (result
	  (if (or (and type-check? (hfield-ref repr 'need-revision?))
		  (not (eqv? old-object new-object))
		  (not (eqv? old-field-value new-field-value)))
	      (translate-const-field-set-fwd
	       binder
	       new-object field-name
	       new-field-value
	       type-check?
	       (hfield-ref binder 'inside-param-proc?))
	      repr)))
    result))


(define (parse-signature-members subreprs)
  (cond
   ((null? subreprs) '())
   ((>= (length subreprs) 2)
    (cons (take subreprs 2) (parse-signature-members (drop subreprs 2))))
   (else (raise 'internal-error-cloning-sig-def))))


(define (cwb-signature-def binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <signature-definition>))
  (assert (list? subreprs))
  (let ((lst-old-types (map cdr (hfield-ref repr 'lst-members))))
    (if (not (and-map? eqv? subreprs lst-old-types))
	(let* ((lst-vars (map car (hfield-ref repr 'lst-members)))
	       (lst-new-members
		(map cons lst-vars subreprs))
	       ;; Should we allocate a new address?
	       (address (hfield-ref (hfield-ref repr 'variable) 'address))
	       (to (make-signature-object address lst-new-members))
	       (var (make-signature-var address to)))
	  (make-hrecord
	   <signature-definition>
	   tt-none
	   #t
	   #t
	   '()
	   #f
	   #f
	   #f
	   '()
	   var
	   tc-signature
	   '()
	   (hfield-ref repr 'declared?)
	   #f
	   #f
	   lst-new-members))
	repr)))


(define (cwb-param-sgn-def binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <param-signature-definition>))
  (assert (list? subreprs))
  (let ((lst-old-types (map cdr (hfield-ref repr 'lst-members))))
    (if (not (and-map? eqv? subreprs lst-old-types))
	(let* ((lst-vars (map car (hfield-ref repr 'lst-members)))
	       (lst-new-members
		(map cons lst-vars subreprs))
	       (r-type-vars (hfield-ref repr 'r-type-vars))
	       ;; Should we allocate a new address?
	       (address (hfield-ref (hfield-ref repr 'variable) 'address))
	       (to (make-param-sgn-object address r-type-vars lst-new-members))
	       (var (make-object-var to)))
	  (make-hrecord
	   <param-signature-definition>
	   tt-none
	   #t
	   #t
	   '()
	   #f
	   #f
	   #f
	   '()
	   var
	   t-param-signature
	   '()
	   (hfield-ref repr 'declared?)
	   #f
	   #f
	   r-type-vars
	   lst-new-members))
	repr)))


(define (cwb-assertion binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <assertion-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let ((r-old-condition (hfield-ref repr 'condition))
	(r-new-condition (car subreprs)))
    (cond
     ((eqv? r-new-condition r-old-condition)
      repr)
     ((or (not type-check?)
	  (hrecord=? (get-entity-type r-new-condition)
		     tc-boolean))
      (make-hrecord <assertion-expr>
		    tt-none
		    #t
		    #t
		    '()
		    #t
		    #f
		    #f
		    '()
		    #f
		    #f
		    r-new-condition
		    (hfield-ref repr 'condition-source-expr)
		    (hfield-ref repr 'strong?)))
     (else (raise 'assert:type-mismatch)))))


(define (cwb-decl binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <forward-declaration>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let* ((var (hfield-ref repr 'variable))
	 (type-old (get-entity-type var))
	 (type-new (car subreprs)))
    (if (not (eqv? type-old type-new))
	(let* ((address (hfield-ref var 'address))
	       (read-only? (hfield-ref var 'read-only?))
	       (exact-type? (is-final-class? binder type-new))
	       (to (make-incomplete-object type-new exact-type?))
	       (new-var (make-normal-variable
			 address type-new exact-type? read-only?
			 #t to #f)))
	  (make-hrecord <forward-declaration>
			tt-none #t #t '()
			#f #f #f '()
			new-var type-new
			(hfield-ref repr 'redecl?)
			(hfield-ref repr 'include?)))
	repr)))

	       
(define (cwb-force-pure-expr binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <force-pure-expr>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (assert (boolean? type-check?))
  (let ((repr-new-component (car subreprs))
	(repr-old-component (hfield-ref repr 'repr-component)))
    (if (eqv? repr-new-component repr-old-component)
	repr
	(translate-force-pure-expr repr-new-component))))


;; We could use cwb-default.
(define (cwb-empty binder repr subreprs type-check?)
  repr)


(define (cwb-location binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (hrecord-is-instance? repr <normal-variable>))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let* ((new-type
	  (if (not-null? (car subreprs))
	      (car subreprs)
	      (get-entity-type repr)))
	 (old-type (get-entity-type repr)))
    (if (not (target-type=? new-type old-type))
	(let ((new-var
	       (make-normal-variable6
		(hfield-ref repr 'address)
		new-type
		(hfield-ref repr 'type-dispatched?)
		#f
		(hfield-ref repr 'read-only?)
		(hfield-ref repr 'volatile?)
		(hfield-ref repr 'forward-decl?)
		'()
;;		(hfield-ref repr 'value)
		(hfield-ref repr 'value-expr))))
	  new-var)
	(begin
	  repr))))


(set! cwb-location-fwd cwb-location)


(define (cwb-default binder repr subreprs type-check?)
  repr)


(define (cowb-unknown-object binder to subreprs)
  (assert (= (length subreprs) 1))
  (let ((type-old (get-entity-type to))
	(type-new (car subreprs)))
    (if (not (eq? type-old type-new))
	(make-target-object 
	 type-new
	 #t
	 (is-final-class? binder type-new)
	 (hfield-ref to 'address)
	 #f
	 #f
	 #f
	 '())
	to)))


(define (cowb-pair-class binder to subreprs type-check?)
  (let ((old-tvar-values (tno-field-ref to 'l-tvar-values)))
    (let ((result
	   ;; Not sure if the first condition is needed.
	   (if (or (and type-check? (not (hfield-ref to 'type-dispatched?)))
		   (not (and-map? eqv? subreprs old-tvar-values)))
	       (translate-pair-class-expression binder subreprs)
	       to)))
      result)))


(define (cowb-union binder to subreprs type-check?)
  (let ((old-member-types (tno-field-ref to 'l-member-types)))
    (let ((result
	   ;; Not sure if the first condition is needed.
	   (if (or (and type-check? (not (hfield-ref to 'type-dispatched?)))
		   (not (and-map? eqv? subreprs old-member-types)))
	       ;; We must not overwrite the singleton object in procedure
	       ;; do-bind-type-vars00 with a class. Otherwise we would have
	       ;; to different (by eq?) objects representing the same class.
	       (let ((to-type (get-union-of-types binder subreprs)))
		 (if (is-tt-union? to-type)
		     to-type
		     (make-union-expression0 (list to-type))))
	       to)))
      result)))


(define (cowb-uniform-list binder to subreprs type-check?)
  (raise 'invalid-uniform-list))


(define (cowb-param-proc-class binder to subreprs type-check?)
  (assert (= (length subreprs) 1))
  (let ((new-inst-type (car subreprs))
	(old-inst-type (tno-field-ref to 'type-contents)))
    (if (not (eqv? new-inst-type old-inst-type))
	(let ((name (tno-field-ref to 'str-name))
	      (type-vars (tno-field-ref to 'l-tvars)))
	  (make-param-proc-class-object name type-vars new-inst-type))
	to)))


(define (cowb-gen-proc-class binder to subreprs type-check?)
  (let ((lst-mtc-new subreprs)
	(lst-mtc-old (tno-field-ref to 'l-method-classes)))
    (if (or (not (= (length lst-mtc-new) (length lst-mtc-old)))
	    (not (and-map? eqv? lst-mtc-new lst-mtc-old)))
	(make-gen-proc-class-object lst-mtc-new)
	to)))


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


(define (cowb-type-list binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (is-t-type-list? repr))
  (assert (and (list? subreprs)
	       (and-map? is-target-object? subreprs)))
  (assert (boolean? type-check?))
  (let ((r-old-subreprs (tno-field-ref repr 'l-subtypes)))
    (if (and (= (length subreprs) (length r-old-subreprs))
	     (and-map? eqv? subreprs r-old-subreprs))
	repr
	(construct-toplevel-type-repr binder subreprs))))


(define (cowb-rest binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (is-t-rest? repr))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-component-type (tno-field-ref repr 'type-component))
	(new-component-type (car subreprs)))
    (if (not (eqv? old-component-type new-component-type))
	(make-rest-object new-component-type)
	repr)))


(define (cowb-splice binder repr subreprs type-check?)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (is-t-splice? repr))
  (assert (and (list? subreprs) (= (length subreprs) 1)))
  (let ((old-component-type (tno-field-ref repr 'type-component))
	(new-component-type (car subreprs)))
    (if (not (eqv? old-component-type new-component-type))
	(make-splice-object new-component-type)
	repr)))


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


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


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


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


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


(define (cowb-signature binder repr subreprs)
  (assert (or (null? binder)
	      (hrecord-is-instance? binder <binder>)))
  (assert (is-t-signature? repr))
  (assert (list? subreprs))
  (let ((l-members-new (make-sgn-members-from-list-repr subreprs))
	(l-members-old (tno-field-ref repr 'l-members)))
    (if (not (and-map? (lambda (pr1 pr2)
			 (and (eq? (car pr1) (car pr2))
			      (equal-reprs1? binder (cdr pr1) (cdr pr2))))
		       l-members-new l-members-old))
	(begin
	  (make-signature-object (hfield-ref repr 'address) l-members-new))
	repr)))


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


(define (cwb-target-object binder repr subreprs type-check?)
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((result
	   (if (null? subreprs)
	       repr
	       (cond
		((eq? (hfield-ref repr 'al-field-values) #f)
		 (cowb-unknown-object binder repr subreprs))		
		((is-t-apti? repr)
		 (cowb-apti binder repr subreprs type-check?)) 
		((is-tc-pair? repr)
		 (cowb-pair-class binder repr subreprs type-check?))
		((is-tt-union? repr)
		 (cowb-union binder repr subreprs type-check?))
		((is-tt-procedure? repr)
		 (cowb-procedure-type binder repr subreprs type-check? #f))
		((is-tc-simple-proc? repr)
		 (cowb-procedure-type binder repr subreprs type-check? #t))
		((is-tc-param-proc? repr)
		 (cowb-param-proc-class binder repr subreprs type-check?))
		((is-tc-gen-proc? repr)
		 (cowb-gen-proc-class binder repr subreprs type-check?))
		((is-tc-vector? repr)
		 (translate-vector-expression0 (car subreprs)))
		((is-tc-mutable-vector? repr)
		 (translate-mutable-vector-expression0 (car subreprs)))
		((is-tc-value-vector? repr)
		 (translate-value-vector-expression0 (car subreprs)))
		((is-tc-mutable-value-vector? repr)
		 (translate-mutable-value-vector-expression0 (car subreprs)))
		((is-t-type-list? repr)
		 (cowb-type-list binder repr subreprs type-check?))
		((is-t-rest? repr)
		 (cowb-rest binder repr subreprs type-check?))
		((is-t-splice? repr)
		 (cowb-splice binder repr subreprs type-check?))
		((is-t-type-loop? repr)
		 (cowb-type-loop binder repr subreprs type-check?))
		((is-t-type-join? repr)
		 (cowb-type-join binder repr subreprs type-check?))
		((is-t-param-class-instance? repr)
		 (cowb-param-class-instance binder repr subreprs))
		;; ((is-t-param-signature-instance? repr)
		;;  (cowb-param-sgn-instance binder repr subreprs))
		((is-t-signature? repr)
		 (cowb-signature binder repr subreprs))
		((is-t-param-ltype-inst? repr)
		 ;; We should not arrive here.
		 (raise 'internal-error-with-param-logical-types))
		((is-t-field? repr)
		 (cowb-field binder repr subreprs))
		(else
		 (dvar1-set! repr)
		 (dvar2-set! subreprs)
		 (raise 'unknown-parametrized-type-2))))))
      (set! gl-indent old-indent)
      result)))


(define gl-clone-with-branches-table
  (list
   (cons <target-object> cwb-target-object)
   (cons <variable-reference> cwb-var-ref)
   (cons <variable-definition> cwb-var-def)
   (cons <prim-proc-ref> cwb-prim-proc-ref)
   (cons <checked-prim-proc> cwb-checked-prim-proc)
   (cons <prim-class-def> cwb-default)
   ;;   (cons <class-definition> cwb-class-def)
   (cons <class-definition> cwb-default)
   ;;   (cons <param-class-definition> cwb-param-class-def)
   (cons <param-class-definition> cwb-default)
   (cons <param-logical-type-def> cwb-param-ltype-def)
   (cons <expr-param-proc-instance> cwb-param-proc-instance)
   (cons <expr-param-proc-dispatch> cwb-param-proc-dispatch)
   (cons <param-proc-expr> cwb-param-proc)
   (cons <generic-proc-dispatch> cwb-generic-proc-dispatch)
   (cons <method-declaration> cwb-method-decl)
   (cons <method-definition> cwb-method-def)
   (cons <procedure-expression> cwb-procedure-expression)
   (cons <compound-expression> cwb-compound-expression)
   (cons <if-form> cwb-if)
   (cons <until-form> cwb-until)
   (cons <set-expression> cwb-set)
   (cons <let-expression> cwb-let)
   (cons <cast-expression> cwb-cast)
   (cons <static-cast-expression> cwb-static-cast)
   (cons <match-type-expression> cwb-match-type)
   (cons <proc-appl> cwb-proc-appl)
   (cons <expr-constructor> cwb-constructor)
   (cons <zero-expr> cwb-zero)
   (cons <field-ref-expr> cwb-field-ref)
   (cons <field-set-expr> cwb-field-set)
   (cons <signature-definition> cwb-signature-def)
   (cons <param-signature-definition> cwb-param-sgn-def)
   (cons <zero-setting-expr> cwb-default)
   (cons <forward-declaration> cwb-decl)
   (cons <assertion-expr> cwb-assertion)
   (cons <prevent-stripping-expr> cwb-default)
   (cons <generic-procedure-definition> cwb-default)
   (cons <force-pure-expr> cwb-force-pure-expr)
   (cons <expr-define-syntax> cwb-default)
   (cons <debug-output-expr> cwb-default)
   (cons <empty-expression> cwb-empty)
   (cons <normal-variable> cwb-location)))


(define (clone-with-branches binder repr subreprs type-check?)
  (let ((result
	 (let ((proc (assv (hrecord-type-of repr)
			   gl-clone-with-branches-table)))
	   (if (not (eqv? proc #f))
	       (begin
		 (dvar1-set! proc)
		 ((cdr proc) binder repr subreprs type-check?))
	       (begin
		 (write-error-info (hrecord-type-name-of repr))
		 (raise 'unknown-expression-type))))))
    result))


(set! clone-with-branches-fwd clone-with-branches)


(define (handle-union repr lst-visited)
  (if (is-tt-union? repr)
      (if (memq repr lst-visited)
	  repr
	  (let ((member-types (tno-field-ref repr 'l-member-types)))
	    (if (= (length member-types) 1)
		(handle-union (car member-types) (cons repr lst-visited))
		repr)))
      repr))


(define (equal-entities? binder rebindings1 rebindings2 repr1 repr2 visited)
  (cond
   ((not (hrecord-type=? (hrecord-type-of repr1) (hrecord-type-of repr2)))
    #f)
   ((hrecord-is-instance? repr1 <variable-reference>)
    (let ((var1 (hfield-ref repr1 'variable))
	  (var2 (hfield-ref repr2 'variable)))
      (equal-reprs0? binder rebindings1 rebindings2 var1 var2
		     visited)))
   ((and (is-normal-variable? repr1) (is-normal-variable? repr2))
    (variable-addresses-equal? repr1 repr2))
   ((and (is-t-type-variable? repr1) (is-t-type-variable? repr2))
    (let ((reb1 (assoc repr1 rebindings1 type-variable=?))
	  (reb2 (assoc repr2 rebindings2 type-variable=?)))
      (if (and (pair? reb1) (pair? reb2))
	  (= (cdr reb1) (cdr reb2))
	  (type-variable=? repr1 repr2))))
   ((is-expression? repr1)
    (let ((subreprs1 (get-subexpressions repr1))
	  (subreprs2 (get-subexpressions repr2)))
      (and (= (length subreprs1) (length subreprs2))
	   (and-map?
	    (lambda (r1 r2)
	      (equal-reprs0? binder
			     rebindings1 rebindings2 r1 r2
			     visited))
	    subreprs1 subreprs2))))
   ((is-target-object? repr1)
    (cond
     ;; No need to use get-entity-type here.
     ((not (equal-reprs0? binder
			  rebindings1
			  rebindings2
			  (hfield-ref repr1 'type)
			  (hfield-ref repr2 'type)
			  visited))
      #f)
     ((and (is-t-apti? repr1) (is-t-apti? repr2))
      (and
       (equal-reprs0? binder
		      rebindings1
		      rebindings2
		      (tno-field-ref repr1 'type-meta)
		      (tno-field-ref repr2 'type-meta)
		      visited)
       (equal-reprs0? binder
		      rebindings1
		      rebindings2
		      (tno-field-ref repr1 'l-type-args)
		      (tno-field-ref repr2 'l-type-args)
		      visited)))
     ((and (target-type=? (hfield-ref repr1 'type) tc-splice)
	   (target-type=? (hfield-ref repr2 'type) tc-splice))
      (equal-reprs0? binder rebindings1 rebindings2
		     (tno-field-ref repr1 'type-component)
		     (tno-field-ref repr2 'type-component)
		     visited))
     ((and (target-type=? (hfield-ref repr1 'type) tc-rest)
	   (target-type=? (hfield-ref repr2 'type) tc-rest))
      (equal-reprs0? binder rebindings1 rebindings2
		     (tno-field-ref repr1 'type-component)
		     (tno-field-ref repr2 'type-component)
		     visited))
     ((and (target-type=? (hfield-ref repr1 'type) tc-type-list)
	   (target-type=? (hfield-ref repr2 'type) tc-type-list))
      (let ((subtypes1 (tno-field-ref repr1 'l-subtypes))
	    (subtypes2 (tno-field-ref repr2 'l-subtypes)))
	(and
	 (= (length subtypes1) (length subtypes2))
	 (and-map?
	  (lambda (r1 r2)
	    (equal-reprs0? binder
			   rebindings1 rebindings2 r1 r2
			   visited))
	  subtypes1 subtypes2))))
     ((and (target-type=? (hfield-ref repr1 'type) tc-type-join)
	   (target-type=? (hfield-ref repr2 'type) tc-type-join))
      (let ((subtypes1 (tno-field-ref repr1 'l-subtypes))
	    (subtypes2 (tno-field-ref repr2 'l-subtypes)))
	(and
	 (= (length subtypes1) (length subtypes2))
	 (and-map?
	  (lambda (r1 r2)
	    (equal-reprs0? binder rebindings1 rebindings2 r1 r2
			   visited))
	  subtypes1 subtypes2))))
     ((and (target-type=? (hfield-ref repr1 'type) tc-type-loop)
	   (target-type=? (hfield-ref repr2 'type) tc-type-loop))
      (let ((subtypes1 (tno-field-ref repr1 'x-subtypes))
	    (iter-expr1 (tno-field-ref repr1 'x-iter-expr))
	    (subtypes2 (tno-field-ref repr2 'x-subtypes))
	    (iter-expr2 (tno-field-ref repr2 'x-iter-expr)))
	(and
	 (equal-reprs0? binder rebindings1 rebindings2
			iter-expr1 iter-expr2
			visited)
	 (or
	  (and (list? subtypes1) (list? subtypes2)
	       (= (length subtypes1) (length subtypes2))
	       (and-map?
		(lambda (r1 r2)
		  (equal-reprs0? binder
				 rebindings1 rebindings2 r1 r2
				 visited))
		subtypes1 subtypes2))
	  (and (is-t-type-variable? subtypes1)
	       (is-t-type-variable? subtypes2)
	       (equal-reprs0? binder
			      rebindings1 rebindings2
			      subtypes1 subtypes2
			      visited))))))
     ((and (is-tt-union? repr1) (is-tt-union? repr2))
      (let ((tvars1 (tno-field-ref repr1 'l-member-types))
	    (tvars2 (tno-field-ref repr2 'l-member-types)))
	(and (= (length tvars1) (length tvars2))
	     (and-map?
	      (lambda (t1 t2)
		(equal-reprs0? binder rebindings1 rebindings2
			       t1 t2 visited))
	      tvars1 tvars2))))
     ((and (is-tc-pair? repr1) (is-tc-pair? repr2))
      (let ((tvars1 (tno-field-ref repr1 'l-tvar-values))
	    (tvars2 (tno-field-ref repr2 'l-tvar-values)))
	(assert (= (length tvars1) 2))
	(assert (= (length tvars2) 2))
	(and
	 (equal-reprs0? binder rebindings1 rebindings2
			(car tvars1) (car tvars2)
			visited)
	 (equal-reprs0? binder rebindings1 rebindings2
			(cadr tvars1) (cadr tvars2)
			visited))))
     ((and (is-t-param-class-instance? repr1)
	   (is-t-param-class-instance? repr2))
      (let ((tvars1 (tno-field-ref repr1 'l-param-exprs))
	    (tvars2 (tno-field-ref repr2 'l-param-exprs)))
	(and (= (length tvars1) (length tvars2))
	     (and-map?
	      (lambda (t1 t2)
		(equal-reprs0? binder rebindings1 rebindings2
			       t1 t2 visited))
	      tvars1 tvars2))))
     ((and (target-type=? (hfield-ref repr1 'type) tc-class)
	   (target-type=? (hfield-ref repr2 'type) tc-class))
      (eq? repr1 repr2))
     ((and (is-t-param-ltype-inst? repr1)
	   (is-t-param-ltype-inst? repr2))
      (if (equal-reprs0? binder rebindings1 rebindings2
			 (tno-field-ref repr1 'type-meta)
			 (tno-field-ref repr2 'type-meta)
			 visited)
	  (let ((tvars1 (tno-field-ref repr1 'l-tvar-values))
		(tvars2 (tno-field-ref repr2 'l-tvar-values)))
	    (and (= (length tvars1) (length tvars2))
		 (and-map?
		  (lambda (t1 t2)
		    (equal-reprs0? binder rebindings1 rebindings2
				   t1 t2 visited))
		  tvars1 tvars2)))))
     ((and (is-tc-param-proc? repr1)
	   (is-tc-param-proc? repr2))
      (equal-reprs0? binder rebindings1 rebindings2
		     (tno-field-ref repr1 'type-contents)
		     (tno-field-ref repr2 'type-contents)
		     visited))
     ((and (is-t-general-proc-type? repr1)
	   (is-t-general-proc-type? repr2))
      (let ((simple1? (is-tc-simple-proc? repr1))
	    (simple2? (is-tc-simple-proc? repr2)))
	(if (eq? simple1? simple2?)
	    (let ((argl1 (tno-field-ref repr1 'type-arglist))
		  (argl2 (tno-field-ref repr2 'type-arglist))
		  (res1 (tno-field-ref repr1 'type-result))
		  (res2 (tno-field-ref repr2 'type-result))
		  (pure1? (tno-field-ref repr1 'pure-proc?))
		  (pure2? (tno-field-ref repr2 'pure-proc?))
		  (always-returns1? (tno-field-ref repr1
						   'appl-always-returns?))
		  (always-returns2? (tno-field-ref repr2
						   'appl-always-returns?))
		  (never-returns1? (tno-field-ref repr1
						  'appl-never-returns?))
		  (never-returns2? (tno-field-ref repr2
						  'appl-never-returns?)))
	      (and
	       (eq? pure1? pure2?)
	       (eq? always-returns1? always-returns2?)
	       (eq? never-returns1? never-returns2?)
	       (equal-reprs0? binder
			      rebindings1 rebindings2
			      argl1 argl2
			      visited)
	       (equal-reprs0? binder
			      rebindings1 rebindings2
			      res1 res2
			      visited)))
	    #f)))
     ((and (is-t-signature? repr1)
	   (is-t-signature? repr2))
      (equal-reprs0?
       binder
       rebindings1 rebindings2
       (tno-field-ref repr1 'l-members)
       (tno-field-ref repr2 'l-members)
       visited))
     (else
      #f)))
   (else #f)))


;; We should take care of bound variables here.
(define (equal-reprs0? binder rebindings1 rebindings2 repr10 repr20 visited)
  (assert (is-binder? binder))
  (assert (list? rebindings1))
  (assert (list? rebindings2))
  (assert (or
	   (null? repr10)
	   (pair? repr10)
	   (is-expression? repr10)
	   (is-target-object? repr10)
	   (is-variable? repr10)))
  (assert (or
	   (null? repr20)
	   (pair? repr20)
	   (is-expression? repr20)
	   (is-target-object? repr20)
	   (is-variable? repr20)))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let* ((repr1 (handle-union repr10 '()))
	   (repr2 (handle-union repr20 '()))
	   (result
	    (cond
	     ((null? repr1) (null? repr2))
	     ;; Here we know that repr1 is not null.
	     ((null? repr2) #f)
	     ((is-null-class-entity? repr1)
	      (is-null-class-entity? repr2))
	     ;; Here we know that repr1 is not <null>.
	     ((is-null-class-entity? repr2) #f)   
	     ((eqv? repr1 repr2) #t)
	     ;; ((or (not (hrecord? repr1)) (not (hrecord? repr2)))
	     ;;  #f)
	     ;; ((not (hrecord-type=? (hrecord-type-of repr1) (hrecord-type-of repr2)))
	     ;;  #f)
	     ((member (cons repr1 repr2) visited equal-pairs?)
	      #t)
	     ((or (eq? repr1 tc-class) (eq? repr2 tc-class))
	      (eq? repr1 repr2))
	     (else
	      (let ((new-visited (cons (cons repr1 repr2) visited)))
		(cond
		 ((and (pair? repr1) (pair? repr2))
		  (and
		   (equal-reprs0? binder rebindings1 rebindings2
				  (car repr1) (car repr2)
				  new-visited)
		   (equal-reprs0? binder rebindings1 rebindings2
				  (cdr repr1) (cdr repr2)
				  new-visited)))
		 ((or (pair? repr1) (pair? repr2))
		  #f)
		 ((hrecord-is-instance? repr1 <entity>)
		  (if (hrecord-is-instance? repr2 <entity>)
		      (equal-entities? binder
				       rebindings1 rebindings2
				       repr1 repr2
				       new-visited)
		      #f))
		 (else #f)))))))
      (set! gl-indent old-indent)
      result)))


(set! equal-reprs0-fwd? equal-reprs0?)


(define (equal-reprs? binder repr1 repr2)
  (let* ((tvars1 (get-all-tvars repr1))
	 (tvar-count (length tvars1))
	 (tvars2 (get-all-tvars repr2))
	 (result
	  (if (= (length tvars2) tvar-count)
	      (let* ((marks (get-integer-sequence 0 tvar-count))
		     (rebindings1 (map cons tvars1 marks))
		     (rebindings2 (map cons tvars2 marks)))
		(equal-reprs0? binder rebindings1 rebindings2 repr1 repr2 '()))
	      #f)))
    result))


(set! equal-reprs-fwd? equal-reprs?)


(define (equal-reprs1? binder repr1 repr2)
  (let* ((tvars1 (get-bound-tvars repr1))
	 (tvar-count (length tvars1))
	 (tvars2 (get-bound-tvars repr2))
	 (result
	  (if (= (length tvars2) tvar-count)
	      (let* ((marks (get-integer-sequence 0 tvar-count))
		     (rebindings1 (map cons tvars1 marks))
		     (rebindings2 (map cons tvars2 marks)))
		(equal-reprs0? binder rebindings1 rebindings2 repr1 repr2 '()))
	      #f)))
    result))


(set! equal-reprs1-fwd? equal-reprs1?)


(define (equal-reprs2? binder repr1 repr2 tvar1 tvar2)
  (assert (is-t-type-variable? tvar1))
  (assert (is-t-type-variable? tvar2))
  (let* ((tvars1 (get-bound-tvars repr1))
	 (tvar-count (length tvars1))
	 (tvars2 (get-bound-tvars repr2))
	 (result
	  (if (= (length tvars2) tvar-count)
	      (let* ((marks (get-integer-sequence 1 tvar-count))
		     (rebindings1 (cons (cons tvar1 0)
					(map cons tvars1 marks)))
		     (rebindings2 (cons (cons tvar2 0)
					(map cons tvars2 marks))))
		(equal-reprs0? binder rebindings1 rebindings2 repr1 repr2 '()))
	      #f)))
    result))


(set! equal-reprs2-fwd? equal-reprs2?)
