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


;; *** Tree-IL target compilation ***


(import (th-scheme-utilities stdutils))


(define tc-tree-il-object-fwd '())
(define theme-target-tree-il-compile-fwd '())


(define (tree-il-get-call-keyword linker)
  (case (hfield-ref linker 's-intermediate-language)
    ((tree-il-3.0) 'call)
    ((tree-il-2.2) 'call)
    ((tree-il-2.0) 'apply)
    (else (raise '(tree-il-get-call-keyword:internal-error)))))


(define (tree-il-get-seq-keyword linker)
  (case (hfield-ref linker 's-intermediate-language)
    ((tree-il-3.0) 'seq)
    ((tree-il-2.2) 'seq)
    ((tree-il-2.0) 'begin)
    (else (raise '(tree-il-get-seq-keyword:internal-error)))))


(define (tc-tree-il-2.0-compile-sequence l-target-exprs)
  (cons 'begin l-target-exprs))


(define (tc-tree-il-2.2-compile-sequence l-target-exprs)
  (cond
   ((null? l-target-exprs) '(void))
   ((= (length l-target-exprs) 1) (car l-target-exprs))
   (else
    (list 'seq
	  (car l-target-exprs)
	  (tc-tree-il-2.2-compile-sequence (cdr l-target-exprs))))))


(define tc-tree-il-3.0-compile-sequence
  tc-tree-il-2.2-compile-sequence)


(define (tc-tree-il-compile-sequence linker l-target-exprs)
  (case (hfield-ref linker 's-intermediate-language)
    ((tree-il-3.0) (tc-tree-il-3.0-compile-sequence l-target-exprs))
    ((tree-il-2.2) (tc-tree-il-2.2-compile-sequence l-target-exprs))
    ((tree-il-2.0) (tc-tree-il-2.0-compile-sequence l-target-exprs))
    (else (raise '(tree-il-compile-sequence:internal-error)))))


(define (get-lambda-attr s-name)
  (cond
   ((null? s-name) '())
   ((symbol? s-name) `((name . ,s-name)))
   (else (raise 'internal-error))))

  
(define (make-instance-test linker t-obj expr-type)
  (assert (is-entity? expr-type))
  (cond
   ((eq? expr-type tc-object)
    '(const #t))
   ((eq? expr-type tt-none)
    '(const #f))
   ((not (is-known-object? expr-type))
    (let ((s-call (tree-il-get-call-keyword linker))
	  (t-expr-type (theme-target-tree-il-compile-fwd linker expr-type)))
      `(,s-call (toplevel is-instance?)
		,t-obj ,t-expr-type)))
   ((and (is-tc-pair? expr-type)
	 (eq? (tt-car expr-type) tc-object)
	 (eq? (tt-cdr expr-type) tc-object))
    (let ((s-call (tree-il-get-call-keyword linker)))
      `(,s-call (toplevel pair?) ,t-obj)))
   (else
    (let ((p-prim (assq expr-type gl-l-prim-pred))
	  (s-call (tree-il-get-call-keyword linker)))
      (if p-prim
	  `(,s-call (toplevel ,(cdr p-prim))
		    ,t-obj)
	  (let ((t-expr-type
		 (theme-target-tree-il-compile-fwd linker expr-type)))
	    (cond
	     ((and (is-t-param-class-instance? expr-type)
		   (not (is-tc-pair? expr-type)))
	      `(,s-call (toplevel is-instance-of-class?)
			,t-obj ,t-expr-type))
	     ((is-t-simple-class? expr-type)
	      ;; We know that the expression type is not an instance
	      ;; of a parametrized class here.
	      `(,s-call (toplevel is-instance-of-simple-class?)
			,t-obj ,t-expr-type))
	     (else 
	      `(,s-call (toplevel is-instance?)
			,t-obj ,t-expr-type)))))))))


(define (make-subtype-test linker ent-type1 ent-type2)
  (assert (is-entity? ent-type1))
  (assert (is-entity? ent-type2))
  (let ((sx-type1
	 (theme-target-tree-il-compile-fwd linker ent-type1))
	(sx-type2
	 (theme-target-tree-il-compile-fwd linker ent-type2))
	(s-call (tree-il-get-call-keyword linker)))
    (cond
     ((or (not (is-known-object? ent-type1))
	  (not (is-t-class? ent-type1))
	  (not (is-known-object? ent-type2))
	  (not (is-t-class? ent-type2)))
      `(,s-call (toplevel is-subtype?) ,sx-type1 ,sx-type2))
     ((is-t-simple-class? ent-type2)
      `(,s-call (toplevel is-simple-class-subtype?) ,sx-type1 ,sx-type2))
     ((and (is-t-param-class-instance? ent-type2)
	   (not (is-tc-pair? ent-type2)))
      `(,s-call (toplevel is-param-inst-subclass?) ,sx-type1 ,sx-type2))
     (else
      `(,s-call (toplevel is-subtype?) ,sx-type1 ,sx-type2)))))


(define (make-normal-equiv-expression linker s-kind x1 x2)
  (let ((p-pred-name (assq s-kind gl-al-target-eq-pred)))
    (assert (not (eq? p-pred-name #f)))
    (let ((s-pred-name (cdr p-pred-name))
	  (s-call (tree-il-get-call-keyword linker)))
      `(,s-call (toplevel ,s-pred-name) ,x1 ,x2))))


(define (optimize-eq-by-value1 linker s-kind i
			       l-fields1 l-fields2
			       x-obj1 x-obj2)
  (assert (= (length l-fields1) (length l-fields2)))
  (if (null? l-fields1)
      '(const #t)
      (let* ((type1 (tno-field-ref (car l-fields1) 'type))
	     (type2 (tno-field-ref (car l-fields2) 'type))
	     (s-call (tree-il-get-call-keyword linker))
	     (x-elem1
	      `(,s-call (toplevel vector-ref)
			,x-obj1
			(const ,i)))
	     (x-elem2
	      `(,s-call (toplevel vector-ref)
			,x-obj2
			(const ,i)))
	     ;; No deep recursion into contents.
	     (x-test (make-equiv-expression1 linker s-kind #f
					     type1 x-elem1
					     type2 x-elem2))
	     (x-next (optimize-eq-by-value1 linker s-kind (+ i 1)
					    (cdr l-fields1)
					    (cdr l-fields2)
					    x-obj1
					    x-obj2)))
	`(if ,x-test ,x-next (const #f)))))


(define (is-var-ref? x)
  (and (list? x)
       (not-null? x)
       (or (eq? (car x) 'toplevel)
	   (eq? (car x) 'lexical))))


;; This procedure works only for noninheritable classes.
(define (optimize-eq-by-value linker s-kind cl1 x1 cl2 x2)
  (let* ((l-fields1 (tno-field-ref cl1 'l-all-fields))
	 (l-fields2 (tno-field-ref cl2 'l-all-fields))
	 (i-nr-fields (length l-fields1)))
    (assert (= i-nr-fields (length l-fields2)))
    (if (<= i-nr-fields gl-i-max-ebv-opt)
	(let* ((wrap1? (not (is-var-ref? x1)))
	       (wrap2? (not (is-var-ref? x2)))
	       (x-obj1
		(if wrap1?
		    (tc-tree-il-var-ref0 linker
					 (linker-alloc-loc linker 'tmp1 #f))
		    x1))
	       (x-obj2
		(if wrap2?
		    (tc-tree-il-var-ref0 linker
					 (linker-alloc-loc linker 'tmp2 #f))
		    x2))
	       (x-body (optimize-eq-by-value1 linker s-kind 1
					      l-fields1
					      l-fields2
					      x-obj1
					      x-obj2))
	       (x-body2
		(if wrap2?
		    `(let (tmp2) (,(caddr x-obj2)) (,x2) ,x-body)
		    x-body))
	       (x-body1
		(if wrap1?
		    `(let (tmp1) (,(caddr x-obj1)) (,x1) ,x-body2)
		    x-body2)))
	  x-body1)
	#f)))

	    
(define (optimize-pair-eq-by-value linker s-kind cl1 x1 cl2 x2)
  (assert (is-tc-pair? cl1))
  (assert (is-tc-pair? cl2))
  (let* ((wrap1? (not (is-var-ref? x1)))
	 (wrap2? (not (is-var-ref? x2)))
	 (x-obj1
	  (if wrap1?
	      (tc-tree-il-var-ref0 linker
				   (linker-alloc-loc linker 'tmp1 #f))
	      x1))
	 (x-obj2
	  (if wrap2?
	      (tc-tree-il-var-ref0 linker
				   (linker-alloc-loc linker 'tmp2 #f))
	      x2))
	 (type11 (get-pair-first-type cl1))
	 (type12 (get-pair-second-type cl1))
	 (type21 (get-pair-first-type cl2))
	 (type22 (get-pair-second-type cl2))
	 (s-call (tree-il-get-call-keyword linker))
	 (x-elem11 `(,s-call (toplevel car) ,x-obj1))
	 (x-elem12 `(,s-call (toplevel cdr) ,x-obj1))
	 (x-elem21 `(,s-call (toplevel car) ,x-obj2))
	 (x-elem22 `(,s-call (toplevel cdr) ,x-obj2))
	 ;; No deeper recursion.
	 (x-test1 (make-equiv-expression1 linker s-kind #f
					  type11 x-elem11
					  type21 x-elem21))
	 (x-test2 (make-equiv-expression1 linker s-kind #f
					  type12 x-elem12
					  type22 x-elem22))
	 (x-body
	  `(if ,x-test1 ,x-test2 (const #f)))
	 (x-body2
	  (if wrap2?
	      `(let (tmp2) (,(caddr x-obj2)) (,x2) ,x-body)
	      x-body))
	 (x-body1
	  (if wrap1?
	      `(let (tmp1) (,(caddr x-obj1)) (,x1) ,x-body2)
	      x-body2)))
    x-body1))


(define (make-equiv-expression2 linker s-kind rec? type1 x-arg1 type2 x-arg2)
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (x-opt
	  ;; Types type1 and type2 are classes here. They are either
	  ;; user defined nonatomic classes, vector classes,
	  ;; custom primitive classes or goops classes.
	  (case s-kind
	    ((equal-objects?)
	     (let ((s-pred1
		    (hashq-ref (hfield-ref linker
					   'ht-equal-objects)
			       type1))
		   (s-pred2
		    (hashq-ref (hfield-ref linker
					   'ht-equal-objects)
			       type2)))
	       ;; The equal-objects? predicate is eqv? for all
	       ;; GOOPS classes.
	       (cond
		((and (not s-pred1) (not s-pred2))
		 ;; Use eqv? instead of eq? so that the predicate
		 ;; is correct in case the runtime type of
		 ;; either argument object is a GOOPS class.
		 `(,s-call (toplevel eqv?) ,x-arg1 ,x-arg2))
		((eq? s-pred1 s-pred2)
		 `(,s-call (toplevel ,s-pred1) ,x-arg1 ,x-arg2))
		(else #f))))
	    ((equal-values?)
	     (let ((s-pred1
		    (hashq-ref (hfield-ref linker
					   'ht-equal)
			       type1))
		   (s-pred2
		    (hashq-ref (hfield-ref linker
					   'ht-equal)
			       type2)))
	       (cond
		((or (tno-field-ref type1 'goops?)
		     (tno-field-ref type2 'goops?))
		 #f)
		((and s-pred1 (eq? s-pred1 s-pred2))
		 ;; If type1 and type2 are custom primitive classes
		 ;; they should be equal here.
		 `(,s-call (toplevel ,s-pred1) ,x-arg1 ,x-arg2))
		((and
		  (not (tno-field-ref type1 'inheritable?))
		  (not (tno-field-ref type2 'inheritable?))
		  ;; Classes type1 and type2 are the same class
		  ;; if the conditions above are true.
		  (not (tno-field-ref type1 'eq-by-value?)))
		 `(,s-call (toplevel eq?) ,x-arg1 ,x-arg2))
		((and
		  rec?
		  (not (tno-field-ref type1 'inheritable?))
		  (not (tno-field-ref type2 'inheritable?))
		  ;; Classes type1 and type2 are the same class
		  ;; if the conditions above are true.
		  (tno-field-ref type1 'eq-by-value?))
		 (optimize-eq-by-value linker s-kind
				       type1 x-arg1
				       type2 x-arg2))
		(else #f))))
	    ((equal-contents?)
	     (let ((s-pred1
		    (hashq-ref (hfield-ref linker
					   'ht-equal-contents)
			       type1))
		   (s-pred2
		    (hashq-ref (hfield-ref linker
					   'ht-equal-contents)
			       type2)))
	       (cond
		((or (tno-field-ref type1 'goops?)
		     (tno-field-ref type2 'goops?))
		 #f)
		((and s-pred1 (eq? s-pred1 s-pred2))
		 `(,s-call (toplevel ,s-pred1) ,x-arg1 ,x-arg2))
		((and
		  rec?
		  (not (tno-field-ref type1 'inheritable?))
		  (not (tno-field-ref type2 'inheritable?)))
		 ;; Classes type1 and type2 are the same class
		 ;; if the conditions above are true.
		 (optimize-eq-by-value linker s-kind
				       type1 x-arg1
				       type2 x-arg2))
		(else #f))))
	    (else (raise 'internal-error)))))
    (if x-opt
	x-opt
	(make-normal-equiv-expression linker s-kind
				      x-arg1 x-arg2))))


(define (make-equiv-expression1 linker s-kind rec? type1 x-arg1 type2 x-arg2)
  (assert (memq s-kind (list 'equal-values? 'equal-objects? 'equal-contents?)))
  (let* ((binder (hfield-ref linker 'binder-instantiation))
	 (cl1? (is-t-instance? binder type1 tc-class))
	 (cl2? (is-t-instance? binder type2 tc-class))
	 (s-call (tree-il-get-call-keyword linker)))
    (if (and cl1? cl2?
	     (not (is-t-subtype? binder type1 type2))
	     (not (is-t-subtype? binder type2 type1)))
	'(const #f)	
	(let* ((s-pred1 (get-equiv-pred s-kind type1))
	       (s-pred2 (get-equiv-pred s-kind type2)))
	  (cond
	   ((or s-pred1 s-pred2) =>
	    (lambda (s-pred)
	      `(,s-call (toplevel ,s-pred) ,x-arg1 ,x-arg2)))
	   ((or (not cl1?) (not cl2?))
	    (make-normal-equiv-expression linker s-kind x-arg1 x-arg2))
	   ((and (is-tc-pair? type1) (is-tc-pair? type2))
	    (cond
	     ((eq? s-kind 'equal-objects?)
	      `(,s-call (toplevel eq?) ,x-arg1 ,x-arg2))
	     (rec?
	      (optimize-pair-eq-by-value linker s-kind
					 type1 x-arg1 type2 x-arg2))
	     (else
	      (make-normal-equiv-expression linker s-kind x-arg1 x-arg2))))
	   ((or (is-tc-pair? type1) (is-tc-pair? type2))
	    ;; If we enter here either of types type1 and type2 is <object>.
	    (if (eq? s-kind 'equal-objects?)
		`(,s-call (toplevel eq?) ,x-arg1 ,x-arg2)
		(make-normal-equiv-expression linker s-kind x-arg1 x-arg2)))
	   (else
	    (make-equiv-expression2 linker s-kind rec?
				    type1 x-arg1 type2 x-arg2)))))))


(define (make-equiv-expression linker s-kind ent1 ent2)
  (let* ((x1 (theme-target-tree-il-compile linker ent1))
	 (x2 (theme-target-tree-il-compile linker ent2))
	 (type1 (get-entity-type ent1))
	 (type2 (get-entity-type ent2)))
    (make-equiv-expression1 linker s-kind #t type1 x1 type2 x2)))


(define (tc-tree-il-var-ref0 linker address)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address <address>))
  (let ((sym-name (get-target-var-name linker address)))
    (if (hfield-ref address 'toplevel?)
	`(toplevel ,sym-name)
	(let ((sym-source-name (hfield-ref address 'source-name)))
	  `(lexical ,sym-source-name ,sym-name)))))


(define (tc-tree-il-var-ref linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <variable-reference>))
  (let* ((variable (hfield-ref repr 'variable))
	 (address (hfield-ref variable 'address)))
    ;; Forward declared variables are always toplevel.
    (if (hfield-ref address 'toplevel?)
	(let ((s-name (get-target-var-name linker address))
	      (s-source-name (hfield-ref address 'source-name))
	      (s-call (tree-il-get-call-keyword linker)))
	  `(,s-call (toplevel check-var-unspecified)
		    (toplevel ,s-name)
		    (const ,s-source-name)))
	(tc-tree-il-var-ref0 linker address))))


(define (tc-tree-il-primitive-object linker repr)
  (assert (hfield-ref repr 'primitive?))
  (cond
   ((is-t-atomic-object? repr)
    (list 'const (get-contents repr)))
   ((not-null? (hfield-ref repr 'address))
    (tc-tree-il-object-with-address linker repr))
   (else
    (list 'const (get-contents repr)))))


(define (tc-tree-il-compile-type-var linker tvar)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-variable? tvar))
  (tc-tree-il-var-ref0 linker (hfield-ref tvar 'address)))


(define (tc-tree-il-generate-type-check linker obj-expr type-expr)
  (assert (is-linker? linker))
  (let ((s-call (tree-il-get-call-keyword linker)))
    (cond
     ((hfield-ref linker 'verbose-typechecks?)
      `(,s-call (toplevel check-type-verbose)
		,obj-expr ,type-expr
		(const ,obj-expr) (const ,type-expr)))
     (else
      `(,s-call (toplevel check-type) ,obj-expr ,type-expr)))))


(define (tc-tree-il-letrec-unspecified-check linker expr s-var-name)
  (let ((s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel check-letrec-unspecified)
	      ,expr
	      (const ,s-var-name))))


(define (tc-tree-il-call-stack-debug linker repr t-body)
  (if (hfield-ref linker 'runtime-pretty-backtrace?)
      (let* ((s-kind (hfield-ref repr 's-kind))
	     (s-name (hfield-ref repr 's-name))
	     (l-module (hfield-ref repr 'l-module))
	     (addr-result (linker-alloc-loc linker 'result #f))
	     (s-gensym (get-target-var-name linker addr-result))
	     (s-call (tree-il-get-call-keyword linker))
	     (s-seq (tree-il-get-seq-keyword linker)))
	`(,s-seq
	   (,s-call (toplevel call-stack-push)
		    (const ,s-kind)
		    (const ,s-name)
		    (const ,l-module))
	   (let (result) (,s-gensym) (,t-body)
		(,s-seq
		 (,s-call (toplevel call-stack-pop))
		 (lexical result ,s-gensym)))))
      t-body))


(define (generate-let*-expression t-names t-gensyms t-values t-body)
  (if (null? t-names)
      t-body
      `(let (,(car t-names)) (,(car t-gensyms)) (,(car t-values))
	    ,(generate-let*-expression (cdr t-names)
				       (cdr t-gensyms)
				       (cdr t-values)
				       t-body))))


(define (tc-tree-il-construct-procedure0 linker lst-source-names
					 lst-gensyms
					 t-body t-arg-descs
					 t-args)
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (addr-parsed (linker-alloc-loc linker 'parsed-args #f))
	 (sym-parsed-gensym (get-target-var-name linker addr-parsed))
	 (t-var-parsed (list 'lexical 'parsed-args sym-parsed-gensym))
	 (lst-indices (get-integer-sequence 0 (length lst-source-names)))
	 (lst-values (map (lambda (i) `(,s-call (toplevel list-ref)
						,t-var-parsed
						(const ,i)))
			  lst-indices))
	 (lst-expr
	  (generate-let*-expression lst-source-names lst-gensyms lst-values
				    t-body)))
    `(let (parsed-args) (,sym-parsed-gensym)
	  ((,s-call (toplevel translate-call-arguments)
		    (,s-call (toplevel list) ,@t-arg-descs) ,t-args))
	  ,lst-expr)))


(define (tc-tree-il-construct-procedure linker repr
					arg-vars t-body t-arg-descs
					t-result-type-desc
					simple-args?
					simple-args-with-tail?
					s-name)
  (let* ((lst-addr (map (lambda (var) (hfield-ref var 'address)) arg-vars))
	 (lst-source-names (map (lambda (address)
				  (hfield-ref address 'source-name))
				lst-addr))
	 (lst-gensyms (map (lambda (address)
			     (get-target-var-name linker address))
			   lst-addr)))
    (cond
     (simple-args?
      (let ((t-body1 (tc-tree-il-call-stack-debug linker repr t-body)))
	`(lambda ,(get-lambda-attr s-name)
	   (lambda-case ((,lst-source-names #f #f #f ()
					    ,lst-gensyms)
			 ,t-body1)))))
     (simple-args-with-tail?
      (let ((t-body1 (tc-tree-il-call-stack-debug linker repr t-body)))
	`(lambda ,(get-lambda-attr s-name)
	   (lambda-case ((,(drop-right lst-source-names 1)
			  #f
			  ,(last lst-source-names)
			  #f ()
			  ,lst-gensyms)
			 ,t-body1)))))
     (else
      (let* ((addr-args (linker-alloc-loc linker 'args #f))
	     (sym-args-gensym (get-target-var-name linker addr-args))
	     (t-args (list 'lexical 'args sym-args-gensym))
	     (t-actual-body
	      (if (not-null? t-args)
		  (tc-tree-il-construct-procedure0 linker lst-source-names
						   lst-gensyms t-body
						   t-arg-descs t-args)
		  t-body))
	     (t-actual-body1 (tc-tree-il-call-stack-debug linker repr
							  t-actual-body)))
	`(lambda ,(get-lambda-attr s-name)
	   (lambda-case ((() #f args #f ()
			  (,sym-args-gensym))
			 ,t-actual-body1))))))))


(define (get-source-names lst-args)
  (map (lambda (arg) (hfield-ref (hfield-ref arg 'address) 'source-name))
       lst-args))


(define (tc-tree-il-param-proc-body-simple-args
	 linker repr l-params t-body l-args s-name)
  (let* ((l-all-args (append l-params l-args))
	 (l-names (get-source-names l-all-args))
	 (l-gensyms (get-gensyms linker l-all-args))
	 (t-body1 (tc-tree-il-call-stack-debug linker repr t-body)))
    `(lambda ,(get-lambda-attr s-name)
       (lambda-case (((,@l-names) #f #f #f () (,@l-gensyms))
		     ,t-body1)))))


(define (tc-tree-il-param-proc-body-simple-args-with-tail
	 linker repr l-params t-body l-args s-name)
  (let* ((l-all-args (append l-params l-args))
	 (l-names (get-source-names l-all-args))
	 (l-normal-names (drop-right l-names 1))
	 (l-rest-name (last l-names))
	 (l-gensyms (get-gensyms linker l-all-args))
	 (t-body1 (tc-tree-il-call-stack-debug linker repr t-body)))
    `(lambda ,(get-lambda-attr s-name)
       (lambda-case (((,@l-normal-names) #f ,l-rest-name #f () (,@l-gensyms))
		     ,t-body1)))))


(define (tc-tree-il-param-proc-body-nonsimple-args
	 linker repr l-params t-body l-args t-arg-descs s-name)
  (let* ((l-param-names (get-source-names l-params))
	 (l-param-gensyms (get-gensyms linker l-params))
	 (l-arg-names (get-source-names l-args))
	 (l-arg-gensyms (get-gensyms linker l-args))
	 (addr-args (linker-alloc-loc linker 'args #f))
	 (s-args-gensym (get-target-var-name linker addr-args))
	 (t-args-ref (list 'lexical 'args s-args-gensym))
	 (t-actual-body
	  (tc-tree-il-construct-procedure0 linker
					   l-arg-names
					   l-arg-gensyms
					   t-body t-arg-descs
					   t-args-ref))
	 (t-actual-body1 (tc-tree-il-call-stack-debug linker repr
						      t-actual-body)))
    `(lambda ,(get-lambda-attr s-name)
       (lambda-case ((,l-param-names #f args #f ()
		      (,@l-param-gensyms ,s-args-gensym))
		     ,t-actual-body1)))))


(define (tc-tree-il-param-proc-body-no-args
	 linker repr l-params t-body s-name)
  (let* ((l-names (get-source-names l-params))
	 (l-gensyms (get-gensyms linker l-params))
	 (t-body1 (tc-tree-il-call-stack-debug linker repr t-body)))
    `(lambda ,(get-lambda-attr s-name)
       (lambda-case ((,l-names #f #f #f ()
			       ,l-gensyms)
		     ,t-body1)))))


(define (tc-tree-il-construct-param-proc-body linker repr l-params t-body
					      l-args
					      t-arg-descs
					      t-result-type-desc
					      s-name
					      no-result?
					      simple-args?
					      simple-args-with-tail?
					      type-dispatched?)
  (assert (is-linker? linker))
  (let ((t-body1
	 (if no-result?
	     t-body
	     (tc-tree-il-generate-type-check linker t-body
					     t-result-type-desc))))
    (cond
     ((null? l-args)
      (tc-tree-il-param-proc-body-no-args
       linker repr l-params t-body1 s-name))
     (simple-args?
      (tc-tree-il-param-proc-body-simple-args
       linker repr l-params t-body1 l-args s-name))
     (simple-args-with-tail?
      (tc-tree-il-param-proc-body-simple-args-with-tail
       linker repr l-params t-body1 l-args s-name))
     (else
      (tc-tree-il-param-proc-body-nonsimple-args
       linker repr l-params t-body1 l-args t-arg-descs s-name)))))


(define (tc-tree-il-compile-proc-expr linker repr l-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (assert (list? l-tvars))
  (let* ((args (hfield-ref repr 'arg-variables))
	 (arg-descs (hfield-ref repr 'arg-descs))
	 (simple? (is-simple-arg-list2? arg-descs))
	 (simple-with-tail? (is-simple-arg-list-with-tail? arg-descs))
	 (c-arg-descs (map (lambda (desc)
			     (theme-target-tree-il-compile linker desc))
			   arg-descs))
	 (body (hfield-ref repr 'body))
	 (c-body (theme-target-tree-il-compile linker body))
	 (type (get-entity-type repr))
	 (c-type (theme-target-tree-il-compile linker type))
	 (result-type (hfield-ref repr 'result-type))
	 (c-result-type (theme-target-tree-il-compile linker result-type))
	 (s-name (hfield-ref repr 's-name))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-procedure)
	      ,c-type
	      ,(tc-tree-il-construct-procedure linker repr args c-body
					       c-arg-descs
					       c-result-type
					       simple? simple-with-tail?
					       s-name))))


(define (tc-tree-il-compile-param-proc-expr linker repr0 repr l-tvars s-name)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (assert (list? l-tvars))
  (let* ((args (hfield-ref repr 'arg-variables))
	 (arg-descs (hfield-ref repr 'arg-descs))
	 (simple? (is-simple-arg-list2? arg-descs))
	 (simple-with-tail? (is-simple-arg-list-with-tail? arg-descs))
	 (c-arg-descs (map (lambda (desc)
			     (theme-target-tree-il-compile linker desc))
			   arg-descs))
	 (body (hfield-ref repr 'body))
	 (c-body (theme-target-tree-il-compile linker body))
	 (type (get-entity-type repr))
	 (c-type (theme-target-tree-il-compile linker type))
	 (result-type (hfield-ref repr 'result-type))
	 (c-result-type (theme-target-tree-il-compile linker result-type)))
    (let ((no-result? (linker-entity-is-none? linker result-type))
	  (type-dispatched? (entity-type-dispatched? body)))
      (tc-tree-il-construct-param-proc-body linker
					    repr0
					    l-tvars
					    c-body args c-arg-descs
					    c-result-type
					    s-name
					    no-result?
					    simple?
					    simple-with-tail?
					    type-dispatched?))))



(define (tc-tree-il-prim-proc-check linker result-type t-result-type t-cl)
  (let ((s-call (tree-il-get-call-keyword linker)))
    (cond
     ((or (not (is-known-object? result-type))
	  (not (is-t-class? result-type)))
      `(,s-call (toplevel is-subtype?) ,t-cl ,t-result-type))
     ((is-t-simple-class? result-type)
      `(,s-call (toplevel is-simple-class-subtype?) ,t-cl ,t-result-type))
     ((and (is-t-param-class-instance? result-type)
	   (not (is-tc-pair? result-type)))
      `(,s-call (toplevel is-param-inst-subclass?) ,t-cl ,t-result-type))
     (else
      `(,s-call (toplevel is-subtype?) ,t-cl ,t-result-type)))))


(define (tc-tree-il-construct-prim-proc-wrapper linker expr)
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (binder (hfield-ref linker 'binder-instantiation))
	 (address (hfield-ref expr 'address))
	 (type-proc (get-entity-type expr))
	 (type-result (tno-field-ref type-proc 'type-result))
	 (type-arglist (tno-field-ref type-proc 'type-arglist))
	 (simple? (is-tuple-type? binder type-arglist))
	 (n-args (if simple? (tuple-type-length binder type-arglist) -1))
	 (l-arg-numbers (if simple? (get-integer-sequence 1 n-args) '()))
	 (l-arg-names (if simple?
			  (map
			   (lambda (i)
			     (string->symbol
			      (string-append "arg" (number->string i))))
			   l-arg-numbers)
			  '()))
	 (l-arg-gensyms
	  (if simple?
	      (map (lambda (s-name)
		     (let ((addr (linker-alloc-loc linker s-name #f)))
		       (get-target-var-name linker addr)))
		   l-arg-names)
	      '()))
	 (t-proc (tc-tree-il-var-ref0 linker address))
	 (t-result-type (theme-target-tree-il-compile linker type-result))
	 (source-name (hfield-ref address 'source-name))
	 (str-source-name (symbol->string source-name))
	 (addr-arguments
	  (if (not simple?)
	      (linker-alloc-loc linker 'arguments #f)
	      '()))
	 (sym-arguments-gensym
	  (if (not simple?)
	      (get-target-var-name linker addr-arguments)
	      '()))
	 (t-arguments
	  (if (not simple?)
	      (list 'lexical 'arguments sym-arguments-gensym)
	      '()))
	 (addr-result (linker-alloc-loc linker 'result #f))
	 (sym-result-gensym (get-target-var-name linker addr-result))
	 (t-result (list 'lexical 'result sym-result-gensym))
	 (texpr-header
	  (if simple?
	      `(,l-arg-names #f #f #f () ,l-arg-gensyms)    
	      `(() #f arguments #f () (,sym-arguments-gensym))))
	 (l-texpr-arglist
	  (if simple?
	      (map (lambda (s-name s-gensym) (list 'lexical s-name s-gensym))
		   l-arg-names l-arg-gensyms)
	      '()))
	 (texpr-call
	  (if simple?
	      `(,s-call ,t-proc ,@l-texpr-arglist)
	      `(,s-call (toplevel apply) ,t-proc ,t-arguments))))
    (if (eq? type-result tc-object)
	`(lambda ()
	   (lambda-case (,texpr-header
			 (let (result)
			   (,sym-result-gensym)
			   (,texpr-call)
			   (if
			    (,s-call (toplevel is-valid-theme-d-object?)
				     ,t-result)
			    ,t-result
			    (,s-call (toplevel _i_invalid-theme-d-object-error)
				     ,t-result
				     (const ,str-source-name)))))))
	(let ((p-prim (assq type-result gl-l-prim-pred))
	      (t-result-type
	       (theme-target-tree-il-compile linker type-result)))
	  (if p-prim
	      `(lambda ()
		 (lambda-case (,texpr-header
			       (let (result)
				 (,sym-result-gensym)
				 (,texpr-call)
				 (if
				  (,s-call (toplevel ,(cdr p-prim))
					   ,t-result)
				  ,t-result
				  (,s-call (toplevel _i_result-type-error)
					   ,t-result
					   ,t-result-type
					   (const ,str-source-name)))))))
	      (let* ((addr-result-type-var
		      (linker-alloc-loc linker 'result-type-var #f))
		     (sym-result-type-var-gensym
		      (get-target-var-name linker addr-result-type-var))
		     (t-result-type-var
		      (list 'lexical 'result-type1 sym-result-type-var-gensym))
		     (addr-cl
		      (linker-alloc-loc linker 'cl-var #f))
		     (sym-cl-gensym
		      (get-target-var-name linker addr-cl))
		     (t-cl
		      (list 'lexical 'cl sym-cl-gensym))
		     (t-check
		      (tc-tree-il-prim-proc-check linker
						  type-result
						  t-result-type-var
						  t-cl)))
		`(lambda ()
		   (lambda-case (,texpr-header
				 (let (result result-type1)
				   (,sym-result-gensym
				    ,sym-result-type-var-gensym)
				   (,texpr-call ,t-result-type)
				   (let (cl)
				     (,sym-cl-gensym)
				     ((,s-call (toplevel theme-class-of0)
					       ,t-result))
				     (if
				      ,t-cl
				      (if
				       ,t-check
				       ,t-result
				       (,s-call (toplevel _i_result-type-error)
						,t-result
						,t-result-type-var
						(const ,str-source-name)))
				      (,s-call
				       (toplevel
					_i_invalid-theme-d-object-error)
				       ,t-result
				       (const ,str-source-name))))))))))))))


(define (tc-tree-il-compile-prim-proc-ref linker repr param-proc? l-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (result
	  (if (not param-proc?)
	      (let ((type (get-entity-type repr))
		    (t-var-ref
		     (tc-tree-il-var-ref0 linker
					  (hfield-ref repr 'address))))	
		(cond
		 ((is-tc-simple-proc? type)
		  (list s-call '(toplevel _i_make-procedure)
			(tc-tree-il-object-fwd linker type '() #f)
			t-var-ref))
		 ((is-tc-param-proc? type)
		  `(,s-call (toplevel _i_make-param-proc)
			    ,(tc-tree-il-object-fwd linker type '() #f)
			    ,t-var-ref
			    (const ,(hfield-ref (hfield-ref repr 'address)
						'source-name))))
		 (else
		  (dvar1-set! repr)
		  (raise 'internal-error-with-prim-proc))))
	      (let* ((s-name (get-target-var-name linker
						  (hfield-ref repr 'address)))
		     (addr-args (linker-alloc-loc linker 'args #f))
		     (s-gensym-args (get-target-var-name linker addr-args))
		     (l-source-names (get-source-names l-tvars))
		     (l-gensyms (get-gensyms linker l-tvars)))
		(assert (hfield-ref (hfield-ref repr 'address) 'toplevel?))
		`(lambda () (lambda-case
			     ((,l-source-names #f args () ()
					       (,@l-gensyms ,s-gensym-args))
			      (,s-call (toplevel apply)
				       (toplevel ,s-name)
				       (lexical args ,s-gensym-args)))))))))
    result))


(define (tc-tree-il-param-prim-proc-wrapper linker address result-type
					    l-tvars)
  (assert (hfield-ref address 'toplevel?))
  (let* ((name (get-target-var-name linker address))
	 (t-result-type (theme-target-tree-il-compile linker result-type))
	 (source-name (hfield-ref address 'source-name))
	 (l-source-names (get-source-names l-tvars))
	 (l-gensyms (get-gensyms linker l-tvars))
	 (addr-args (linker-alloc-loc linker 'args #f))
	 (s-gensym-args (get-target-var-name linker addr-args))
	 (s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker)))
    ;; Maybe we could set the procedure name in the procedure properties.
    (if (linker-entity-is-none? linker result-type)
	`(lambda () (lambda-case
		     ((,l-source-names #f args () ()
				       (,@l-gensyms ,s-gensym-args))
		      (,s-call (toplevel apply)
			       (toplevel ,name)
			       (lexical args ,s-gensym-args)))))
	(let* ((addr-result (linker-alloc-loc linker 'result #f))
	       (s-gensym-result (get-target-var-name linker addr-result))
	       (addr-result-type (linker-alloc-loc linker 'result-type #f))
	       (s-gensym-result-type
		(get-target-var-name linker addr-result-type)))
	  `(lambda () (lambda-case
		       ((,l-source-names #f args () ()
					 (,@l-gensyms ,s-gensym-args))
			(let (result result-type)
			  (,s-gensym-result ,s-gensym-result-type)
			  ((,s-call (toplevel apply)
				    (toplevel ,name)
				    (lexical args ,s-gensym-args))
			   ,t-result-type)
			  (,s-seq
			    (,s-call (toplevel _i_check-result-type)
				     (lexical result ,s-gensym-result)
				     (lexical result-type ,s-gensym-result-type)
				     (const ,(symbol->string source-name)))
			    (lexical result ,s-gensym-result))))))))))


(define (tc-tree-il-param-prim-proc-wrapper2 linker address type result-type
					     l-tvars)
  ;; <none> result type must be taken care by the caller.
  (assert (not (eqv? result-type tt-none)))
  (let* ((s-name (get-target-var-name linker address))
	 (t-type (theme-target-tree-il-compile linker type))
	 (t-result-type (theme-target-tree-il-compile linker result-type))
	 (source-name (hfield-ref address 'source-name))
	 (l-source-names (get-source-names l-tvars))
	 (l-gensyms (get-gensyms linker l-tvars))
	 (l-tvar-refs (map (lambda (s-source-name s-gensym)
			     (list 'lexical s-source-name s-gensym))
			   l-source-names l-gensyms))
	 (addr-args (linker-alloc-loc linker 'args #f))
	 (s-gensym-args (get-target-var-name linker addr-args))
	 (addr-result (linker-alloc-loc linker 'result #f))
	 (s-gensym-result (get-target-var-name linker addr-result))
	 (addr-result-type (linker-alloc-loc linker 'result-type #f))
	 (s-gensym-result-type
	  (get-target-var-name linker addr-result-type))
	 (s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker)))
    ;; Maybe we could set the procedure name in the procedure properties.
    `(,s-call (toplevel _i_make-param-proc)
	      ,t-type
	      (lambda ()
		(lambda-case ((,l-source-names #f args () ()
					       (,@l-gensyms ,s-gensym-args))
			      (let (result result-type)
				(,s-gensym-result ,s-gensym-result-type)
				((,s-call (toplevel apply)
					  (toplevel ,s-name)
					  (,s-call
					   (toplevel make-list-with-tail)
					   (,s-call (toplevel list)
						    ,@l-tvar-refs)
					   (lexical args ,s-gensym-args)))
				 ,t-result-type)
				(,s-seq
				 (,s-call (toplevel _i_check-result-type)
					  (lexical result ,s-gensym-result)
					  (lexical result-type
						   ,s-gensym-result-type)
					  (const ,(symbol->string source-name)))
				 (lexical result ,s-gensym-result))))))
	      (const ()))))


(define (tc-tree-il-compile-checked-prim-proc linker repr param-proc? l-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <checked-prim-proc>))
  (assert (boolean? param-proc?))
  (assert (list? l-tvars))
  (let ((type (get-entity-type repr)))
    (strong-assert
     (or (is-tc-simple-proc? type)
	 (is-tc-param-proc? type)))
    (let ((result
	   (cond
	    (param-proc?
	     (let ((result-type (tno-field-ref type 'type-result)))
	       (tc-tree-il-param-prim-proc-wrapper
	     	linker
	     	(hfield-ref repr 'address)
	     	result-type
	     	l-tvars)))
	    ((is-tc-simple-proc? type)
	     ;; We must not check the result value
	     ;; if the result type is <none>.
	     (let ((result-type (tno-field-ref type 'type-result))
		   (t-var-ref
		    (tc-tree-il-var-ref0 linker
					 (hfield-ref repr 'address)))
		   (s-call (tree-il-get-call-keyword linker)))
	       (if (linker-entity-is-none? linker result-type)
		   (list s-call '(toplevel _i_make-procedure)
			 (tc-tree-il-object-fwd linker (get-entity-type repr)
						'() #f)
			 t-var-ref)
		   (list s-call '(toplevel _i_make-procedure)
			 (tc-tree-il-object-fwd linker type '() #f)
			 (tc-tree-il-construct-prim-proc-wrapper
			  linker repr)))))
	    ((is-tc-param-proc? type)
	     (let* ((result-type
		     (tno-field-ref (tno-field-ref type 'type-contents)
				    'type-result))
	     	    (l-tvars (tno-field-ref type 'l-tvars)))
	       (if (linker-entity-is-none? linker result-type)
	     	   (let* ((s-name (get-target-var-name
				   linker
				   (hfield-ref repr 'address)))
			  (t-type (tc-tree-il-object-fwd
				   linker
				   (get-entity-type repr)))
			  (s-call (tree-il-get-call-keyword linker)))
		     `(,s-call (toplevel _i_make-param-proc)
			       ,t-type
			       ,s-name
			       ,s-name))
	     	   (tc-tree-il-param-prim-proc-wrapper2
	     	    linker
	     	    (hfield-ref repr 'address)
	     	    type
	     	    result-type
	     	    l-tvars))))
	    (else (raise 'internal-error-1)))))
      result)))


(define (tc-tree-il-class-field-texpr linker field)
  (let* ((name (tno-field-ref field 's-name))
	 (type (theme-target-tree-il-compile linker
					     (tno-field-ref field 'type)))
	 (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?))
	 (r-init-value
	  (if has-init-value?
	      (tno-field-ref field 'x-init-value)
	      '()))
	 (t-init-value
	  (if has-init-value?
	      (theme-target-tree-il-compile linker r-init-value)
	      '(const ()))))
    (list `(const ,name) type `(const ,read-access) `(const ,write-access)
	  `(const ,has-init-value?) t-init-value)))


(define (tc-tree-il-class-field-texprs linker fields)
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (l-texprs
	  (map (lambda (fld)
		 `(,s-call (toplevel make-field)   
			   ,@(tc-tree-il-class-field-texpr linker fld)))
	       fields)))
    `(,s-call (toplevel list) ,@l-texprs)))


(define (tc-tree-il-get-initializer-body linker object-arg fields
					 l-field-arg-names
					 l-field-arg-gensyms)
  (let ((body '())
	(i-arg 0)
	(s-call (tree-il-get-call-keyword linker)))
    (do ((i 1 (+ i 1)) (cur-lst fields (cdr cur-lst)))
	((null? cur-lst))
      (let* ((cur-field (car cur-lst))
	     (has-init-value? (tno-field-ref cur-field 'has-init-value?))
	     (cur-init-value
	      (if has-init-value?
		  (tno-field-ref cur-field 'x-init-value)
		  '())))
	(if (null? cur-init-value)
	    (let* ((s-cur-arg-name (list-ref l-field-arg-names i-arg))
		   (s-gensym-cur-arg (list-ref l-field-arg-gensyms i-arg))
		   (t-cur-arg-ref (list 'lexical
					s-cur-arg-name
					s-gensym-cur-arg)))		  
	      (set! body
		    (append body
			    (list
			     `(,s-call (toplevel vector-set!)
				       ,object-arg
				       (const ,i)
				       ,t-cur-arg-ref))))
	      (set! i-arg (+ i-arg 1)))
	    (let ((t-contents (theme-target-tree-il-compile
			       linker cur-init-value)))
	      (set! body
		    (append body
			    (list
			     `(,s-call (toplevel vector-set!)
				       ,object-arg
				       (const ,i)
				       ,t-contents))))))))
    body))


(define (tc-tree-il-get-constructor-body
	 linker t-class fields l-field-arg-names l-field-arg-gensyms)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? t-class))
  (assert (list? fields))
  (assert (list? l-field-arg-names))
  (assert (list? l-field-arg-gensyms))
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker))
	 (class-texpr (tc-tree-il-var-ref0
		       linker
		       (hfield-ref t-class 'address)))
	 (addr-result (linker-alloc-loc linker 'result #f))
	 (s-gensym-result (get-target-var-name linker addr-result))
	 (class-init-texpr
	  `(,s-call (toplevel vector-set!)
		    (lexical result ,s-gensym-result)
		    (toplevel i-object-class)
		    ,class-texpr))
	 (initializer-texprs
	  (tc-tree-il-get-initializer-body
	   linker
	   (list 'lexical 'result s-gensym-result)
	   fields
	   l-field-arg-names
	   l-field-arg-gensyms))
	 (field-count (length fields))
	 (texpr-sub
	  (tc-tree-il-compile-sequence
	   linker
	   `(,class-init-texpr
	     ,@initializer-texprs
	     (lexical result ,s-gensym-result))))
	 (result
	  ;; Vektorin ensimmäinen alkio on olion tyyppi.
	  `(let (result) (,s-gensym-result)
		((,s-call (toplevel make-vector)
			  (const ,(+ field-count 1))
			  (const ())))
		,texpr-sub)))
    result))


(define (tc-tree-il-get-constructor-def linker to-class t-type)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to-class))
  (let* ((fields (tno-field-ref to-class 'l-all-fields))
	 (l-field-arg-names (get-constructor-field-args fields))
	 (l-field-arg-addresses
	  (map* (lambda (s-name) (linker-alloc-loc linker s-name #f))
		l-field-arg-names))
	 (l-field-arg-gensyms
	  (map (lambda (address) (get-target-var-name linker address))
	       l-field-arg-addresses))
	 (binder (get-binder-for-inst linker))
	 (body (tc-tree-il-get-constructor-body linker to-class
						fields
						l-field-arg-names
						l-field-arg-gensyms))
	 (proc
	  `(lambda () (lambda-case
		       ((,l-field-arg-names #f #f () () ,l-field-arg-gensyms)
			,body))))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-procedure) ,t-type ,proc)))


(define (tc-tree-il-declared-var-def linker addr t-expr r-type read-only?)
  (assert (is-target-object? r-type))
  (let ((t-var (tc-tree-il-var-ref0 linker addr))
	(addr-raw (address-hash-ref (get-ht-raw-procs linker) addr))
	(s-call (tree-il-get-call-keyword linker)))
    (cond
     (addr-raw
      (let ((t-raw (tc-tree-il-var-ref0 linker addr-raw)))
	`(_splice
	  (,s-call (toplevel vector-copy-contents)
		   ,t-expr
		   ,t-var)
	  (set! ,t-raw
		(,s-call (toplevel vector-ref)
			 ,t-var
			 (const 1))))))
     ((is-primitive-class? r-type)
      `(set! ,t-var ,t-expr))
     ((is-pair-class? r-type)
      `(,s-call (toplevel set-cons!) ,t-var ,t-expr))
     ((not read-only?) `(set! ,t-var ,t-expr)) 
     (else
      `(,s-call (toplevel vector-copy-contents)
		,t-expr
		,t-var)))))


(define (tc-tree-il-nondeclared-var-def linker repr)
  (let* ((variable (hfield-ref repr 'variable))
	 (type (get-entity-type variable))
	 (address (hfield-ref variable 'address))
	 (s-var-name (get-target-var-name linker address))
	 (t-expr1
	  `(define
	     ,s-var-name
	     ,(theme-target-tree-il-compile
	       linker
	       (hfield-ref repr 'value-expr)))))
    (if (and (hfield-ref variable 'read-only?)
	     (is-t-general-proc-type? type))
	(let* ((addr-raw (linker-alloc-loc linker 'raw #t)) 
	       (s-raw-name (get-target-var-name linker addr-raw))
	       (s-call (tree-il-get-call-keyword linker)))
	  (address-hash-set! (get-ht-raw-procs linker)
			     (hfield-ref variable 'address)
			     addr-raw)
	  `(_splice ,t-expr1
		    (define ,s-raw-name
		      (,s-call (toplevel vector-ref)
			       (toplevel ,s-var-name)
			       (const 1)))))
	t-expr1)))


(define (tc-tree-il-var-def0 linker value-expr)
  (if (is-target-object? value-expr)
      (tc-tree-il-object-fwd linker value-expr '() #t)
      (theme-target-tree-il-compile linker value-expr)))


(define (get-param-proc-instance0
	 linker
	 s-gensym-arguments
	 t-inst-type
	 t-param-proc
	 t-params)
  (let ((s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-procedure)
	      ,t-inst-type
	      (lambda ()
		(lambda-case
		 ((() #f arguments () ()
		   (,s-gensym-arguments))
		  (,s-call (toplevel apply)
			   (,s-call (toplevel vector-ref)
				    ,t-param-proc
				    (toplevel i-param-proc-raw-proc))
			   (,s-call (toplevel append)
				    (,s-call (toplevel list) ,@t-params)
				    (lexical arguments
					     ,s-gensym-arguments)))))))))


;; The following procedure works also for <expr-param-proc-dispatch>.
;; The following procedure may be useless since <expr-param-proc-instance>'s
;; and <expr-param-proc-dispatch>'s are replaced by variable references
;; when type variables are bound for the target compilation (?).
(define (tc-tree-il-param-proc-instance1 linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (or (hrecord-is-instance? repr <expr-param-proc-instance>)
	      (hrecord-is-instance? repr <expr-param-proc-dispatch>)))
  (let* ((r-param-proc (hfield-ref repr 'param-proc))
	 (r-params (hfield-ref repr 'params))
	 (param-cache (hfield-ref linker 'param-cache-instantiation))
	 (binder (get-binder-for-tc linker))
	 (r-inst (param-cache-fetch param-cache
				    r-param-proc r-params)))
    (if (not (eqv? r-inst #f))
	(let* ((r-inst-type (get-entity-type (cdr r-inst)))
	       (t-inst-type (theme-target-tree-il-compile linker r-inst-type))
	       (t-var-ref
		  (tc-tree-il-var-ref0
		   linker
		   (hfield-ref (cdr r-inst) 'address)))
	       (s-call (tree-il-get-call-keyword linker)))
	  `(,s-call (toplevel _i_make-procedure)
		    ,t-inst-type
		    ,t-var-ref))
	;; We should enter here only when compiling parametrized procedures.
	(let* ((r-inst-type (get-entity-type repr))
	       (t-inst-type (theme-target-tree-il-compile-fwd
			     linker r-inst-type))
	       (t-param-proc (theme-target-tree-il-compile-fwd
			      linker r-param-proc))
	       (t-params (map* (lambda (r-param)
				 (theme-target-tree-il-compile-fwd
				  linker r-param))
			       r-params))
	       (addr-arguments (linker-alloc-loc linker 'arguments #f))
	       (s-gensym-arguments
		(get-target-var-name linker addr-arguments)))
	  (get-param-proc-instance0 linker s-gensym-arguments t-inst-type
				    t-param-proc t-params)))))


(define (tc-tree-il-param-proc-instance-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (or (hrecord-is-instance? repr <expr-param-proc-instance>)
	      (hrecord-is-instance? repr <expr-param-proc-dispatch>)))
  (let* ((r-inst-type (get-entity-type repr))
	 (t-inst-type (theme-target-tree-il-compile-fwd linker r-inst-type))
	 (r-param-proc (hfield-ref repr 'param-proc))
	 (r-params (hfield-ref repr 'params))
	 (t-param-proc (theme-target-tree-il-compile-fwd linker r-param-proc))
	 (t-params (map* (lambda (r-param)
			   (theme-target-tree-il-compile-fwd linker r-param))
			 r-params))
	 (addr-arguments (linker-alloc-loc linker 'arguments #f))
	 (s-gensym-arguments
	  (get-target-var-name linker addr-arguments))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-procedure)
	      ,t-inst-type
	      (lambda ()
		(lambda-case
		 ((() #f arguments () () (,s-gensym-arguments))
		  (,s-call (toplevel apply)
			   (,s-call (toplevel vector-ref)
				    ,t-param-proc
				    (toplevel i-param-proc-raw-proc))
			   (,s-call (toplevel append)
				    (,s-call (toplevel list) ,@t-params)
				    (lexical arguments
					     ,s-gensym-arguments)))))))))


(define (tc-tree-il-var-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <variable-definition>))
  (if (var-def-is-used? linker repr)
      (let* ((variable (hfield-ref repr 'variable))
	     (address (hfield-ref variable 'address))
	     (read-only? (hfield-ref variable 'read-only?))
	     (result
	      (if (hfield-ref repr 'declared?)
		  (let ((t-expr
			 (theme-target-tree-il-compile
			  linker
			  (hfield-ref repr 'value-expr)))
			(r-type
			 (get-entity-type (hfield-ref repr 'variable))))
		    (tc-tree-il-declared-var-def linker address t-expr r-type
						 read-only?))
		  (tc-tree-il-nondeclared-var-def linker repr))))
	(assert (hfield-ref address 'toplevel?))
	result)
      (begin
	'(void))))


(define (tc-tree-il-set-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <set-expression>))
  (let* ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	 (t-var (tc-tree-il-var-ref0 linker address)))
    (if (not (hfield-ref linker 'tcomp-inside-param-proc?))
	`(set! ,t-var
	       ,(theme-target-tree-il-compile
		 linker
		 (hfield-ref repr 'value-expr)))
	(let* ((r-var-type (get-entity-type (hfield-ref repr 'variable)))
	       (t-var-type (theme-target-tree-il-compile linker r-var-type))
	       (r-value-expr (hfield-ref repr 'value-expr))
	       (t-value-expr
		(theme-target-tree-il-compile linker r-value-expr))
	       (t-final-value
		(if (entity-type-dispatched? r-value-expr)
		    t-value-expr
		    (tc-tree-il-generate-type-check
		     linker t-value-expr t-var-type))))
	  `(set! ,t-var ,t-final-value)))))


(define (make-default-proc linker s-name)
  (if (hfield-ref linker 'verbose-unlinked-procedures?)
      (let* ((addr-args (linker-alloc-loc linker 'args #f))
	     (s-args-gensym (get-target-var-name linker addr-args))
	     (s-call (tree-il-get-call-keyword linker)))
	`(lambda ()
	   (lambda-case ((() #f args #f () (,s-args-gensym))
			 (,s-call (toplevel proc-not-linked)
				  (const ,s-name))))))
      '(const ())))


(define (tc-tree-il-fw-decl linker repr)
  (if (or (hfield-ref repr 'redecl?)
	  (and (hfield-ref linker 'strip?)
	       (not (decl-is-used? linker repr)))) 
      '(void)
      (let* ((var (hfield-ref repr 'variable))
	     (var-name (get-target-var-name-for-loc linker var))
	     (type (get-entity-type var))
	     (s-call (tree-il-get-call-keyword linker)))
	(cond
	 ((and (hfield-ref var 'read-only?)
	       (is-t-general-proc-type? type))
	  (let* ((addr-raw (linker-alloc-loc linker 'raw #t))
		 (s-raw-name (get-target-var-name linker addr-raw)) 
		 (nr-of-fields (length (tno-field-ref type 'l-all-fields)))
		 (x-default-impl
		  (make-default-proc
		   linker
		   (hfield-ref (hfield-ref var 'address) 'source-name))))
	    (assert (= nr-of-fields 1))
	    (address-hash-set! (get-ht-raw-procs linker)
			       (hfield-ref var 'address)
			       addr-raw)
	    `(_splice
	      (define ,var-name
		(,s-call (toplevel vector)
			 (toplevel _b_unspecified)
			 ,x-default-impl))
	      (define ,s-raw-name ,x-default-impl))))
	 ((is-primitive-class? type)
	  `(define ,var-name (toplevel _b_unspecified)))
	 ((is-pair-class? type)
	  `(define ,var-name (,s-call (toplevel cons)
				      (toplevel _b_unspecified)
				      (toplevel _b_unspecified))))
	 ((not (hfield-ref var 'read-only?))
	  `(define ,var-name (toplevel _b_unspecified)))
	 (else
	  (let ((binder (get-binder-for-tc linker)))
	    (assert (is-t-instance? binder type tc-class))
	    (let ((nr-of-fields (length (tno-field-ref type 'l-all-fields))))
	      `(define ,var-name
		 (,s-call (toplevel make-vector) (const ,(+ nr-of-fields 1))
			  (toplevel _b_unspecified))))))))))


(define (tc-tree-il-prim-proc-ref linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (tc-tree-il-compile-prim-proc-ref linker repr #f '()))


(define (tc-tree-il-checked-prim-proc linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <checked-prim-proc>))
  (tc-tree-il-compile-checked-prim-proc linker repr #f '()))


(define (tc-tree-il-simple-proc-appl linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (is-t-instance? 
	   (get-binder-for-tc linker)
	   (get-entity-type (hfield-ref repr 'proc))
	   tpc-simple-proc))
  (let* ((args (hfield-ref repr 'arglist))
	 (comp
	  (lambda (arg)
	    (theme-target-tree-il-compile linker arg)))
	 (proc (hfield-ref repr 'proc)))
    (cond
     ;; The following test is an optimization.
     ((and
       (hrecord-is-instance? proc <expr-constructor>)
       (let ((to-class (hfield-ref proc 'clas))
	     (binder (get-binder-for-tc linker)))
	 (is-t-instance? binder to-class tpc-pair)))
      (let ((s-call (tree-il-get-call-keyword linker))
	    (t-args (map* comp args)))
	(strong-assert (= (length t-args) 2))
	`(,s-call (toplevel cons) ,@t-args)))
     ((eq? proc tp-is-instance)
      (strong-assert (= (length args) 2))
      ;; The object is compiled but the type is not.
      (let ((t-obj (comp (car args)))
	    (expr-type (cadr args)))
	(make-instance-test linker t-obj expr-type)))
     ((eq? proc tp-is-subtype)
      (strong-assert (= (length args) 2))
      (let ((ent-type1 (car args))
	    (ent-type2 (cadr args)))
	(make-subtype-test linker ent-type1 ent-type2)))
     ((eq? proc tp-equal-values)
      (strong-assert (= (length args) 2))
      ;; Arguments are not compiled here.
      (make-equiv-expression linker 'equal-values? (car args) (cadr args)))
     ((eq? proc tp-equal-objects)
      (strong-assert (= (length args) 2))
      ;; Arguments are not compiled here.
      (make-equiv-expression linker 'equal-objects? (car args) (cadr args)))
     ((eq? proc tp-equal-contents)
      (strong-assert (= (length args) 2))
      ;; Arguments are not compiled here.
      (make-equiv-expression linker 'equal-contents? (car args) (cadr args)))
     (else
      (let* ((t-proc (theme-target-tree-il-compile linker proc))
	     (t-args (map* comp args))
	     (s-call (tree-il-get-call-keyword linker)))
	(if (and (not (hfield-ref repr 'runtime-arglist-typecheck?))
		 (and-map? entity-type-dispatched? args))
	    (let* ((addr1 (if (is-known-object? proc)
			      (tno-field-ref proc 'addr-raw-proc)
			      '()))
		   (addr-raw
		    (if (not-null? addr1)
			addr1
			(let ((address (hfield-ref proc 'address)))
			  (and (not-null? address)
			       (address-hash-ref
				(get-ht-raw-procs linker)
				address))))))
	      (if addr-raw
		  ;; A raw procedure address is always toplevel.
		  (let ((s-var-name (get-target-var-name linker addr-raw)))
		    `(,s-call (toplevel ,s-var-name) ,@t-args))
		  `(,s-call (,s-call (toplevel vector-ref) ,t-proc (const 1))
			    ,@t-args)))
	    (let* ((addr-proc (linker-alloc-loc linker 'proc #f))
		   (sym-proc-gensym (get-target-var-name linker addr-proc))
		   (t-proc-var (list 'lexical 'proc sym-proc-gensym))
		   (s-proc-name
		    (let ((address (hfield-ref proc 'address)))
		      (if (not-null? address)
			  (hfield-ref address 'source-name)
			  '()))))
	      `(let (proc) (,sym-proc-gensym) (,t-proc)
		    (,s-call (toplevel apply)
			     (,s-call (toplevel vector-ref)
				      ,t-proc-var
				      (const 1))
			     (,s-call (toplevel check-arglist-type)
				      ,t-proc-var
				      (,s-call (toplevel list)
					       ,@t-args)
				      (const ,s-proc-name)))))))))))


(define (tc-tree-il-apply-expr linker repr)
  (let* ((arglist (hfield-ref repr 'arglist))
	 (proc (car arglist))
	 (arglist2 (cadr arglist))
	 (comp (lambda (rexpr) (theme-target-tree-il-compile linker rexpr)))
	 (t-proc (comp proc))
	 (t-arglist2 (comp arglist2))
	 (s-call (tree-il-get-call-keyword linker)))
    (if (is-tc-simple-proc? (get-entity-type proc))
	`(,s-call (toplevel apply)
		  (,s-call (toplevel vector-ref)
			   ,t-proc
			   (toplevel i-simple-proc-raw-proc))
		  ,t-arglist2)
	(let* ((static-arg-types (hfield-ref repr 'static-arg-types))
	       (t-static
		(if (list? static-arg-types)
		    (let ((t (map* comp static-arg-types)))
		      `(,s-call (toplevel list) ,@t))
		    (comp static-arg-types))))
	  `(,s-call (toplevel _i_call-proc)
		    ,t-proc
		    ,t-arglist2
		    (,s-call (toplevel cadr) ,t-static))))))


(define (tc-tree-il-param-proc-appl linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (target-type=?
	   (get-entity-type (get-entity-type (hfield-ref repr 'proc)))
	   tpc-param-proc))
  (let* ((args (hfield-ref repr 'arglist))
	 (comp (lambda (rexpr) (theme-target-tree-il-compile linker rexpr)))
	 (t-args (map* comp args))
	 (param-proc (hfield-ref repr 'proc))
	 (t-param-proc (comp param-proc))
	 (static-arg-types (hfield-ref repr 'static-arg-types))
	 (s-call (tree-il-get-call-keyword linker))
	 ;; static-arg-types may be a single variable
	 ;; because of optimization.
	 (t-static
	  (cond
	   ((null? static-arg-types)
	    '(const ()))
	   ((list? static-arg-types)
	    (let ((t (map* comp static-arg-types)))
	      `(,s-call (toplevel list) ,@t)))
	   (else
	    (comp static-arg-types))))
	 (result
	  `(,s-call (toplevel _i_call-param-proc)
		    ,t-param-proc
		    (,s-call (toplevel list) ,@t-args)
		    ,t-static)))
    result))


(define (tc-tree-il-checked-abst-proc-appl linker t-proc t-args t-static)
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (addr-proc
	  (linker-alloc-loc linker 'proc #f))
	 (s-gensym-proc
	  (get-target-var-name linker addr-proc))
	 (addr-args
	  (linker-alloc-loc linker 'args #f))
	 (s-gensym-args
	  (get-target-var-name linker addr-args))
	 (addr-static
	  (linker-alloc-loc linker 'static-types #f))
	 (s-gensym-static
	  (get-target-var-name linker addr-static)))
    `(let (prog args static-types)
       (,s-gensym-proc ,s-gensym-args ,s-gensym-static)
       (,t-proc (,s-call (toplevel list) ,@t-args) ,t-static)
       (if (,s-call (toplevel is-instance-of-simple-class?)
		    (,s-call (toplevel vector-ref)
			     (lexical proc ,s-gensym-proc)
			     (toplevel i-object-class))
		    (toplevel _b_:simple-proc))
	   (,s-call (toplevel _i_call-proc)
		    (lexical proc ,s-gensym-proc)
		    (,s-call (toplevel check-arglist-type)
			     (lexical proc ,s-gensym-proc)
			     (lexical args ,s-gensym-args)
			     (const ()))
		    (lexical static-types ,s-gensym-static))
	   (,s-call (toplevel _i_call-proc)
		    (lexical proc ,s-gensym-proc)
		    (lexical args ,s-gensym-args)
		    (lexical static-types ,s-gensym-static))))))

	   
(define (tc-tree-il-abstract-proc-appl linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (let ((to-type (get-entity-type (hfield-ref repr 'proc)))
	(binder (get-binder-for-tc linker)))
    (strong-assert (is-t-instance? binder to-type tmt-procedure))
    (let* ((args (hfield-ref repr 'arglist))
	   (t-args (map (lambda (arg)
			  (theme-target-tree-il-compile linker arg))
			args))
	   (proc (hfield-ref repr 'proc))
	   (s-call (tree-il-get-call-keyword linker))
	   (result
	    ;; The following test is an optimization.
	    ;; It has probably no effect with abstract procedure applications.
	    (if (and
		 (hrecord-is-instance? proc <expr-constructor>)
		 (let ((to-class (hfield-ref proc 'clas)))
		   (and (not-null? to-class)
			(is-t-instance? binder to-class tpc-pair))))
		`(,s-call (toplevel cons) ,@t-args)
		(let* ((t-proc (theme-target-tree-il-compile linker proc))
		       ;; (static-arg-types
		       ;; (map (lambda (arg) (hfield-ref arg 'type)) args))
		       (comp (lambda (rexpr)
			       (theme-target-tree-il-compile linker rexpr)))
		       ;; (t-static-arg-types (map* comp static-arg-types)))
		       (static-arg-types (hfield-ref repr 'static-arg-types))
		       ;; static-arg-types may be a single variable
		       ;; because of optimization.
		       (t-static
			(if (list? static-arg-types)
			    (let ((t (map* comp static-arg-types)))
			      `(,s-call (toplevel list) ,@t))
			    (comp static-arg-types))))
		  (if (and (not (hfield-ref repr 'runtime-arglist-typecheck?))
			   (and-map? entity-type-dispatched? args))
		      `(,s-call (toplevel _i_call-proc)
				,t-proc
				(,s-call (toplevel list) ,@t-args)
				,t-static)
		      (tc-tree-il-checked-abst-proc-appl
		       linker t-proc t-args t-static))))))
      result)))


(define (tc-tree-il-generic-proc-appl linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <proc-appl>))
  (assert (is-tc-gen-proc?
	   (get-entity-type (hfield-ref repr 'proc))))
  (let* ((t-proc (theme-target-tree-il-compile linker (hfield-ref repr 'proc)))
	 (t-arglist
	  (map* (lambda (repr-arg)
		  (theme-target-tree-il-compile linker repr-arg))
		(hfield-ref repr 'arglist)))
	 (s-call (tree-il-get-call-keyword linker))
	 (t-expr
	 `(,s-call (toplevel _i_call-generic-proc)
		   ,t-proc
		   (,s-call (toplevel list)
			    ,@t-arglist))))
    ;; (if (and (entity-type-dispatched? repr)
    ;; 	     (not (linker-entity-is-none? linker (get-entity-type repr))))
    ;; 	(let ((t-type-expr (theme-target-tree-il-compile
    ;; 			    linker (get-entity-type repr))))
    ;; 	  (tc-tree-il-generate-type-check linker t-expr t-type-expr))
    ;; 	t-expr)))
    t-expr))


(define (tc-tree-il-proc-appl linker repr)
  (let* ((binder (get-binder-for-tc linker))
	 (type (get-entity-type (hfield-ref repr 'proc)))
	 (result
	  (cond
	   ((and
	     (is-pure-entity? (hfield-ref repr 'proc))
	     (is-apply-proc? (hfield-ref repr 'proc)))
	    (tc-tree-il-apply-expr linker repr))
	   ((null? type)
	    (tc-tree-il-abstract-proc-appl linker repr))
	   ((is-t-instance? binder type tpc-simple-proc)
	    (tc-tree-il-simple-proc-appl linker repr))
	   ((is-t-instance? binder type tpc-param-proc)
	    (tc-tree-il-param-proc-appl linker repr))
	   ((is-t-instance? binder type tmc-gen-proc)
	    (tc-tree-il-generic-proc-appl linker repr))
	   ((is-t-instance? binder type tmt-procedure)
	    (tc-tree-il-abstract-proc-appl linker repr))
	   (else
	    (dvar1-set! repr)
	    (raise 'internal-error-in-procedure-application)))))
    result))


(define (tc-tree-il-proc-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (tc-tree-il-compile-proc-expr linker repr '()))


(define (tc-tree-il-param-proc-body linker repr body l-tvars s-name)
  (assert (hrecord-is-instance? linker <linker>))
  (assert
   (or (hrecord-is-instance? body <procedure-expression>)
       (hrecord-is-instance? body <prim-proc-ref>)
       (hrecord-is-instance? body <checked-prim-proc>)))
  (assert (list? l-tvars))
  (cond
   ((hrecord-is-instance? body <procedure-expression>)
    (tc-tree-il-compile-param-proc-expr linker repr body l-tvars s-name))
   ;; Should we remove the following?
   ((hrecord-is-instance? body <prim-proc-ref>)
    (tc-tree-il-compile-prim-proc-ref linker body #t l-tvars))
   ((hrecord-is-instance? body <checked-prim-proc>)
    (tc-tree-il-compile-checked-prim-proc linker body #t l-tvars))
   (else
    ;; We should never arrive here.
    (raise 'internal-error-2))))


(define (tc-tree-il-param-proc-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-proc-expr>))
  (let ((inside-param-proc-old? (hfield-ref linker 'tcomp-inside-param-proc?)))
    (hfield-set! linker 'tcomp-inside-param-proc? #t)
    (let* ((to-type (get-entity-type repr))
	   (vcomp (lambda (argvar)
		    (get-target-var-name linker
					 (hfield-ref argvar 'address))))
	   (l-params (hfield-ref repr 'type-variables))
	   (t-type (theme-target-tree-il-compile linker to-type))
	   (to (hfield-ref repr 'to-value))
	   (s-name (if (not-null? to) (tno-field-ref to 's-name) '()))
	   (t-proc-body (tc-tree-il-param-proc-body
			 linker repr (hfield-ref repr 'body) l-params s-name))
	   (binder (get-binder-for-tc linker))
	   (s-call (tree-il-get-call-keyword linker)))
      (assert (is-t-instance? binder to-type tpc-param-proc))
      (hfield-set! linker 'tcomp-inside-param-proc? inside-param-proc-old?)
      `(,s-call (toplevel _i_make-param-proc)
		,t-type
		,t-proc-body
		(const ,s-name)))))


(define (tc-tree-il-if linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <if-form>))
  (let* ((condition (hfield-ref repr 'condition))
	 (then-expr (hfield-ref repr 'then-expr))
	 (else-expr (hfield-ref repr 'else-expr))
	 (comp (lambda (repr1) (theme-target-tree-il-compile linker repr1)))
	 (t-condition
	  (if (or (entity-type-dispatched? condition)
		  (not (hfield-ref repr 'boolean-cond?)))
	      (comp condition)
	      (tc-tree-il-generate-type-check linker
					      (comp condition)
					      (comp tc-boolean)))))
    (cond
     ((equal? t-condition '(const #t)) (comp then-expr))
     ((equal? t-condition '(const #f)) (comp else-expr))
     (else
      `(if ,t-condition ,(comp then-expr) ,(comp else-expr))))))


;; HUOM: Jos paluuarvo on tyhjä, niin
;; semantiikka voi poiketa Schemen do-lauseesta
;; vastaavassa tapauksessa.
(define (tc-tree-il-until linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <until-form>))
  (let ((condition (hfield-ref repr 'condition))
	(result (hfield-ref repr 'result))
	(body (hfield-ref repr 'body))
	(comp (lambda (repr1) (theme-target-tree-il-compile linker repr1))))
    ;; <empty-expression> puuttuville arvoille
    ;; ehto ei saa puuttua
    (assert (not-null? condition))
    (assert (not (is-empty-expr? condition)))
    (assert (not-null? result))
    (assert (not-null? body))
    (let* ((t-condition
	    (if (entity-type-dispatched? condition)
		(comp condition)
		(tc-tree-il-generate-type-check linker (comp condition)
						(comp tc-boolean))))
	   (t-result (comp result))
	   (t-body (if (not (is-empty-expr? body)) (comp body) '()))
	   (addr-loop (linker-alloc-loc linker 'loop #f))
	   (s-gensym-loop (get-target-var-name linker addr-loop))
	   (s-call (tree-il-get-call-keyword linker))
	   (s-seq (tree-il-get-seq-keyword linker)))
     `(letrec (loop)
	(,s-gensym-loop)
	((lambda ((name . loop))
	   (lambda-case
	    ((() #f #f #f () ())
	     (if ,t-condition
		 ,t-result
		 (,s-seq
		  ,t-body
		  (,s-call (lexical loop ,s-gensym-loop))))))))
	(,s-call (lexical loop ,s-gensym-loop))))))


(define (tc-tree-il-compound linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <compound-expression>))
  (let* ((subexprs (hfield-ref repr 'subexprs))
	 (comp (lambda (repr1) (theme-target-tree-il-compile linker repr1)))
	 (t-subexprs (map comp subexprs)))
    (tc-tree-il-compile-sequence linker t-subexprs)))


(define (tc-tree-il-parse-let-variable linker var)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-letvar? var))
  (let* ((variable (cadr var))
	 (type (list-ref var 3))
	 (init-expr (list-ref var 4)))
    (assert (hrecord-is-instance? variable <normal-variable>))
    (assert (hrecord-is-instance? init-expr <entity>))
    (let* ((address (hfield-ref variable 'address))
	   (t-var-name (get-target-var-name linker address))
	   (s-source-name (hfield-ref address 'source-name)))
      (if (hfield-ref linker 'tcomp-inside-param-proc?)
	  (let ((type-check
		 (if (or (null? type)
			 (entity-type-dispatched? init-expr))
		     (theme-target-tree-il-compile linker init-expr)
		     (tc-tree-il-generate-type-check
		      linker
		      (theme-target-tree-il-compile linker init-expr)
		      (theme-target-tree-il-compile linker
						    type)))))
	    (list s-source-name t-var-name type-check))
	  (list
	   s-source-name
	   t-var-name
	   (theme-target-tree-il-compile linker init-expr))))))


(define (tc-tree-il-parse-letrec-variable linker var)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-letvar? var))
  (let ((variable (cadr var))
	(type (list-ref var 3))
	(init-expr (list-ref var 4)))
    (assert (hrecord-is-instance? variable <normal-variable>))
    (assert (hrecord-is-instance? init-expr <entity>))
    (let* ((address (hfield-ref variable 'address))
	   (t-var-name (get-target-var-name linker address))
	   (s-source-name (hfield-ref address 'source-name))
	   (t-init-expr0 (theme-target-tree-il-compile linker init-expr))
	   (t-init-expr (tc-tree-il-letrec-unspecified-check
			 linker t-init-expr0 s-source-name)))
      (if (hfield-ref linker 'tcomp-inside-param-proc?)
	  (let ((type-check
		 (if (entity-type-dispatched? init-expr)
		     t-init-expr
		     (tc-tree-il-generate-type-check
		      linker
		      t-init-expr
		      (theme-target-tree-il-compile linker
						    type)))))
	    (list s-source-name t-var-name type-check))
	  (list
	   s-source-name
	   t-var-name
	   t-init-expr)))))


(define (tc-tree-il-parse-let-variables linker variables rec?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (list? variables))
  (if rec?
      (map (lambda (var) (tc-tree-il-parse-letrec-variable linker var))
	   variables)
      (map (lambda (var) (tc-tree-il-parse-let-variable linker var))
	   variables)))


(define (tc-tree-il-let linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <let-expression>))
  (if gl-test3 (raise 'test-error-3))
  (let ((recursive? (hfield-ref repr 'recursive?))
	(order? (hfield-ref repr 'order?))
	(variables (hfield-ref repr 'variables))
	(body (hfield-ref repr 'body)))
    (let* ((keyword (get-let-keyword recursive? order?))
	   (t-variables (tc-tree-il-parse-let-variables linker variables
							recursive?))
	   (t-body (theme-target-tree-il-compile linker body))
	   (t-names (map car t-variables))
	   (t-gensyms (map cadr t-variables))
	   (t-vals (map caddr t-variables)))
      (list keyword
	    t-names
	    t-gensyms
	    t-vals
	    t-body))))


(define (tc-tree-il-cast linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <cast-expression>))
  (let ((type (get-entity-type repr))
	(value-expr (hfield-ref repr 'value-expr))
	(default-expr (hfield-ref repr 'default-expr)))
    (assert (is-target-object? type))
    (assert (is-entity? value-expr))
    (assert (is-entity? default-expr))
    (let ((result
	   (cond
	    ;; The following check is an optimization.
	    ((is-t-subtype? (get-binder-for-tc linker)
			    (get-entity-type value-expr)
			    type)
	     (theme-target-tree-il-compile linker value-expr))
	    ((hrecord-is-instance? value-expr <variable-reference>)
	     (let* ((t-obj
		     (tc-tree-il-var-ref0
		      linker
		      (hfield-ref (hfield-ref value-expr 'variable)
				  'address)))
		    (t-test (make-instance-test linker t-obj type))
		    (t-default-expr
		     (if (is-empty-expr? default-expr)
			 (let ((s-call (tree-il-get-call-keyword linker)))
			   `(,s-call
			     (toplevel _i_cast-error)
			     ,(theme-target-tree-il-compile linker
							    type)
			     ,t-obj))
			 (theme-target-tree-il-compile
			  linker default-expr))))
	       `(if ,t-test ,t-obj ,t-default-expr)))
	    (else
	     (let* ((addr-obj (linker-alloc-loc linker 'obj #f))
		    (s-gensym-obj (get-target-var-name linker addr-obj))
		    (t-test
		     (make-instance-test linker `(lexical obj ,s-gensym-obj)
					 type))
		    (t-value-expr (theme-target-tree-il-compile
				   linker value-expr))
		    (t-default-expr
		     (if (is-empty-expr? default-expr)
			 (let ((s-call (tree-il-get-call-keyword linker)))
			   `(,s-call
			     (toplevel _i_cast-error)
			     ,(theme-target-tree-il-compile linker
							    type)
			     (lexical obj ,s-gensym-obj)))
			 (theme-target-tree-il-compile
			  linker default-expr))))
	       `(let (obj) (,s-gensym-obj) (,t-value-expr)
		     (if
		      ,t-test
		      (lexical obj ,s-gensym-obj)
		      ,t-default-expr)))))))
      result)))


(define (tc-tree-il-static-cast linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <static-cast-expression>))
  (theme-target-tree-il-compile linker
				(hfield-ref repr 'ent-value)))


(define (tc-tree-il-compile-class-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <class-definition>))
  (let* ((var (hfield-ref repr 'variable))
	 (val (hfield-ref var 'value))
	 (binder (get-binder-for-tc linker)))
    (if (and (is-target-object? val)
	     (is-t-instance? binder val tc-class))
	(let ((tt-constructor (tno-field-ref val 'type-constructor)))
	  (if (null? tt-constructor)
	      (raise 'undefined-constructor)
	      (let* ((s-call (tree-il-get-call-keyword linker))
		     (var-name (get-target-var-name
				linker
				(hfield-ref val 'address)))
		     (t-var-ref
		      (tc-tree-il-var-ref0 linker
					   (hfield-ref val 'address)))
		     (t-super
		      (tno-field-ref val 'cl-superclass))
		     (body
		      (list
		       `(const ,(tno-field-ref val 'str-name))
		       (tc-tree-il-object-fwd linker t-super '() #f)
		       (tc-tree-il-class-field-texprs
			linker
			(tno-field-ref val 'l-fields))
		       `(const ,(tno-field-ref val 'inheritable?))
		       `(const ,(tno-field-ref val 'immutable?))
		       `(const ,(tno-field-ref val 'eq-by-value?))
		       `(const ,(tno-field-ref val 's-ctr-access))))
		     (t-ctr-type
		      (theme-target-tree-il-compile linker tt-constructor))
		     (ctr
		      (tc-tree-il-get-constructor-def linker val t-ctr-type))
		     (x-def
		      (if (hfield-ref repr 'declared?)
			  `(,s-call (toplevel vector-copy-contents-rev)
				    ,t-var-ref
				    (,s-call (toplevel _i_make-class) ,@body))
			  `(define ,var-name
			     (,s-call (toplevel _i_make-class) ,@body))))
		     (x-ctr-type-set
		      `(,s-call (toplevel vector-set!)
				,t-var-ref
				(toplevel i-class-type-constructor)
				,t-ctr-type))
		     (x-ctr-set
		      `(,s-call (toplevel vector-set!)
				,t-var-ref
				(toplevel i-class-proc-constructor)
				,ctr)))
		`(_splice ,x-def ,x-ctr-type-set ,x-ctr-set))))
	(raise 'internal-error-in-class))))


(define (tc-tree-il-class-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <class-definition>))
  (if (var-def-is-used? linker repr)
      (tc-tree-il-compile-class-def linker repr)
      '(void)))


(define (tc-tree-il-field-ref linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <field-ref-expr>))
  (let ((r-object (hfield-ref repr 'object))
	(r-field-name (hfield-ref repr 'field-name)))
    (let ((t-object (theme-target-tree-il-compile linker r-object))
	  (to-type (get-entity-type r-object))
	  (s-call (tree-il-get-call-keyword linker)))
      (cond
       ((and (hfield-ref repr 'const-field-name?)
	     (not-null? to-type))
	(assert (symbol? r-field-name))
	;; Procedure get-field-index raises an exception if the field is
	;; undefined.
	(let ((field-index (get-field-index
			    r-field-name
			    to-type)))
	  (if (and (is-target-object? r-object)
		   (or
		    (hfield-ref r-object 'incomplete?)
		    (eq? (hfield-ref r-object 'al-field-values) #f)))
	      `(,s-call (toplevel check-field-unspecified)
			(,s-call (toplevel vector-ref) ,t-object
				 (const ,field-index))
			(const ,r-field-name))
	      `(,s-call (toplevel vector-ref) ,t-object
			(const ,field-index)))))
       ((symbol? r-field-name)
	`(,s-call (toplevel _i_field-ref)
		  ,t-object
		  (const ,r-field-name)))
       (else
	(let ((t-field-name (theme-target-tree-il-compile linker
							  r-field-name)))
	  `(,s-call (toplevel _i_field-ref)
		    ,t-object
		    ,t-field-name)))))))
       

(define (tc-tree-il-field-set linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <field-set-expr>))
  (let ((r-object (hfield-ref repr 'object))
	(r-field-name (hfield-ref repr 'field-name))
	(r-field-value (hfield-ref repr 'field-value)))
    (let* ((t-object (theme-target-tree-il-compile linker r-object))
	   (t-field-value (theme-target-tree-il-compile linker r-field-value))
	   (to-type (get-entity-type r-object))
	   (s-call (tree-il-get-call-keyword linker))
	   (result
	    (cond
	     ((and (hfield-ref repr 'const-field-name?)
		   (not-null? to-type))
	      ;; Procedures get-field and get-field-index raise an exception
	      ;; if the field is undefined.
	      (if (hfield-ref linker 'tcomp-inside-param-proc?)
		  (let* ((field-index (get-field-index
				       r-field-name
				       to-type))
			 (field (get-field r-field-name to-type))
			 (r-field-type (tno-field-ref field 'type))
			 (t-field-type
			  (theme-target-tree-il-compile linker r-field-type))
			 (t-wrapped-value
			  (if (entity-type-dispatched? r-field-value)
			      t-field-value
			      (tc-tree-il-generate-type-check
			       linker t-field-value t-field-type))))
		    `(,s-call (toplevel vector-set!)
			      ,t-object
			      (const ,field-index)
			      ,t-wrapped-value))
		  (let ((field-index (get-field-index
				      r-field-name
				      to-type)))
		    `(,s-call (toplevel vector-set!)
			      ,t-object
			      (const ,field-index)
			      ,t-field-value))))
	     ((symbol? r-field-name)
	      `(,s-call (toplevel _i_field-set!)
			,t-object
			(const ,r-field-name)
			,t-field-value))
	     (else
	      (let ((t-field-name (theme-target-tree-il-compile
				   linker r-field-name)))
	      `(,s-call (toplevel _i_field-set!)
			,t-object
			,t-field-name
			,t-field-value))))))
      result)))


(define (tc-tree-il-do-compile-param-ltype-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-logical-type-def>))
  (let* ((s-call (tree-il-get-call-keyword linker))
	 (var (hfield-ref repr 'variable))
	 (var-name (get-target-var-name
		    linker
		    (hfield-ref var 'address)))
	 (t-var-ref (tc-tree-il-var-ref0 linker (hfield-ref var 'address)))
	 (str-name (symbol->string (hfield-ref (hfield-ref var 'address)
					       'source-name)))
	 (r-val (hfield-ref repr 'value-expr))
	 (r-tvars (hfield-ref repr 'type-variables))
	 (nr-of-tvars (length r-tvars))
	 (t-val (theme-target-tree-il-compile linker r-val))
	 (l-tvar-names (get-source-names r-tvars))
	 (l-tvar-gensyms (get-gensyms linker r-tvars))
	 (first-number (alloc-tvar-number-range linker nr-of-tvars))
	 (tvar-numbers (get-integer-sequence
			first-number
			nr-of-tvars))
	 (t-tvar-objects
	  (map (lambda (tvar-number)
		 `(,s-call (toplevel make-tvar-object)
			   (const ,tvar-number)))
	       tvar-numbers))
	 (addr-tvar-list (linker-alloc-loc linker 'tvar-list #f))
	 (s-gensym-tvar-list (get-target-var-name linker addr-tvar-list))
	 (t-body
	  `(let (tvar-list) (,s-gensym-tvar-list)
		((,s-call (toplevel list) ,@t-tvar-objects))
		(,s-call (toplevel _i_make-param-ltype)
			 (const ,str-name)
			 (lexical tvar-list ,s-gensym-tvar-list)
			 (,s-call (toplevel apply)
				  (lambda ()
				    (lambda-case ((,l-tvar-names
						   #f #f () ()
						   ,l-tvar-gensyms)
						  ,t-val)))
				  (lexical tvar-list ,s-gensym-tvar-list))
			 (toplevel _b_<object>)
			 (const ,nr-of-tvars)))))
    (if (hfield-ref repr 'declared?)
	`(,s-call (toplevel vector-copy-contents-rev)
		  ,t-var-ref
		  ,t-body)
	`(define ,var-name ,t-body))))


(define (tc-tree-il-param-ltype-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-logical-type-def>))
  (if (var-def-is-used? linker repr)
      (tc-tree-il-do-compile-param-ltype-def linker repr)
      '(void)))


(define (tc-tree-il-param-class-def0 linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-class-definition>))
  (let* ((var (hfield-ref repr 'variable))
	 (val (hfield-ref var 'value))
	 (binder (get-binder-for-tc linker)))
    (let ((result
	   (cond
	    ((and (is-target-object? val)
		  (is-t-instance? binder val tc-class))
	     (let* ((s-call (tree-il-get-call-keyword linker))
		    (var-name (get-target-var-name-for-loc linker var))
		    (r-super
		     (tno-field-ref val 'cl-instance-superclass))
		    (t-super (theme-target-tree-il-compile linker r-super))
		    (t-fields
		     (tc-tree-il-class-field-texprs
		      linker
		      (tno-field-ref val 'l-instance-fields)))
		    (l-tvars (tno-field-ref val 'l-tvars))
		    (l-tvar-names (get-source-names l-tvars))
		    (l-tvar-gensyms (get-gensyms linker l-tvars))
		    (nr-of-tvars (length l-tvars))
		    (first-number (alloc-tvar-number-range linker
							   nr-of-tvars))
		    (tvar-numbers (get-integer-sequence
				   first-number
				   nr-of-tvars))
		    (t-tvar-objects
		     (map (lambda (tvar-number)
			    `(,s-call (toplevel make-tvar-object)
				      (const ,tvar-number)))
			  tvar-numbers)))
	       (let* ((x-super-proc
		       `(lambda ()
			  (lambda-case
			   ((,l-tvar-names #f #f () ()
					   ,l-tvar-gensyms)
			    ,t-super))))
		      (x-fields-proc
		       `(lambda ()
			  (lambda-case
			   ((,l-tvar-names #f #f () ()
					   ,l-tvar-gensyms)
			    ,t-fields))))
		      ;; Variable t-tvar-objects could be factorized
		      ;; in the following.
		      (body
		       (list
			`(const ,(tno-field-ref val 'str-name))
			`(const ,(tno-field-ref val 'i-params))
			`(,s-call (toplevel list) ,@t-tvar-objects)
			`(,s-call ,x-super-proc ,@t-tvar-objects)
			`(,s-call ,x-fields-proc ,@t-tvar-objects)
			`(const ,(tno-field-ref val 'instances-inheritable?))
			`(const ,(tno-field-ref val 'instances-immutable?))
			`(const ,(tno-field-ref val 'instances-eq-by-value?))
			`(const ,(tno-field-ref val 'instance-has-constructor?))
			`(const ,(tno-field-ref val 's-instance-ctr-access)))))
		 (if (hfield-ref repr 'declared?)
		     `(,s-call (toplevel vector-copy-contents-rev)
		       (toplevel ,var-name)
		       (,s-call (toplevel _i_make-param-class) ,@body))
		     `(define ,var-name
		       (,s-call (toplevel _i_make-param-class) ,@body))))))
	    (else (raise 'internal-error-in-class)))))
      result)))


(define (tc-tree-il-param-class-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-class-definition>))
  (if (var-def-is-used? linker repr)
      (tc-tree-il-param-class-def0 linker repr)
      '(void)))


(define (tc-tree-il-constructor linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <expr-constructor>))
  (let* ((clas (hfield-ref repr 'clas))
	 (binder (get-binder-for-tc linker))
	 (s-call (tree-il-get-call-keyword linker)))
    (cond
     ((null? clas)
      (raise 'internal-undefined-class))
     ((is-t-instance? binder clas tpc-pair)
      (let* ((r-type (get-entity-type repr))
	     (c-type (theme-target-tree-il-compile linker r-type)))	
	`(,s-call (toplevel _i_make-procedure)
		  ,c-type
		  cons)))
     (else
      (let ((t-clas (theme-target-tree-il-compile linker clas)))
	`(,s-call (toplevel get-constructor) ,t-clas))))))


(define (tc-tree-il-match-type-clause linker lst-clause t-obj-match-ref)
  (let* ((var (car lst-clause))
	 (has-var? (not-null? var))
	 (s-var-name
	  (if has-var?
	      (hfield-ref (hfield-ref var 'address) 'source-name)
	      '()))
	 (s-var-gensym
	  (if has-var?
	      (get-target-var-name linker (hfield-ref var 'address))
	      '()))
	 (expr-type (cadr lst-clause))
	 (expr-to-eval (caddr lst-clause))
	 (texpr-to-eval (theme-target-tree-il-compile linker expr-to-eval))
	 (opt? (list-ref lst-clause 3)))
    (assert (boolean? opt?))
    (cond
     ((and has-var? (not opt?))
      (list (make-instance-test linker t-obj-match-ref expr-type)
	    `(let (,s-var-name) (,s-var-gensym)
		  (,t-obj-match-ref)
		  ,texpr-to-eval)))
     ((and has-var? opt?)
      `((const #t)
	(let (,s-var-name) (,s-var-gensym)
	     (,t-obj-match-ref)
	     ,texpr-to-eval)))
     ((and (not has-var?) (not opt?))
      (list (make-instance-test linker t-obj-match-ref expr-type)
	    texpr-to-eval))
     ((and (not has-var?) opt?)
      `((const #t) ,texpr-to-eval))
     (else
      ;; We should not arrive here.
      (raise 'internal-error)))))


(define (tc-tree-il-match-type-body linker t-clauses t-else)
  (assert (list? t-clauses))
  (if (null? t-clauses)
      t-else
      (let ((t-first (car t-clauses))
	    (t-rest (cdr t-clauses)))
	(assert (and (list? t-first) (= (length t-first) 2)))
	;; The following test is an optimization.
	(if (equal? (car t-first) '(const #t))
	    (cadr t-first)
	    `(if ,(car t-first)
		 ,(cadr t-first)
		 ,(tc-tree-il-match-type-body linker t-rest t-else))))))


(define (tc-tree-il-match-type linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <match-type-expression>))
  (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))
	 (texpr-to-match (theme-target-tree-il-compile linker expr-to-match))
	 (addr-obj-match (linker-alloc-loc linker 'obj-match #f))
	 (s-gensym-obj-match (get-target-var-name linker addr-obj-match))
	 (t-obj-match-ref (list 'lexical 'obj-match s-gensym-obj-match))
	 (texpr-clauses
	  (map (lambda (lst-repr-clause)
		 (tc-tree-il-match-type-clause linker lst-repr-clause
					       t-obj-match-ref))
	       lst-repr-clauses))
	 (texpr-else
	  (if (and (hfield-ref repr 'strong?)
		   (is-empty-expr? expr-else))
	      (let ((s-call (tree-il-get-call-keyword linker)))
		`(,s-call (toplevel _i_match-type-strong-no-match)))
	      (theme-target-tree-il-compile linker expr-else)))
	 (t-body (tc-tree-il-match-type-body linker texpr-clauses texpr-else)))
    `(let (obj-match) (,s-gensym-obj-match) (,texpr-to-match)
	  ,t-body)))


(define (tc-tree-il-param-proc-instance linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <expr-param-proc-instance>))
  (if (is-known-object? (hfield-ref repr 'param-proc))
      (tc-tree-il-param-proc-instance1 linker repr)
      (tc-tree-il-param-proc-instance-expr linker repr)))


(define (tc-tree-il-param-proc-dispatch linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  ;; Procedure tc-tree-il-param-proc-instance1 works also for
  ;; <expr-param-proc-dispatch>.
  (tc-tree-il-param-proc-instance1 linker repr))


(define (tc-tree-il-gen-proc-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <generic-procedure-definition>))
  (if (var-def-is-used? linker repr)
      (let ((gen-proc-name (symbol->string
			    (hfield-ref
			     (hfield-ref
			      (hfield-ref repr 'variable)
			      'address)
			     'source-name)))
	    (var-name (get-target-var-name
		       linker
		       (hfield-ref (hfield-ref repr 'variable) 'address)))
	    (s-call (tree-il-get-call-keyword linker)))
	(begin
	  `(define ,var-name (,s-call (toplevel make-empty-gen-proc)
				      (const ,gen-proc-name)))))
      '(void)))


(define (tc-tree-il-method-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <method-definition>))
  (let* ((gen-proc (hfield-ref repr 'gen-proc))
	 (procexpr (hfield-ref repr 'procexpr))
	 (addr-gen-proc (hfield-ref gen-proc 'address))
	 (ht-used (hfield-ref linker 'ht-used))
	 (ht-rebound (hfield-ref linker 'ht-rebound)))
    (if (or (not (hfield-ref linker 'strip?))
	    (hfield-ref repr 'include?)
	    (hashq-ref ht-rebound repr)
	    (address-hash-ref ht-used addr-gen-proc))
	(begin
	  (let ((t-gen-proc (theme-target-tree-il-compile linker gen-proc)))
	    (let ((t-procexpr (theme-target-tree-il-compile linker procexpr))
		  (s-call (tree-il-get-call-keyword linker))
		  (static? (hfield-ref repr 'static-method?)))
	      (assert (boolean? static?))
	      (if (hfield-ref repr 'declared?)
		  (let ((old-address (hfield-ref repr 'old-address)))
		    (assert (not-null? old-address))
		    (let ((old-var-name
			   (get-target-var-name linker old-address)))
		      `(_splice (set! (toplevel ,old-var-name) ,t-procexpr)
				(,s-call (toplevel _i_add-method!)
					 ,t-gen-proc ,t-procexpr
					 (const ,static?)))))
		  `(,s-call (toplevel _i_add-method!)
			    ,t-gen-proc ,t-procexpr (const ,static?))))))
	'(void))))


(define (tc-tree-il-method-decl linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <method-declaration>))
  (let* ((method (hfield-ref repr 'method))
	 (address (hfield-ref method 'address))
	 (gen-proc (hfield-ref repr 'gen-proc))
	 (addr-gen-proc (hfield-ref gen-proc 'address))
	 (ht-used (hfield-ref linker 'ht-used))
	 (ht-used-decls (hfield-ref linker 'ht-used-decls))
	 (ht-rebound (hfield-ref linker 'ht-rebound)))
    (if (or (not (hfield-ref linker 'strip?))
	    (hfield-ref repr 'include?)
	    (hashq-ref ht-rebound repr)
	    (address-hash-ref ht-used addr-gen-proc)
	    (address-hash-ref ht-used-decls address))
	(let ((var-name (get-target-var-name linker address)))
	  `(define ,var-name (const ())))
	'(void))))


(define (tc-tree-il-generic-proc-dispatch linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <generic-proc-dispatch>))
  (let* ((proc-type (get-entity-type repr))
	 (result-type (tno-field-ref proc-type 'type-result))
	 (appl-pure? (hfield-ref repr 'appl-pure?))
	 (appl-always-returns? (hfield-ref repr 'appl-always-returns?))
	 (appl-never-returns? (hfield-ref repr 'appl-never-returns?))
	 (t-gen-proc (theme-target-tree-il-compile
		      linker (hfield-ref repr 'generic-proc)))
	 (l-arg-types
	  (map* (lambda (repr-arg)
		  (theme-target-tree-il-compile linker repr-arg))
		(hfield-ref repr 'arg-types)))
	 (t-result-type
	  (if (and (entity-type-dispatched? repr)
		   (not (linker-entity-is-none? linker result-type)))
	      (theme-target-tree-il-compile linker result-type)
	      '(const ())))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_dispatch-generic-proc)
	      ,t-gen-proc
	      ,t-result-type
	      (,s-call (toplevel list)
		       ,@l-arg-types)
	      (const ,appl-pure?)
	      (const ,appl-always-returns?)
	      (const ,appl-never-returns?))))
    

(define (tc-tree-il-prim-class-def0 linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-class-def>))
  (let* ((name (hfield-ref repr 'name))
	 (target-name (hfield-ref repr 'target-name))
	 (goops? (hfield-ref repr 'goops?))
	 (r-superclass (hfield-ref repr 'superclass))
	 (t-superclass (tc-tree-il-object-fwd linker
					      r-superclass '() #f))
	 (inh? (hfield-ref repr 'inh?))
	 (imm? (hfield-ref repr 'imm?))
	 (ebv? (hfield-ref repr 'ebv?))
	 (t-member-var-name (hfield-ref repr 'member-target-name))
	 (t-equal-var-name (hfield-ref repr 'equal-target-name))
	 (t-equal-objects-var-name (hfield-ref repr 'equal-objects-target-name))
	 (t-equal-contents-var-name
	  (hfield-ref repr 'equal-contents-target-name))
	 (t-var-name
	  (get-target-var-name
	   linker (hfield-ref (hfield-ref repr 'variable) 'address)))
	 (s-call (tree-il-get-call-keyword linker))
	 ;; Custom primitive classes are always declared forward.
	 (t-creation
	  (if goops?
	      `(,s-call (toplevel vector-copy-contents-rev)
			(toplevel ,t-var-name)
			(,s-call (toplevel create-goops-class)
				 (const ,name)
				 ,t-superclass
				 (const ,inh?)
				 (const ,imm?)
				 (const ,ebv?)))
	      `(,s-call (toplevel vector-copy-contents-rev)
			(toplevel ,t-var-name)
			(,s-call (toplevel make-custom-prim-class)
				 (const ,name)
				 (const ,imm?)
				 (const ,ebv?)))))
	 (t-notify
	  (if goops?
	      `(,s-call (toplevel notify-goops-class)
			(toplevel ,t-var-name)
			(toplevel ,target-name)
			(toplevel ,t-equal-var-name)
			(toplevel ,t-equal-contents-var-name))
	      `(,s-call (toplevel notify-custom-prim-class)
			(toplevel ,t-var-name)
			(toplevel ,t-member-var-name)
			(toplevel ,t-equal-var-name)
			(toplevel ,t-equal-objects-var-name)
			(toplevel ,t-equal-contents-var-name))))
	 (t-final
	  (list '_splice
		t-creation 
		t-notify)))
    t-final))


(define (tc-tree-il-prim-class-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-class-def>))
  (if (var-def-is-used? linker repr)
      (tc-tree-il-prim-class-def0 linker repr)
      '(void)))


(define (tc-tree-il-zero linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <zero-expr>))
  (let* ((r-clas (hfield-ref repr 'clas))
	 (t-clas (theme-target-tree-il-compile linker r-clas))
	 (s-call (tree-il-get-call-keyword linker)))
    (if (is-t-instance? (get-binder-for-tc linker)
			r-clas
			tc-class)
	(let ((zero-value (tno-field-ref r-clas 'x-zero-value)))
	  (cond
	   ((tno-field-ref r-clas 'zero-prim?)
	    (assert (is-primitive-value? zero-value))
	    `(const ,zero-value))
	   ((is-address? zero-value)
	    (tc-tree-il-var-ref0 linker zero-value))
	   (else
	    `(,s-call (toplevel vector-ref)
		      ,t-clas
		      (toplevel i-class-zero-value)))))
	`(,s-call (toplevel get-zero) ,t-clas))))


(define (tc-tree-il-zero-setting linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <zero-setting-expr>))
  (let* ((var-cl (hfield-ref repr 'var-class))
	 (r-zero-proc (hfield-ref repr 'zero-proc))
	 (param? (hfield-ref repr 'param?))
	 (t-cl (tc-tree-il-var-ref0 linker (hfield-ref var-cl 'address)))
	 (t-zero-proc (theme-target-tree-il-compile linker r-zero-proc))
	 (s-call (tree-il-get-call-keyword linker)))
    (if param?
	`(_splice
	  (,s-call (toplevel vector-set!)
		   ,t-cl
		   (toplevel i-param-class-instance-has-zero)
		   (const #t))
	  (,s-call (toplevel vector-set!)
		   ,t-cl
		   (toplevel i-param-class-instance-zero-proc)
		   ,t-zero-proc))
	`(_splice
	  (,s-call (toplevel vector-set!)
		   ,t-cl
		   (toplevel i-class-has-zero)
		   (const #t))
	  (,s-call (toplevel vector-set!)
		   ,t-cl
		   (toplevel i-class-zero-value)
		   (,s-call (toplevel _i_call-proc)
			    ,t-zero-proc
			    (const ())
			    (const ())))))))


(define (tc-tree-il-signature-member linker r-member)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-signature-member? (get-binder-for-tc linker) r-member))
  (let ((obj-target (car r-member))
	(r-type (cdr r-member)))
    (let ((p-target (theme-target-tree-il-compile linker obj-target))
	  (p-type (theme-target-tree-il-compile linker r-type))
	  (s-call (tree-il-get-call-keyword linker)))
      `(,s-call (toplevel cons) ,p-target ,p-type))))


(define (tc-tree-il-signature-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <signature-definition>))
  (let* ((var (hfield-ref repr 'variable))
	 (to (hfield-ref var 'value)))
    (assert (and (not-null? to)
		 (target-type=? (get-entity-type to)
				tc-signature)))
    (let* ((r-members (tno-field-ref to 'l-members))
	   (p-members (map* (lambda (r-member)
			      (tc-tree-il-signature-member linker r-member))
			    r-members))
	   (s-gensym-var
	    (get-target-var-name linker (hfield-ref var 'address)))
	   (declared? (hfield-ref repr 'declared?))
	   (def-kw (if declared? 'set! 'define))
	   (s-call (tree-il-get-call-keyword linker)))
      (if (hfield-ref repr 'declared?)
	  `(set! (toplevel ,s-gensym-var)
		 (,s-call (toplevel make-signature)
			  (,s-call (toplevel list)
				   ,@p-members)))
	  `(define ,s-gensym-var
	     (,s-call (toplevel make-signature)
		      (,s-call (toplevel list)
			       ,@p-members)))))))


(define (tc-tree-il-param-signature0 linker to)
  (let* ((l-tvars (tno-field-ref to 'l-tvars))
	 (nr-of-tvars (length l-tvars))
	 (l-tvar-names (get-source-names l-tvars))
	 (l-tvar-gensyms (get-gensyms linker l-tvars))
	 (first-number (alloc-tvar-number-range linker
						nr-of-tvars))
	 (tvar-numbers (get-integer-sequence
			first-number
			nr-of-tvars))
	 (s-call (tree-il-get-call-keyword linker))
	 (t-tvar-objects
	  (map (lambda (tvar-number)
		 `(,s-call (toplevel make-tvar-object)
			   (const ,tvar-number)))
	       tvar-numbers))
	 (r-members (tno-field-ref to 'l-members))
	 (t-members (map* (lambda (r-member)
			    (tc-tree-il-signature-member linker r-member))
			  r-members))
	 (x-sig-lambda
	  `(lambda ()
	     (lambda-case ((,l-tvar-names #f #f () () ,l-tvar-gensyms)
			   (,s-call (toplevel list)
				    ,@t-members))))))
    `(,s-call (toplevel make-param-signature)
	      (,s-call (toplevel list) ,@t-tvar-objects)
	      (,s-call ,x-sig-lambda
		       ,@t-tvar-objects))))


(define (tc-tree-il-param-signature-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-signature-definition>))
  (let* ((var (hfield-ref repr 'variable))
	 (var-name (get-target-var-name linker (hfield-ref var 'address)))
	 (to (hfield-ref var 'value))
	 (t-expr (tc-tree-il-param-signature0 linker to)))
    (if (hfield-ref repr 'declared?)
	`(set! (toplevel ,var-name) ,t-expr)
	`(define ,var-name ,t-expr))))


(define (tc-tree-il-force-pure-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <force-pure-expr>))
  (theme-target-tree-il-compile-fwd linker
				    (hfield-ref repr 'repr-component)))


(define (tc-tree-il-assertion linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <assertion-expr>))
  (if (or (hfield-ref linker 'all-assertions?)
	  (hfield-ref repr 'strong?))
      (let ((t-condition
	     (theme-target-tree-il-compile linker
					   (hfield-ref repr 'condition)))
	    (condition-source-expr (hfield-ref repr 'condition-source-expr))
	    (s-call (tree-il-get-call-keyword linker)))
	`(if (,s-call (toplevel not) ,t-condition)
	     (,s-call (toplevel _i_raise-assertion-failed)
		      (const ,condition-source-expr))
	     (void)))
      '(void)))


(define (tc-tree-il-debug-output linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <debug-output-expr>))
  (let ((x-message (hfield-ref repr 'x-message))
	(s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel theme-debug-print) (const ,x-message))))


(define (tc-tree-il-empty linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <empty-expression>))
  '(void))


(define (tc-tree-il-do-nothing linker repr) #f)


(define (tc-tree-il-error linker repr)
  ;; TBD: Move the error output to theme-d-linker-errors
  (write-error-info "Unknown expression type")
  (write-error-info (hrecord-type-name-of repr))
  (raise 'unknown-expr-type))


;; Note: Type loops are not handled here.
(define tc-tree-il-proc-table
  (list
   (cons <generic-procedure-definition> tc-tree-il-gen-proc-def)
   (cons <variable-definition> tc-tree-il-var-def)
   (cons <set-expression> tc-tree-il-set-expr)
   (cons <variable-reference> tc-tree-il-var-ref)
   (cons <prim-proc-ref> tc-tree-il-prim-proc-ref)
   (cons <checked-prim-proc> tc-tree-il-checked-prim-proc)
   (cons <prim-class-def> tc-tree-il-prim-class-def)
   (cons <class-definition> tc-tree-il-class-def)
   (cons <param-class-definition> tc-tree-il-param-class-def)
   (cons <expr-constructor> tc-tree-il-constructor)
   (cons <zero-expr> tc-tree-il-zero)
   (cons <field-ref-expr> tc-tree-il-field-ref)
   (cons <field-set-expr> tc-tree-il-field-set)
   (cons <proc-appl> tc-tree-il-proc-appl)
   (cons <procedure-expression> tc-tree-il-proc-expr)
   (cons <method-definition> tc-tree-il-method-def)
   (cons <method-declaration> tc-tree-il-method-decl)
   (cons <let-expression> tc-tree-il-let)
   (cons <cast-expression> tc-tree-il-cast)
   (cons <static-cast-expression> tc-tree-il-static-cast)
   (cons <match-type-expression> tc-tree-il-match-type)
   (cons <if-form> tc-tree-il-if)
   (cons <compound-expression> tc-tree-il-compound)
   (cons <until-form> tc-tree-il-until)
   (cons <forward-declaration> tc-tree-il-fw-decl)
   (cons <param-logical-type-def> tc-tree-il-param-ltype-def)
   (cons <param-proc-expr> tc-tree-il-param-proc-expr)
   (cons <expr-param-proc-instance> tc-tree-il-param-proc-instance)
   (cons <expr-param-proc-dispatch> tc-tree-il-param-proc-dispatch)
   (cons <generic-proc-dispatch> tc-tree-il-generic-proc-dispatch)
   (cons <signature-definition> tc-tree-il-signature-def)
   (cons <param-signature-definition> tc-tree-il-param-signature-def)
   (cons <zero-setting-expr> tc-tree-il-zero-setting)
   (cons <force-pure-expr> tc-tree-il-force-pure-expr)
   (cons <assertion-expr> tc-tree-il-assertion)
   (cons <debug-output-expr> tc-tree-il-debug-output)
   (cons <empty-expression> tc-tree-il-empty)
   (cons <normal-variable> tc-tree-il-error)
   (cons <target-object> tc-tree-il-error)))


(define (tc-tree-il-object-with-address linker to)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to))
  (let ((address (hfield-ref to 'address)))
    (assert (not-null? address))
    (tc-tree-il-var-ref0 linker address)))


(define (tc-tree-il-pair-class linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (and (is-target-object? to) (is-tc-pair? to)))
  (let* ((tvv (tno-field-ref to 'l-tvar-values))
	 (tt-first (tc-tree-il-object-fwd linker (car tvv)
					  lst-visited #f))
	 (tt-second (tc-tree-il-object-fwd linker (cadr tvv)
					   lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    (if (contains-type-modifiers? to)
	`(,s-call (toplevel _i_get-pair-class-general1)
		  (,s-call (toplevel list) ,tt-first ,tt-second))
	`(,s-call (toplevel _i_get-pair-class-general)
		  (,s-call (toplevel list) ,tt-first ,tt-second)))))


(define (tc-tree-il-pair linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (and (is-target-object? to) (is-tc-pair? (get-entity-type to))))
  (let* ((first (tc-tree-il-object-fwd linker (tno-field-ref to 'first)
				       lst-visited #f))
	 (second (tc-tree-il-object-fwd linker (tno-field-ref to 'second)
					lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel cons) ,first ,second)))


(define (tc-tree-il-union-type linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (and (is-target-object? to) (is-tt-union? to)))
  (let* ((r-member-types (tno-field-ref to 'l-member-types))
	 (p-member-types
	  (map* (lambda (to-member)
		  (tc-tree-il-object-fwd linker to-member lst-visited #f))
		r-member-types))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-concrete-union)
	      (,s-call (toplevel list) ,@p-member-types))))


(define (tc-tree-il-rest linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-rest? repr))
  (let* ((component (tno-field-ref repr 'type-component))
	 (compiled-component (tc-tree-il-object-fwd linker component
						    lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-rest-expression) ,compiled-component)))


(define (tc-tree-il-type-list linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-list? repr))
  (let* ((subtypes (tno-field-ref repr 'l-subtypes))
	 (compiled-subexprs
	  (map
	   (lambda (subrepr)
	     (tc-tree-il-object-fwd linker subrepr lst-visited #f))
	   subtypes))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel create-type-list)
	      (,s-call (toplevel list) ,@compiled-subexprs))))


(define (tc-tree-il-splice linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-splice? repr))
  (let* ((component (tno-field-ref repr 'type-component))
	 (compiled-component (tc-tree-il-object-fwd
			      linker component lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-splice-expression) ,compiled-component)))


(define (tc-tree-il-type-loop linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-loop? repr))
  (let ((s-iter-var-name (hfield-ref (hfield-ref (tno-field-ref repr 'tvar)
						 'address)
				     'source-name))
	(s-gensym-iter-var (get-target-var-name
			    linker
			    (hfield-ref (tno-field-ref repr 'tvar)
					'address)))
	(t-subtypes (tc-tree-il-object-fwd
		     linker
		     (tno-field-ref repr 'x-subtypes)
		     lst-visited
		     #f))
	(t-iter-expr (tc-tree-il-object-fwd
		      linker
		      (tno-field-ref repr 'x-iter-expr)
		      lst-visited
		      #f))
	(s-call (tree-il-get-call-keyword linker)))
    (let* ((tvar-number (alloc-tvar-number-range linker 1))
	   (t-iter-var-object `(,s-call (toplevel make-tvar-object)
					(const ,tvar-number))))
      ;; We replace the iteration type variable with corresponding
      ;; type variable object.
      `(,s-call (toplevel construct-type-loop-repr1)
		(,s-call (toplevel vector-ref)
			 (toplevel gl-rte)
			 (toplevel i-rte-arg-xlat))
		,t-iter-var-object
		,t-subtypes
		(,s-call
		 (lambda () (lambda-case (((,s-iter-var-name) #f #f () ()
					   (,s-gensym-iter-var))
					  ,t-iter-expr)))
		 ,t-iter-var-object)))))


(define (tc-tree-il-type-join linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-join? repr))
  (let* ((subtypes (tno-field-ref repr 'l-subtypes))
	 (compiled-subtypes
	  (map
	   (lambda (subrepr)
	     (tc-tree-il-object-fwd linker subrepr lst-visited #f))
	   subtypes))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_make-type-join) ,@compiled-subtypes)))


(define (tc-tree-il-general-proc-type linker repr lst-visited simple?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (or (is-tt-procedure? repr)
	      (is-tc-simple-proc? repr)))
  (assert (boolean? simple?))
  (let* ((arg-list-type (tno-field-ref repr 'type-arglist))
	 (result-type (tno-field-ref repr 'type-result))
	 (pure-proc? (tno-field-ref repr 'pure-proc?))
	 (appl-always-returns? (tno-field-ref repr 'appl-always-returns?))
	 (appl-never-returns? (tno-field-ref repr 'appl-never-returns?))
	 (static-method? (tno-field-ref repr 'static-method?))
	 (comp (lambda (repr1)
		 (tc-tree-il-object-fwd
		  linker
		  repr1
		  lst-visited
		  #f)))
	 (internal-proc-name '_i_make-procedure-type)
	 (s-call (tree-il-get-call-keyword linker)))
    ;; We use <none> for a missing value.
    (assert (not-null? result-type))
    (list s-call `(toplevel ,internal-proc-name)
	  (comp arg-list-type)
	  (comp result-type)
	  `(const ,pure-proc?)
	  `(const ,appl-always-returns?)
	  `(const ,appl-never-returns?)
	  `(const ,static-method?)
	  `(const ,simple?))))


(define (tc-tree-il-cycle linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to))
  ;; Cycles use lexical variables.
  (let* ((address (linker-alloc-loc linker 'cycle-3 #f))
	 (t-var-name (get-target-var-name linker address))
	 (t-var-ref (list 'lexical 'cycle-3 t-var-name))
	 (r-type (get-entity-type to))
	 (t-type (tc-tree-il-object-fwd linker (get-entity-type to)
					lst-visited #f))
	 (lst-old-encl (hfield-ref linker 'lst-enclosing-cycles)))
    (hfield-set! linker 'lst-enclosing-cycles
		 (cons (cons to address)
		       (hfield-ref linker 'lst-enclosing-cycles)))
    (let ((p-contents (tc-tree-il-object-fwd linker to lst-visited
					     #t))
	  (binder (get-binder-for-tc linker))
	  (s-call (tree-il-get-call-keyword linker)))
      (hfield-set! linker 'lst-enclosing-cycles lst-old-encl)
      ;; We should also check that r-type is the exact class of the cycle
      ;; contents.
      (if (is-t-instance? binder r-type tc-class)
	  (let ((i-elements (+ (length (tno-field-ref r-type 'l-all-fields))
			       1))
		(texpr-body
		 (tc-tree-il-compile-sequence
		  linker
		  `((,s-call (toplevel vector-set!)
			     ,t-var-ref
			     (toplevel i-object-class)
			     ,t-type)
		    (,s-call (toplevel vector-copy-contents-rev)
			     ,t-var-ref
			     ,p-contents)
		    ,t-var-ref))))
	    `(let (cycle-3) (,t-var-name)
		  ((,s-call (toplevel make-vector)
			    (const ,i-elements)
			    (const ())))
		  ,texpr-body))
	  `(let (cycle-3) (,t-var-name)
		((,s-call (toplevel make-singleton) (const ())))
		(begin
		  (,s-call (toplevel vector-set!)
			   ,t-var-ref
			   (toplevel i-singleton-element)
			   ,p-contents)
		  ,t-var-ref))))))


(define (tc-tree-il-param-proc-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-param-proc? repr))
  (let* ((type-vars (tno-field-ref repr 'l-tvars))
	 (inst-type (tno-field-ref repr 'type-contents))
	 (l-source-names (get-source-names type-vars))
	 (l-gensyms (get-gensyms linker type-vars))
	 (nr-of-tvars (length type-vars))
	 (first-number (alloc-tvar-number-range linker nr-of-tvars))
	 (tvar-numbers (get-integer-sequence
			first-number
			nr-of-tvars))
	 (s-call (tree-il-get-call-keyword linker))
	 (t-tvar-objects
	  (map (lambda (tvar-number)
		 `(,s-call (toplevel make-tvar-object)
			   (const ,tvar-number)))
	       tvar-numbers))
	 (t-inst-type (tc-tree-il-object-fwd linker inst-type lst-visited #f)))
    ;; Variable t-tvar-objects could be probably optimized so that it is
    ;; computed only once in the following.
    `(,s-call (toplevel _i_make-param-proc-class)
	      (const ,first-number)
	      (const ,nr-of-tvars)
	      (,s-call (toplevel list) ,@t-tvar-objects)
	      (,s-call
	       (lambda () (lambda-case ((,l-source-names #f #f () ()
							 ,l-gensyms)
					,t-inst-type)))
	       ,@t-tvar-objects))))


(define (tc-tree-il-abstract-param-type-inst linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to))
  (let* ((r-param-type (tno-field-ref to 'type-meta))
	 (p-param-type (tc-tree-il-object-fwd linker r-param-type
					      lst-visited #f))
	 (r-args (tno-field-ref to 'l-type-args))
	 (p-args (map (lambda (repr) (tc-tree-il-object-fwd
				      linker repr lst-visited #f))
		      r-args))
	 (decl-proc
	  (cond
	   ((is-t-param-class? r-param-type)
	    '_i_get-param-class-inst1)
	   ((is-t-param-logical-type? r-param-type)
	    '_i_get-param-ltype-inst1)
	   (else (raise 'internal-error-3))))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel ,decl-proc)
	      ,p-param-type
	      (,s-call (toplevel list) ,@p-args))))


(define (tc-tree-il-vector-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-vector? repr))
  (let* ((member-type-repr (car (tno-field-ref repr 'l-tvar-values)))
	 (member-type-texpr (tc-tree-il-object-fwd linker member-type-repr
						   lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_construct-vector) ,member-type-texpr)))


(define (tc-tree-il-mutable-vector-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-mutable-vector? repr))
  (let* ((member-type-repr (car (tno-field-ref repr 'l-tvar-values)))
	 (member-type-texpr (tc-tree-il-object-fwd linker member-type-repr
						   lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_construct-mutable-vector) ,member-type-texpr)))


(define (tc-tree-il-value-vector-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-value-vector? repr))
  (let* ((member-type-repr (car (tno-field-ref repr 'l-tvar-values)))
	 (member-type-texpr (tc-tree-il-object-fwd linker member-type-repr
						   lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_construct-value-vector) ,member-type-texpr)))


(define (tc-tree-il-mutable-value-vector-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-mutable-value-vector? repr))
  (let* ((member-type-repr (car (tno-field-ref repr 'l-tvar-values)))
	 (member-type-texpr (tc-tree-il-object-fwd linker member-type-repr
						   lst-visited #f))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel _i_construct-mutable-value-vector)
	      ,member-type-texpr)))


(define (tc-tree-il-param-class-instance linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-param-class-instance? repr))
  (let ((result
	 (let* ((r-param-class (get-entity-type repr))
		(t-param-class (tc-tree-il-object-fwd linker r-param-class
						      lst-visited #f))
		(r-params (tno-field-ref repr 'l-tvar-values))
		(t-params
		 (map* (lambda (param)
			 (tc-tree-il-object-fwd linker param lst-visited #f))
		       r-params))
		(s-call (tree-il-get-call-keyword linker)))
	   ;; Formerly we compiled the value expression of the
	   ;; parametrized logical type if it was available.
	   `(,s-call (toplevel _i_get-concrete-param-class-inst)
		     ,t-param-class
		     (,s-call (toplevel list) ,@t-params)))))
    result))


(define (tc-tree-il-signature linker to l-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-signature? to))
  (let* ((r-members (tno-field-ref to 'l-members))
	 (p-members (map* (lambda (r-member)
			    (tc-tree-il-signature-member linker r-member))
			  r-members))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel make-signature)
	      (,s-call (toplevel list) ,@p-members))))


(define (tc-tree-il-param-signature linker to l-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-param-signature? to))
  (tc-tree-il-param-signature0 linker to))


(define (tc-tree-il-gen-proc-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-gen-proc? repr))
  (let* ((comp (lambda (rexpr)
		 (tc-tree-il-object-fwd linker rexpr lst-visited #f)))
	 (r-method-classes (tno-field-ref repr 'l-method-classes))
	 (t-method-classes (map* comp r-method-classes))
	 (s-call (tree-il-get-call-keyword linker)))
    `(,s-call (toplevel make-gen-proc-class)
	      (,s-call (toplevel list) ,@t-method-classes))))


(define (tc-tree-il-incomplete-object linker to lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to))
  (raise 'trying-to-compile-incomplete-object))


(define (tc-tree-il-do-comp-object linker to lst-visited compile-always?)
  (let* ((binder (get-binder-for-tc linker))
	 (result
	  (cond
	   ((null? to) '())
	   ((is-t-type-variable? to)
	    (tc-tree-il-compile-type-var linker to))
	   ((and (not compile-always?)
		 (not-null? (hfield-ref to 'address)))
	    (tc-tree-il-object-with-address linker to))
	   ((hfield-ref to 'primitive?)
	    (tc-tree-il-primitive-object linker to))
	   ;; The following may be an error situation.
	   ((hfield-ref to 'incomplete?)
	    (tc-tree-il-incomplete-object linker to lst-visited))
	   ((is-tc-pair? to)
	    (tc-tree-il-pair-class linker to lst-visited)) 
	   ((is-tt-union? to)
	    (tc-tree-il-union-type linker to lst-visited))
	   ((is-tc-param-proc? to)
	    (tc-tree-il-param-proc-class linker to lst-visited))
	   ((is-t-param-class-instance? to)
	    (tc-tree-il-param-class-instance linker to lst-visited))
	   ((is-tc-vector? to)
	    (tc-tree-il-vector-class linker to lst-visited))
	   ((is-tc-mutable-vector? to)
	    (tc-tree-il-mutable-vector-class linker to lst-visited))
	   ((is-tc-value-vector? to)
	    (tc-tree-il-value-vector-class linker to lst-visited))
	   ((is-tc-mutable-value-vector? to)
	    (tc-tree-il-mutable-value-vector-class linker to lst-visited))
	   ((is-tt-procedure? to)
	    (tc-tree-il-general-proc-type linker to lst-visited #f))
	   ((is-tc-simple-proc? to)
	    (tc-tree-il-general-proc-type linker to lst-visited #t))
	   ((is-tc-gen-proc? to)
	    (tc-tree-il-gen-proc-class linker to lst-visited))
	   ((is-t-param-signature? to)
	    (tc-tree-il-param-signature linker to lst-visited))
	   ((is-t-signature? to)
	    (tc-tree-il-signature linker to lst-visited))
	   ((is-t-rest? to)
	    (tc-tree-il-rest linker to lst-visited))
	   ((is-t-splice? to)
	    (tc-tree-il-splice linker to lst-visited))
	   ((is-t-type-list? to)
	    (tc-tree-il-type-list linker to lst-visited))
	   ((is-t-type-loop? to)
	    (tc-tree-il-type-loop linker to lst-visited))
	   ((is-t-type-join? to)
	    (tc-tree-il-type-join linker to lst-visited))
	   ((is-tc-pair? (get-entity-type to))
	    (tc-tree-il-pair linker to lst-visited))
	   ((is-t-apti? to)
	    (tc-tree-il-abstract-param-type-inst linker to lst-visited))
	   ((is-t-cycle? to)
	    (raise 'internal-error-with-cycles))
	   (else
	    (dvar1-set! to)
	    (raise 'unknown-object-type)))))
    result))


(define (tc-tree-il-object linker to lst-visited compile-always?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? to))
  (assert (list? lst-visited))
  (assert (boolean? compile-always?))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((lst-new-visited (cons to lst-visited))
	  (binder (get-binder-for-tc linker)))
      (let ((result
	     (if compile-always?
		 (tc-tree-il-do-comp-object linker to lst-new-visited #t)
		 (let* ((a (assv to
				 (hfield-ref linker 'lst-enclosing-cycles))))
		   (if a
		       (tc-tree-il-var-ref0 linker (cdr a))
		       (if (hashq-ref (hfield-ref linker 'ht-cycles) to)
			   (tc-tree-il-cycle linker to lst-new-visited)
			   (tc-tree-il-do-comp-object linker to
						      lst-visited #f)))))))
	(set! gl-indent old-indent)
	result))))


(set! tc-tree-il-object-fwd tc-tree-il-object)


(define (theme-target-tree-il-compile linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-entity? repr))
  (hfield-set! linker 'state 'target-compilation)
  (let ((prev-repr (hfield-ref linker 'current-repr))
	(old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (hfield-set! linker 'current-repr repr)
    (let ((result
	   (cond
	    ((is-t-primitive-object? repr)
	     (tc-tree-il-primitive-object linker repr))
	    ((is-expression? repr)
	     (let ((proc (hrecord-type-inquire tc-tree-il-proc-table 
					       (hrecord-type-of repr))))
	       (if proc
		   (proc linker repr)
		   (begin
		     ;; TBD: Move the error output to theme-d-linker-errors.
		     (write-line (hrecord-type-get-name (hrecord-type-of repr)))
		     (raise 'compilation-not-implemented)))))
	    ((is-target-object? repr)
	     (tc-tree-il-object linker repr '() #f))
	    (else
	     (raise 'invalid-entity)))))
      (hfield-set! linker 'current-repr prev-repr)
      (set! gl-indent old-indent)
      result)))


(set! theme-target-tree-il-compile-fwd theme-target-tree-il-compile)


(define (make-inst-raw-proc linker addr-proc addr-raw)
  (let ((t-var-proc (tc-tree-il-var-ref0 linker addr-proc))
	(s-var-raw (get-target-var-name linker addr-raw))
	(s-call (tree-il-get-call-keyword linker)))
    `(define ,s-var-raw
       (,s-call (toplevel vector-ref)
		,t-var-proc
		(const 1)))))


(define (tc-tree-il-instance linker instance)
  (assert (list? instance))
  (hfield-set! linker 'current-instance instance)
  (let* ((inst-type (car instance))
	 (to (cadr instance))
	 (address (hfield-ref to 'address)))
    (assert (memq inst-type '(class ltype proc declared-proc raw-proc)))
    (let ((result
	   (case inst-type
	     ((class)
	      (assert (= (length instance) 4))
	      (if (param-class-inst-contains-tvars? instance)
		  '()
		  (let ((param-class (list-ref instance 2))
			(params (list-ref instance 3))
			(binder (get-binder-for-tc linker))
			(ht-cycles (hfield-ref linker 'ht-cycles)))
		    (hash-clear! ht-cycles)
		    ;;		      (detect-cycles binder to ht-cycles '())
		    (detect-cycles binder param-class ht-cycles '())
		    (for-each (lambda (ent)
				(detect-cycles binder ent ht-cycles '()))
			      params)
		    (let ((result
			   (tc-tree-il-param-class-instantiation
			    linker address to param-class params)))
		      (hash-clear! ht-cycles)
		      result))))
	     ((proc)
	      (assert (= (length instance) 3))
	      (let ((expr (list-ref instance 2))
		    (binder (get-binder-for-tc linker))
		    (ht-cycles (hfield-ref linker 'ht-cycles)))
		(hash-clear! ht-cycles)
		(detect-cycles binder expr ht-cycles '())
		(let ((result
		       (tc-tree-il-param-proc-instantiation
			linker address to expr)))
		  (hash-clear! ht-cycles)
		  result)))
	     ((raw-proc)
	      (assert (= (length instance) 3))
	      (let ((addr-raw (caddr instance)))
		(make-inst-raw-proc linker address addr-raw)))
	     (else (raise 'internal-error-in-param-def-instance)))))
      (hfield-set! linker 'current-instance '())
      result)))


(set! tc-tree-il-instance-fwd tc-tree-il-instance)


(define (tc-tree-il-instances linker lst-instances)
  (map (lambda (inst) (tc-tree-il-instance linker inst))
       lst-instances))


(define (tc-tree-il-param-class-instance-predef linker clas address)
  (let ((var-name (get-target-var-name linker address))
	(s-call (tree-il-get-call-keyword linker)))
    `(define
       ,var-name
       (,s-call (toplevel make-pci-preobject2) ,clas))))


(define (tc-tree-il-instance-predef linker instance)
  (case (car instance)
    ((class)
     (if (param-class-inst-contains-tvars? instance)
	 '()
	 (let* ((to (list-ref instance 1))
		(address (hfield-ref to 'address))
		(clas (get-entity-type to))
		(t-clas (theme-target-tree-il-compile linker clas)))
	   (tc-tree-il-param-class-instance-predef linker t-clas address))))
    (else '())))


(set! tc-tree-il-instance-predef-fwd
      tc-tree-il-instance-predef)


(define (tc-tree-il-instance-predefs linker lst-instances)
  (map (lambda (inst) (tc-tree-il-instance-predef linker inst))
       lst-instances))


(define (tc-tree-il-factorized-expr linker fact-expr)
  (assert (is-linker? linker))
  (assert (hrecord-is-instance? fact-expr <factorized-expr>))
  (assert (is-target-object? (hfield-ref fact-expr 'to)))
    (let* ((var-name (get-target-var-name
		      linker
		      (hfield-ref fact-expr 'address)))
	   (r-value-expr (hfield-ref fact-expr 'to))
	   (binder (get-binder-for-tc linker))
	   (ht-cycles (hfield-ref linker 'ht-cycles)))
      (hash-clear! ht-cycles)
      (detect-cycles binder r-value-expr ht-cycles '())
      (let ((result
	     (if (not (is-t-type-list? r-value-expr))
		 (let ((t-value-expr
			(tc-tree-il-object linker r-value-expr '() #f)))
		   `(define ,var-name ,t-value-expr))
		 (let* ((comp (lambda (r-subexpr)
				(tc-tree-il-object linker r-subexpr '() #f)))
			(subexprs (hfield-ref r-value-expr 'subexprs))
			(t-value-exprs (map* comp subexprs))
			(s-call (tree-il-get-call-keyword linker)))
		   `(define ,var-name
		      (,s-call (toplevel list) ,@t-value-exprs))))))
	(hash-clear! ht-cycles)
	result)))
  

(set! tc-tree-il-factorized-expr-fwd tc-tree-il-factorized-expr)


(define (tc-tree-il-param-class-instantiation linker address to
					      param-class params)
  (let* ((t-param-class (theme-target-tree-il-compile linker param-class))
	 (t-params (map* (lambda (param)
			   (theme-target-tree-il-compile linker param))
			 params))
	 (t-var-ref (tc-tree-il-var-ref0 linker address))
	 (s-call (tree-il-get-call-keyword linker))
	 (result
	  `(,s-call (toplevel vector-copy-contents-rev)
		    ,t-var-ref
		    (,s-call (toplevel _i_make-param-class-inst)
			     ,t-param-class
			     (,s-call (toplevel list) ,@t-params)))))
    result))


(define (tc-tree-il-param-ltype-instantiation linker var param-ltype params)
  (let* ((t-param-ltype (theme-target-tree-il-compile linker param-ltype))
	 (t-params (map* (lambda (param)
			   (theme-target-tree-il-compile linker param))
			 params))
	 (address (hfield-ref var 'address))
	 (var-name (get-target-var-name linker address))
	 (s-call (tree-il-get-call-keyword linker)))
    `(define ,var-name
       (,s-call (toplevel _i_get-concrete-param-ltype-inst)
		,t-param-ltype
		(,s-call (toplevel list) ,@t-params)))))


(define (tc-tree-il-param-proc-instantiation linker address to expr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-address? address))
  (assert (or (null? expr) (is-entity? expr)))
  (if (null? expr)
      '(const ())
      (let ((var-name (get-target-var-name linker address))
	    (t-expr (theme-target-tree-il-compile linker expr)))
	(list 'define var-name t-expr))))


(define (tc-tree-il-decl-proc-instance linker var param-proc type-var-values)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (assert (is-target-object? param-proc))
  (if (hfield-ref param-proc 'incomplete?)
      (raise 'undefined-declared-param-proc)
      (let* ((address (hfield-ref var 'address))
	     (var-name (get-target-var-name linker address))
	     (to-ppc (get-entity-type param-proc))
	     (tvars (tno-field-ref to-ppc 'l-tvars))
	     (type-var-bindings (map cons tvars type-var-values))
	     (value-expr (tno-field-ref param-proc 'x-value-expr))
	     (bind-result (inst-bind-type-vars linker type-var-bindings
					       value-expr))
	     (bound-value-expr (car bind-result))
	     (instantiations (cdr bind-result))
	     (t-preinst (tc-tree-il-instance-predefs
			 linker instantiations))
	     (t-inst (tc-tree-il-instances linker instantiations))
	     (t-proc-expr
	      (theme-target-tree-il-compile linker bound-value-expr))
	     (t-def-expr (list 'define var-name t-proc-expr))
	     (result
	      (if (and (pair? t-def-expr) (eqv? (car t-def-expr) '_splice))
		  (append t-preinst t-inst (cdr t-def-expr))
		  (append t-preinst t-inst (list t-def-expr)))))
	result)))


(define (tc-tree-il-entity linker entity)
  (hfield-set! linker 'current-toplevel-repr entity)
  (let ((result
	 (cond
	  ;; Objects have no effect as toplevel expressions.
	  ((is-target-object? entity)
;;	   (hfield-set! linker 'current-toplevel-repr entity)
	   '(const ()))
	  ((is-expression? entity)
;;	   (hfield-set! linker 'current-toplevel-repr entity)
	   (let ((binder (get-binder-for-tc linker))
		 (ht-cycles (hfield-ref linker 'ht-cycles)))
	     (hash-clear! ht-cycles)
	     (detect-cycles binder entity ht-cycles '())
	     (let ((result
		    (theme-target-tree-il-compile linker entity)))
	       (hash-clear! ht-cycles)
	       result)))
	  ((hrecord-is-instance? entity <linker-instance-predef>)
;;	   (hfield-set! linker 'current-toplevel-repr entity)
	   (tc-tree-il-instance-predef
	    linker
	    (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <linker-instance>)
;;	   (hfield-set! linker 'current-toplevel-repr entity)
	   (tc-tree-il-instance
	    linker
	    (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <factorized-expr>)
;;	   (hfield-set! linker 'current-toplevel-repr entity)
	   (tc-tree-il-factorized-expr linker entity))
	  (else 
	   (raise 'invalid-entity)))))
    result))


(define (tc-tree-il-import-target-module linker l-s-module-name)
  (strong-assert (and (list? l-s-module-name)
		      (not-null? l-s-module-name)
		      (for-all symbol? l-s-module-name)))
  (let* ((addr-iface (linker-alloc-loc linker 'iface #f))
	 (s-iface-gensym (get-target-var-name linker addr-iface))
	 (s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker)))
    `(,s-seq (let (iface)
	       (,s-iface-gensym)
	       ((,s-call (@@ (guile) resolve-r6rs-interface)
		      (const ,l-s-module-name)))
	       (,s-call (@@ (guile) call-with-deferred-observers)
		     (lambda ()
		       (lambda-case
			((() #f #f #f () ())
			 (,s-call (@@ (guile) module-use-interfaces!)
			       (,s-call (@@ (guile) current-module))
			       (,s-call (@@ (guile) list)
					(lexical
					 iface
					 ,s-iface-gensym))))))))
	     (if (const #f) (const #f) (void)))))


(define (tc-tree-il-define-os-main linker)
  (let* ((addr-args (linker-alloc-loc linker 'args #f))
	 (s-args-gensym (get-target-var-name linker addr-args))
	 (addr-continuation (linker-alloc-loc linker 'continuation #f))
	 (s-continuation-gensym
	  (get-target-var-name linker addr-continuation))
	 (addr-exc (linker-alloc-loc linker 'exc #f))
	 (s-exc-gensym (get-target-var-name linker addr-exc))
	 (addr-t (linker-alloc-loc linker 't #f))
	 (s-t-gensym (get-target-var-name linker addr-t))
	 (s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker)))
    `(define main
       (lambda ((name . main))
	 (lambda-case
	  (((args) #f #f #f () (,s-args-gensym))
	   (,s-call (@@ (rnrs exceptions) call/cc)
		 (lambda ()
		   (lambda-case
		    (((continuation)
		      #f
		      #f
		      #f
		      ()
		      (,s-continuation-gensym))
		     (,s-call (@@ (rnrs exceptions) with-exception-handler)
			   (lambda ()
			     (lambda-case
			      (((exc) #f #f #f () (,s-exc-gensym))
			       (,s-call (lexical
				      continuation
				      ,s-continuation-gensym)
				     (,s-call (toplevel my-error-exit)
					   (lexical
					    exc
					    ,s-exc-gensym))))))
			   (lambda ()
			     (lambda-case
			      ((() #f #f #f () ())
			       (,s-seq (,s-call
					(toplevel set-rte-exception-info!)
					(const #t))
				    (if (if (let (t)
					      (,s-t-gensym)
					      ((,s-call (toplevel null?)
						     (lexical
						      args
						      ,s-args-gensym)))
					      (if (lexical
						   t
						   ,s-t-gensym)
						  (lexical
						   t
						   ,s-t-gensym)
						  (,s-call (toplevel =)
							(,s-call (toplevel
							       length)
							      (lexical
							       args
							       ,s-args-gensym))
							(const 1))))
					    (,s-call (toplevel eq?)
						  (,s-call (toplevel vector-ref)
							(,s-call (toplevel
							       vector-ref)
							      (toplevel _main)
							      (toplevel
							       i-object-class))
							(toplevel
							 i-procedure-class-arg-list-type))
						  (toplevel _b_<null>))
					    (const #f))
					(,s-call (toplevel main0))
					(,s-call (toplevel main0)
					      (lexical
					       args
					       ,s-args-gensym))))))))))))))))))


(define (tc-tree-il-define-main linker)
  (assert (hrecord-is-instance? linker <linker>))
  (let* ((my-main (get-main linker))
	 (result-type
	  (tno-field-ref (get-entity-type my-main) 'type-result))
	 (addr-args (linker-alloc-loc linker 'args #f))
	 (s-args-gensym (get-target-var-name linker addr-args))
	 (t-args-var (list 'lexical 'args s-args-gensym))
	 (s-call (tree-il-get-call-keyword linker))
	 (s-seq (tree-il-get-seq-keyword linker)))
    (let* ((sx-def1
	    (if (linker-entity-is-none? linker result-type)
		`(define main0
		    (lambda ((name . main0))
		      (lambda-case ((() #f args #f () (,s-args-gensym))
				    (if
				     (,s-call
				      (toplevel _i_check-procedure-arg-list-type?)
				      ,t-args-var
				      (,s-call (toplevel vector-ref)
					       (toplevel _main)
					       (const 0)))
				     (,s-seq
				      (,s-call (toplevel apply)
					       (,s-call (toplevel vector-ref)
							(toplevel _main)
							(const 1))
					       ,t-args-var)
				      (const 0))
				     (,s-call (toplevel raise)
					      (const invalid-arguments-for-main)))))))
		(let* ((addr-res (linker-alloc-loc linker 'res #f))
		       (s-res-gensym (get-target-var-name linker addr-res))
		       (t-res-var (list 'lexical 'res s-res-gensym)))
		`(define main0
		    (lambda ((name . main0))
		      (lambda-case ((() #f args #f () (,s-args-gensym))
				    (if
				     (,s-call
				      (toplevel _i_check-procedure-arg-list-type?)
				      ,t-args-var
				      (,s-call (toplevel vector-ref)
					       (toplevel _main)
					       (const 0)))
				     (let (res)
				       (,s-res-gensym)
				       ((,s-call (toplevel apply)
						 (,s-call (toplevel vector-ref)
							  (toplevel _main)
							  (const 1))
						 ,t-args-var))
				       (,s-call (toplevel theme-exit)
						,t-res-var))
				     (,s-call
				      (toplevel raise)
				      (const invalid-arguments-for-main))))))))))
	   (sx-def2 (tc-tree-il-define-os-main linker)))
      (list sx-def1 sx-def2))))
