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



;; *** Scheme target compilation ***


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


(define gl-counter1 0)

(define gl-debug3 #f)

(define gl-lst-tcomp '())

(define tcomp-object-fwd '())

;;(define (get-target-var-prefix module-name)
;;  (string-append "-u-" (symbol->string module-name) "-"))


(define (maybe-symbol->string sym)
  (if (not-null? sym) (symbol->string sym) ""))


(define (convert-module-name-to-string module)
  (cond
   ((null? module) "")
   (else
    (string-append (convert-module-name-to-string (drop-right module 1))
		   "_"
		   (symbol->string (car (take-right module 1)))))))


(define (make-instance-test-scheme linker t-obj expr-type)
  (assert (is-entity? expr-type))
  (cond
   ((eq? expr-type tc-object)
    #t)
   ((eq? expr-type tt-none)
    #f)
   (else
    (let ((p-prim (assq expr-type gl-l-prim-pred)))
      (if p-prim
	  (list (cdr p-prim) t-obj)
	  (let ((t-expr-type
		 (theme-target-compile linker expr-type)))
	    (list 'is-instance? t-obj t-expr-type)))))))


(define (make-instance-test-scheme2 linker t-obj expr-type t-expr-type)
  (assert (is-entity? expr-type))
  (let ((p-prim (assq expr-type gl-l-prim-pred)))
    (if p-prim
	(cons #t (list (cdr p-prim) t-obj))
	(cons #f (list 'is-instance? t-obj t-expr-type)))))


(define (is-apply-proc? t-proc)
  ;;  (assert (is-target-object? t-proc))
  (if (memv (get-entity-value t-proc)
	    (list tp-apply
		  tp-apply-nonpure))
      #t #f))


(define (generate-type-check linker obj-expr type-expr)
  (assert (is-linker? linker))
  (cond
   ((hfield-ref linker 'verbose-typechecks?)
    `(check-type-verbose ,obj-expr ,type-expr
			 (quote ,obj-expr) (quote ,type-expr)))
   (else
    `(check-type ,obj-expr ,type-expr))))


(define (tc-scheme0-letrec-unspecified-check expr s-var-name)
  `(check-letrec-unspecified ,expr (quote ,s-var-name)))


(define (tc-scheme0-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)))
	`(begin
	   (call-stack-push (quote ,s-kind) (quote ,s-name)
			    (quote ,l-module))
	   (let ((result ,t-body))
	     (call-stack-pop)
	     result)))
      t-body))


(define (tcomp-primitive-object linker repr)
  (assert (hfield-ref repr 'primitive?))
  (cond
   ((is-t-atomic-object? repr)
    (if (not (memv (get-entity-type repr)
		   (list tc-nil tc-symbol)))
	(get-contents repr)
	(list 'quote (get-contents repr))))
   ((not-null? (hfield-ref repr 'address))
    (tcomp-object-with-address linker repr))
   (else (list 'quote (get-contents repr)))))


(define (compute-arg linker arg)
  (cond
   ((list? arg)
    (cons 'list
	  (map* (lambda (arg2) (compute-arg linker arg2)) arg)))
   (else
    (theme-target-compile linker arg))))


(define (compute-arg-list linker translated-args)
  (map* (lambda (arg) (compute-arg linker arg)) translated-args))


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


(define (compute-class-field-texprs linker fields)
  (cons 'list
	(map (lambda (fld) (cons 'make-field
				 (compute-class-field-texpr linker fld)))
	     fields)))


(set! compute-class-field-texprs-fwd compute-class-field-texprs)


(define (get-target-var-name-for-loc linker loc)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? loc <normal-variable>))
  (get-target-var-name linker (hfield-ref loc 'address)))


(define (construct-prim-proc-wrapper linker address result-type)
  (let* ((name (get-target-var-name linker address))
	 (source-name (hfield-ref address 'source-name))
	 (str-source-name (symbol->string source-name)))
    (if (eq? result-type tc-object)
	`(lambda arguments
	   (let ((result (apply ,name arguments)))
	     (if (is-valid-theme-d-object? result)
		 result
		 (_i_invalid-theme-d-object-error
		  result
		  ,str-source-name))))
	(let ((p-prim (assq result-type gl-l-prim-pred))
	      (t-result-type (theme-target-compile linker result-type)))
	  (if p-prim
	      `(lambda arguments
		 (let ((result (apply ,name arguments)))
		   (if (,(cdr p-prim) result)
		       result
		       (_i_result-type-error
			result
			,t-result-type
			,str-source-name))))
	      `(lambda arguments
		 (let* ((result (apply ,name arguments))
			(cl (theme-class-of0 result))
			(result-type ,t-result-type))
		   (cond
		    ((not cl)
		     (_i_invalid-theme-d-object-error
		      result
		      ,str-source-name))
		    ((is-subtype? cl result-type)
		     result)
		    (else
		     (_i_result-type-error
		      result
		      result-type
		      ,str-source-name))))))))))
  
	  
(define (construct-param-prim-proc-wrapper linker address result-type
					   t-tvars)
  (let ((name (get-target-var-name linker address))
	(t-result-type (theme-target-compile linker result-type))
	(source-name (hfield-ref address 'source-name)))
    (if (linker-entity-is-none? linker result-type)
	`(lambda (,@t-tvars . arguments)
	   (apply ,name arguments))
	`(lambda (,@t-tvars . arguments)
	   (let ((result (apply ,name arguments))
		 (result-type ,t-result-type))
	     (_i_check-result-type result result-type
				   (symbol->string (quote ,source-name)))
	     result)))))


(define (construct-param-prim-proc-wrapper2 linker address type result-type
					    t-tvars)
  ;; <none> result type must be taken care by the caller.
  (let ((name (get-target-var-name linker address))
	(t-type (theme-target-compile linker type))
	(t-result-type (theme-target-compile linker result-type))
	(source-name (hfield-ref address 'source-name)))
    (list '_i_make-param-proc
	  t-type
	  `(lambda (,@t-tvars . arguments)
	     (let ((result
		    (apply ,name
			   (make-list-with-tail (list ,@t-tvars) arguments)))
		   (result-type ,t-result-type))
	       (_i_check-result-type
		result result-type
		(symbol->string (quote ,source-name)))
	       result))
	  '(quote ()))))


(define (make-proc-args t-args number)
  (if (null? t-args)
      '()
      (let ((cur-arg (car t-args)))
	(cons
	 `(,cur-arg (list-ref parsed-args ,number))
	 (make-proc-args (cdr t-args) (+ number 1))))))


(define (construct-procedure0 t-body t-args t-arg-descs)
  (let ((arg-defs (make-proc-args t-args 0)))
    `(let* ((parsed-args
	     (translate-call-arguments
	      (list ,@t-arg-descs) args))
	    ,@arg-defs)
       ,t-body)))


(define (construct-procedure t-body t-args t-arg-descs t-result-type-desc
			     simple-args?)
  ;; No member of a simple argument list is an application of type operator.
  (if simple-args?
      (begin
	`(lambda ,t-args ,t-body))
      (let ((t-actual-body
	     (if (not-null? t-args)
		 (construct-procedure0 t-body t-args t-arg-descs)
		 t-body)))
	`(lambda args ,t-actual-body))))


(define (construct-param-proc-body linker t-params t-body t-args
				   t-arg-descs t-result-type-desc
				   no-result?
				   simple-args? type-dispatched?)
  (assert (is-linker? linker))
  (if no-result?
      (if (not-null? t-args)
	  (if simple-args?
	      `(lambda (,@t-params ,@t-args) ,t-body)
	      `(lambda (,@t-params . args)
		 ,(construct-procedure0 t-body t-args t-arg-descs)))
	  ;; Maybe we should remove args from the following expression.
	  `(lambda (,@t-params . args) ,t-body))
      (if (not-null? t-args)
	  (if simple-args?
	      (let ((type-check
		     (generate-type-check
		      linker t-body t-result-type-desc)))
		`(lambda (,@t-params ,@t-args) ,type-check))
	      (let ((type-check (generate-type-check
				 linker
				 (construct-procedure0 t-body t-args
						       t-arg-descs)
				 t-result-type-desc)))
		`(lambda (,@t-params . args) ,type-check)))
	  ;; Maybe we should remove args from the following expression.
	  (let ((type-check
		 (generate-type-check linker t-body t-result-type-desc)))
	    `(lambda (,@t-params . args) ,type-check)))))


(define (compile-proc-expr linker repr param-proc? t-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (assert (boolean? param-proc?))
  (assert (list? t-tvars))
  (let* ((args (map (lambda (arg)
		      (get-target-var-name-for-loc linker arg))
		    (hfield-ref repr 'arg-variables)))
	 (arg-descs (hfield-ref repr 'arg-descs))
	 (simple? (is-simple-arg-list? arg-descs))
	 (c-arg-descs (map (lambda (desc)
			     (theme-target-compile linker desc))
			   arg-descs))
	 (body (hfield-ref repr 'body))
	 (c-body
	  (tc-scheme0-call-stack-debug
	   linker
	   repr
	   (theme-target-compile linker body)))
	 (type (get-entity-type repr))
	 (c-type (theme-target-compile linker type))
	 (result-type (hfield-ref repr 'result-type))
	 (c-result-type (theme-target-compile linker result-type)))
    (if (not param-proc?)
	(list '_i_make-procedure c-type
	      (construct-procedure c-body args c-arg-descs c-result-type
				   simple?))
	(let ((no-result? (linker-entity-is-none? linker result-type))
	      (type-dispatched? (entity-type-dispatched? body)))
	  (construct-param-proc-body linker
				     t-tvars
				     c-body args c-arg-descs c-result-type
				     no-result?
				     simple?
				     type-dispatched?)))))


(define (compile-prim-proc-ref linker repr param-proc? t-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (let ((result
	 (if (not param-proc?)
	     (let ((type (get-entity-type repr))
		   (name (get-target-var-name linker
					      (hfield-ref repr 'address))))	
	       (cond
		((is-tc-simple-proc? type)
		 (list '_i_make-procedure
		       (tcomp-object-fwd linker type '() #f)
		       name))
		((is-tc-param-proc? type)
		 (list '_i_make-param-proc
		       (tcomp-object-fwd linker type '() #f)
		       name
		       (list 'quote name)))
		(else
		 (dvar1-set! repr)
		 (raise 'internal-error-with-prim-proc))))
	     (let ((name (get-target-var-name linker
					      (hfield-ref repr 'address))))
	       `(lambda (,@t-tvars . arguments)
		  (apply ,name arguments))))))
    result))


(define (compile-checked-prim-proc linker repr param-proc? t-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <checked-prim-proc>))
  (assert (boolean? param-proc?))
  (assert (list? t-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)))
	       (construct-param-prim-proc-wrapper
		linker
		(hfield-ref repr 'address)
		result-type
		t-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)))
	       (if (linker-entity-is-none? linker result-type)
		   (list '_i_make-procedure
			 (tcomp-object-fwd linker (get-entity-type repr) '() #f)
			 (get-target-var-name linker (hfield-ref repr 'address)))
		   (list '_i_make-procedure
			 (tcomp-object-fwd linker type '() #f)
			 (construct-prim-proc-wrapper
			  linker
			  (hfield-ref repr 'address)
			  result-type)))))
	    ((is-tc-param-proc? type)
	     (let* ((result-type (tno-field-ref
				  (tno-field-ref type 'type-contents)
				  'type-result))
		    (tvars (tno-field-ref type 'l-tvars))
		    (t-tvars (compile-type-vars linker tvars)))
	       (if (linker-entity-is-none? linker result-type)
		   (let ((name (get-target-var-name linker
						    (hfield-ref repr 'address))))
		     (list '_i_make-param-proc
			   (tcomp-object-fwd linker (get-entity-type repr) '() #f)
			   name
			   (list 'quote name)))
		   (construct-param-prim-proc-wrapper2
		    linker
		    (hfield-ref repr 'address)
		    type
		    result-type
		    t-tvars))))
	    (else (raise 'internal-error-1)))))
      result)))


(define (get-initializer-body linker object-arg fields)
  (let ((body '()))
    (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 ((cur-arg (get-initializer-arg-name i)))
	      (set! body
		    (append body
			    (list
			     (list 'vector-set! object-arg i cur-arg)))))
	    (let ((t-contents (theme-target-compile linker cur-init-value)))
	      (set! body
		    (append body
			    (list
			     (list 'vector-set! object-arg i t-contents))))))))
    body))


(define (get-constructor-field-args fields)
  (let ((len (length fields))
	(args '()))
    (do ((i 1 (+ i 1)) (cur-lst fields (cdr cur-lst)))
	((null? cur-lst) args)
      (let ((cur-field (car cur-lst)))
	(if (not (tno-field-ref cur-field 'has-init-value?))
	    (set! args
		  (append args (list (get-initializer-arg-name i)))))))))


(define (get-constructor-body
	 linker t-class fields field-args)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-target-object? t-class))
  (assert (list? fields))
  (assert (list? field-args))
  (let* ((class-texpr (get-target-var-name
		       linker
		       (hfield-ref t-class 'address)))
	 (class-init-texpr
	  `(vector-set! result i-object-class ,class-texpr))
	 (initializer-texprs
	  (get-initializer-body linker 'result fields))
	 (field-count (length fields))
	 (result
	  ;; Vektorin ensimmäinen alkio on olion tyyppi.
	  `(let ((result (make-vector ,(+ field-count 1) '())))
	     ,class-init-texpr
	     ,@initializer-texprs
	     result)))
    result))


(define (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))
	 (field-args (get-constructor-field-args fields))
	 (binder (get-binder-for-inst linker))
	 (body (get-constructor-body linker to-class
				     fields
				     field-args))
	 (proc `(lambda ,field-args ,body)))
    (list '_i_make-procedure t-type proc)))


(define (tcomp-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))))
	(begin
	  `(define ,var-name (make-empty-gen-proc ,gen-proc-name))))
      '(quote ())))


(define (tcomp-declared-var-def var-name t-expr r-type read-only?)
  (assert (is-target-object? r-type))
  (cond
   ((is-primitive-class? r-type)
    `(set! ,var-name ,t-expr))
   ((is-pair-class? r-type)
    `(set-cons! ,var-name ,t-expr))
   ((not read-only?) `(set! ,var-name ,t-expr)) 
   (else
    `(vector-copy-contents
      ,t-expr
      ,var-name))))


(define (theme-target-compile-var-def linker value-expr)
  (if (is-target-object? value-expr)
      (tcomp-object-fwd linker value-expr '() #t)
      (theme-target-compile linker value-expr)))


(define (tcomp-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?))
	     (var-name (get-target-var-name linker address))
	     (result
	      (if (hfield-ref repr 'declared?)
		  (begin
		    (let ((t-expr
			   (theme-target-compile
			    linker
			    (hfield-ref repr 'value-expr)))
			  (r-type
			   (get-entity-type (hfield-ref repr 'variable))))
		      (tcomp-declared-var-def var-name t-expr r-type
					      read-only?)))
		  (begin
		    `(define
		       ,var-name
		       ,(theme-target-compile
			 linker
			 (hfield-ref repr 'value-expr)))))))
	result)
      (begin
	'(quote ()))))


(define (tcomp-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))
	 (var-name (get-target-var-name linker address)))
    (if (not (hfield-ref linker 'tcomp-inside-param-proc?))
	`(set! ,var-name
	       ,(theme-target-compile
		 linker
		 (hfield-ref repr 'value-expr)))
	(let* ((r-var-type (get-entity-type (hfield-ref repr 'variable)))
	       (t-var-type (theme-target-compile linker r-var-type))
	       (r-value-expr (hfield-ref repr 'value-expr))
	       (t-value-expr (theme-target-compile linker r-value-expr))
	       (t-final-value
		(if (entity-type-dispatched? r-value-expr)
		    t-value-expr
		    (generate-type-check linker t-value-expr t-var-type))))
	  `(set! ,var-name ,t-final-value)))))


(define (tcomp-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))
	 (number (hfield-ref address 'number))
	 (toplevel? (hfield-ref address 'toplevel?)))
    ;; Mitä tehdään, jos variable on tyyppimuuttuja?
    (let ((result
	   (cond
	    ((or (>= number 0)
		 (= number address-number-builtin)
		 (= number address-number-target))
	     (get-target-var-name linker address))
	    ;; ((= number address-number-primitive)
	    ;;  (let ((val (hfield-ref repr 'value)))
	    ;; 	(assert (and (not-null? val) (hrecord-is-instance? val <target-prim-object>)))
	    ;; 	(hfield-ref val 'contents)))
	    (else
	     (write-line (hfield-ref address 'module))
	     (write-line (hfield-ref address 'number))
	     (write-line (hfield-ref address 'source-name))
	     (raise 'illegal-internal-var-ref)))))
      (if toplevel?
	  (let ((s-source-name (hfield-ref address 'source-name)))
	    `(check-var-unspecified ,result (quote ,s-source-name)))
	  result))))


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


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


(define (get-var-def-address var-def)
  (assert (hrecord-is-instance? var-def <variable-definition>))
  (hfield-ref (hfield-ref var-def 'variable) 'address))


(define (do-tcomp-prim-class-def 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 (tcomp-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)))
	 ;; Custom primitive classes are always declared forward.
	 (t-creation
	  (if goops?
	      `(vector-copy-contents-rev
		,t-var-name
		(create-goops-class ,name ,t-superclass ,inh? ,imm? ,ebv?))
	      `(vector-copy-contents-rev
		,t-var-name
		(make-custom-prim-class ,name ,imm? ,ebv?))))
	 (t-notify
	  (if goops?
	      (list 'notify-goops-class
		    t-var-name
		    target-name
		    t-equal-var-name
		    t-equal-contents-var-name)
	      (list 'notify-custom-prim-class
		    t-var-name
		    t-member-var-name
		    t-equal-var-name
		    t-equal-objects-var-name
		    t-equal-contents-var-name)))
	 (t-final
	  (if goops?
	      (list '_splice
		    t-creation 
		    t-notify)
	      (list '_splice
		    t-creation 
		    t-notify))))
    t-final))


(define (tcomp-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)
      (do-tcomp-prim-class-def linker repr)
      '(quote ())))


(define (do-tcomp-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* ((var-name (get-target-var-name
				linker
				(hfield-ref val 'address)))
		     (t-super
		      (tno-field-ref val 'cl-superclass))
		     (body
		      (list
		       (tno-field-ref val 'str-name)
		       (begin
			 (tcomp-object-fwd linker t-super '() #f))
		       (begin
			 (compute-class-field-texprs
			  linker
			  (tno-field-ref val 'l-fields)))
		       (tno-field-ref val 'inheritable?)
		       (tno-field-ref val 'immutable?)
		       (tno-field-ref val 'eq-by-value?)
		       `(quote ,(tno-field-ref val 's-ctr-access))))
		     (t-ctr-type (theme-target-compile linker tt-constructor))
		     (ctr (get-constructor-def linker val t-ctr-type))
		     (def-keyword (if (hfield-ref repr 'declared?)
				      'vector-copy-contents-rev
				      'define)))
		`(_splice
		  (,def-keyword ,var-name (_i_make-class ,@body))
		  (vector-set! ,var-name i-class-type-constructor ,t-ctr-type)
		  (vector-set! ,var-name i-class-proc-constructor ,ctr)))))
	(raise 'internal-error-in-class))))


(define (tcomp-class-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <class-definition>))
  (if (var-def-is-used? linker repr)
      (do-tcomp-class-def linker repr)
      '(quote ())))


(define (compile-type-var linker tvar)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-variable? tvar))
  (get-target-var-name linker (hfield-ref tvar 'address)))


(define (compile-type-vars linker tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (map* (lambda (tvar) (compile-type-var linker tvar))
	tvars))


(define (do-tcomp-param-class-def 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* ((var-name (get-target-var-name-for-loc linker var))
		    (r-super
		     (tno-field-ref val 'cl-instance-superclass))
		    (t-super (theme-target-compile linker r-super))
		    (t-fields
		     (compute-class-field-texprs
		      linker
		      (tno-field-ref val 'l-instance-fields)))
		    (t-tvars (compile-type-vars
			      linker
			      (tno-field-ref val 'l-tvars)))
		    (nr-of-tvars (length t-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) (list 'make-tvar-object tvar-number))
			  tvar-numbers)))
	       (let ((body
		      (list
		       (tno-field-ref val 'str-name)
		       (tno-field-ref val 'i-params)
		       `(list ,@t-tvar-objects)
		       `((lambda ,t-tvars ,t-super) ,@t-tvar-objects)
		       `((lambda ,t-tvars ,t-fields) ,@t-tvar-objects)
		       (tno-field-ref val 'instances-inheritable?)
		       (tno-field-ref val 'instances-immutable?)
		       (tno-field-ref val 'instances-eq-by-value?)
		       (tno-field-ref val 'instance-has-constructor?)
		       `(quote ,(tno-field-ref val 's-instance-ctr-access)))))
		 (if (hfield-ref repr 'declared?)
		     `(vector-copy-contents-rev
		       ,var-name (_i_make-param-class ,@body))
		     `(define ,var-name (_i_make-param-class ,@body))))))
	    (else (raise 'internal-error-in-class)))))
      result)))


(define (tcomp-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)
      (do-tcomp-param-class-def linker repr)
      '(quote ())))


(define (tcomp-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)))
    (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-compile linker r-type)))
	(list '_i_make-procedure c-type 'cons)))
     (else
      (let ((t-clas (theme-target-compile linker clas)))
	`(get-constructor ,t-clas))))))


(define (handle-prim val)
  (if (not-null? val) val '(quote ())))


(define (tcomp-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-compile linker r-clas)))
    (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?)
	    zero-value)
	   ((is-address? zero-value)
	    (get-target-var-name linker zero-value))
	   (else
	    `(vector-ref ,t-clas i-class-zero-value))))
	`(get-zero ,t-clas))))


(define (tcomp-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 (get-target-var-name linker (hfield-ref var-cl 'address)))
	 (t-zero-proc (theme-target-compile linker r-zero-proc)))
    (if param?
	(begin
	  `(_splice
	    (vector-set! ,t-cl i-param-class-instance-has-zero #t)
	    (vector-set! ,t-cl i-param-class-instance-zero-proc
			 ,t-zero-proc)))
	(begin
	  `(_splice
	    (vector-set! ,t-cl i-class-has-zero #t)
	    (vector-set! ,t-cl i-class-zero-value
			 (_i_call-proc ,t-zero-proc '() '())))))))


(define (tcomp-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-compile linker r-object))
	  (to-type (get-entity-type r-object)))
      (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)))
	  `(check-field-unspecified (vector-ref ,t-object ,field-index)
				    (quote ,r-field-name))))
       ((symbol? r-field-name)
	(list '_i_field-ref t-object `(quote ,r-field-name)))
       (else
	(list '_i_field-ref t-object
	      (theme-target-compile linker r-field-name)))))))


(define (tcomp-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-compile linker r-object))
	   (t-field-value (theme-target-compile linker r-field-value))
	   (to-type (get-entity-type r-object))
	   (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-compile linker
							     r-field-type))
			 (t-wrapped-value
			  (if (entity-type-dispatched? r-field-value)
			      t-field-value
			      (generate-type-check linker t-field-value
						   t-field-type))))
		    (list 'vector-set! t-object field-index t-wrapped-value))
		  (let ((field-index (get-field-index
				      r-field-name
				      to-type)))
		    (list 'vector-set! t-object field-index t-field-value))))
	     ((symbol? r-field-name)
	      (list '_i_field-set! t-object `(quote ,r-field-name)
		    t-field-value))
	     (else
	      (list '_i_field-set! t-object
		    (theme-target-compile linker r-field-name)
		    t-field-value)))))
      result)))


(define (wrap-proc-arg linker arg)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-entity? arg))
  (let ((t-arg (theme-target-compile linker arg))
	(t-type (theme-target-compile linker
				      (get-entity-type arg))))
    (generate-type-check linker t-arg t-type)))


(define (compile-proc-arg linker arg)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-entity? arg))
  (if (hfield-ref linker 'tcomp-inside-param-proc?)
      (wrap-proc-arg linker arg)
      (theme-target-compile linker arg)))


(define (compile-proc-args linker args)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (list? args))
  (map* (lambda (arg) (compile-proc-arg linker arg)) args))


(define (tcomp-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))
	 (t-args (map* (lambda (arg) (theme-target-compile linker arg))
		       args))
	 (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)))
      (strong-assert (= (length t-args) 2))
      (cons 'cons t-args))
     ((eq? proc tp-is-instance)
      (strong-assert (= (length t-args) 2))
      ;; Object is compiled but type is not.
      (let ((t-obj (car t-args))
	    (expr-type (cadr args)))
	(make-instance-test-scheme linker t-obj expr-type)))
     (else
      (let ((t-proc (theme-target-compile linker proc)))
	(if (and (not (hfield-ref repr 'runtime-arglist-typecheck?))
		 (and-map? entity-type-dispatched? args))
	    `((vector-ref ,t-proc 1) ,@t-args)
	    (let ((s-proc-name
		   (let ((address (hfield-ref proc 'address)))
		     (if (not-null? address)
			 (hfield-ref address 'source-name)
			 '()))))
	      `(let ((proc ,t-proc))
		 (apply (vector-ref proc 1)
			(check-arglist-type proc
					    (list ,@t-args)
					    (quote ,s-proc-name)))))))))))


(define (tcomp-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-expr
	 (list '_i_call-generic-proc
	       (theme-target-compile linker (hfield-ref repr 'proc))
	       (cons 'list
		     (map* (lambda (repr-arg)
			     (theme-target-compile linker repr-arg))
			   (hfield-ref repr 'arglist))))))
    (if (and (entity-type-dispatched? repr)
	     (not (linker-entity-is-none? linker (get-entity-type repr))))
	(let ((t-type-expr (theme-target-compile
			    linker (get-entity-type repr))))
	  (generate-type-check linker t-expr t-type-expr))
	t-expr)))


(define (tcomp-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-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))
	 ;; static-arg-types may be a single variable
	 ;; because of optimization.
	 (t-static
	  (cond
	   ((null? static-arg-types) '(quote ()))
	   ((list? static-arg-types)
	    (let ((t (map* comp static-arg-types)))
	      `(list ,@t)))
	   (else
	    (comp static-arg-types))))
	 (result
	  `(_i_call-param-proc ,t-param-proc
			       (list ,@t-args)
			       ,t-static)))
    result))


(define (tcomp-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-compile linker arg))
			args))
	   (proc (hfield-ref repr 'proc))
	   (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))))
		(cons 'cons t-args)
		(let* ((t-proc (theme-target-compile linker proc))
		       ;;		     (static-arg-types
		       ;;		      (map (lambda (arg) (hfield-ref arg 'type)) args))
		       (comp (lambda (rexpr) (theme-target-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)))
			      `(list ,@t))
			    (comp static-arg-types)))
		       (t-expr
			(list '_i_call-proc t-proc
			      (cons 'list t-args)
			      t-static)))
		  (if (and (entity-type-dispatched? repr)
			   (not (linker-entity-is-none?
				 linker
				 (get-entity-type repr))))
		      (let ((t-type-expr (theme-target-compile
					  linker (get-entity-type repr))))
			(generate-type-check linker t-expr t-type-expr))
		      t-expr)))))
      result)))


(define (tcomp-apply-expr linker repr)
  (let* ((arglist (hfield-ref repr 'arglist))
	 (proc (car arglist))
	 (arglist2 (cadr arglist))
	 (comp (lambda (rexpr) (theme-target-compile linker rexpr)))
	 (t-proc (comp proc))
	 (t-arglist2 (comp arglist2)))
    (if (is-tc-simple-proc? (get-entity-type proc))
	(list 'apply (list 'vector-ref t-proc 'i-simple-proc-raw-proc)
	      t-arglist2)
	(let* ((static-arg-types (hfield-ref repr 'static-arg-types))
	       (t-static
		(cond
		 ((null? static-arg-types) '(quote ()))
		 ((list? static-arg-types)
		  (if (>= (length static-arg-types) 2)
		      (comp (cadr static-arg-types))
		      '(quote ())))
		 (else
		  `(cadr ,(comp static-arg-types))))))
	  (list '_i_call-proc t-proc t-arglist2 t-static)))))


(define (tcomp-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)))
	    (tcomp-apply-expr linker repr))
	   ((null? type)
	    (tcomp-abstract-proc-appl linker repr))
	   ((is-t-instance? binder type tpc-simple-proc)
	    (tcomp-simple-proc-appl linker repr))
	   ((is-t-instance? binder type tpc-param-proc)
	    (tcomp-param-proc-appl linker repr))
	   ((is-t-instance? binder type tmc-gen-proc)
	    (tcomp-generic-proc-appl linker repr))
	   ((is-t-instance? binder type tmt-procedure)
	    (tcomp-abstract-proc-appl linker repr))
	   (else
	    (dvar1-set! repr)
	    (raise 'internal-error-in-procedure-application)))))
    result))


(define (combine-args args rest-arg)
  (assert (list? args))
  (assert (symbol? rest-arg))
  (if (null? args)
      rest-arg
      (cons (car args) (combine-args (cdr args) rest-arg))))


(define (tcomp-proc-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (compile-proc-expr linker repr #f '()))


(define (tcomp-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 '()))
	'(quote ()))))


(define (tcomp-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-compile linker gen-proc)))
	    (if (not (symbol? t-gen-proc))
		(raise 'invalid-method-definition))
	    (let ((t-procexpr (theme-target-compile linker procexpr))
		  (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! ,old-var-name ,t-procexpr)
				(_i_add-method! ,t-gen-proc ,t-procexpr
						,static?))))
		  `(_i_add-method! ,t-gen-proc ,t-procexpr ,static?)))))
	'(quote ()))))


(define (target-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>))
    (if (hfield-ref linker 'tcomp-inside-param-proc?)
	(let ((type-check
	       (if (or (null? type)
		       (entity-type-dispatched? init-expr))
		   (theme-target-compile linker init-expr)
		   (generate-type-check
		    linker
		    (theme-target-compile linker init-expr)
		    (theme-target-compile linker
					  type)))))
	  `(,(get-target-var-name-for-loc linker variable)
	    ,type-check))
	(list
	 (get-target-var-name-for-loc linker variable)
	 (theme-target-compile linker init-expr)))))


(define (target-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* ((t-init-expr0 (theme-target-compile linker init-expr))
	   (s-source-name (hfield-ref (hfield-ref variable 'address)
				      'source-name))
	   (t-init-expr (tc-scheme0-letrec-unspecified-check 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
		     (generate-type-check
		      linker
		      t-init-expr
		      (theme-target-compile linker
					    type)))))
	    `(,(get-target-var-name-for-loc linker variable)
	      ,type-check))
	  (list
	   (get-target-var-name-for-loc linker variable)
	   t-init-expr)))))


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


(define (tcomp-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 (target-parse-let-variables linker variables
						   recursive?))
	  (t-body (theme-target-compile linker body)))
      (list keyword
	    t-variables
	    t-body))))


(define (tcomp-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-compile linker value-expr))
	    ((is-empty-expr? default-expr)
	     `(_i_cast
	       ,(theme-target-compile linker type)
	       ,(theme-target-compile linker value-expr)))
	    (else
	     `(let ((obj-cast ,(theme-target-compile linker value-expr)))
		(if (is-instance? obj-cast
				  ,(theme-target-compile linker type))
		    obj-cast
		    ,(theme-target-compile linker default-expr)))))))
      result)))


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


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


(define (tcomp-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-compile linker expr-to-match))
	 (texpr-clauses
	  (map (lambda (lst-repr-clause)
		 (compile-match-type-clause linker lst-repr-clause))
	       lst-repr-clauses))
	 (gen-else? (and (hfield-ref repr 'strong?)
			 (is-empty-expr? expr-else)))
	 (has-else? (or gen-else? (not (is-empty-expr? expr-else))))
	 (texpr-else
	  (if gen-else?
	      '(_i_match-type-strong-no-match)
	      (theme-target-compile linker expr-else))))
    (if has-else?
	`(let ((obj-match ,texpr-to-match))
	   (cond
	    ,@texpr-clauses
	    (else ,texpr-else)))
	`(let ((obj-match ,texpr-to-match))
	   (cond
	    ,@texpr-clauses)))))


(define (tcomp-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-compile linker repr1)))
	 (t-condition
	  (if (or (entity-type-dispatched? condition)
		  (not (hfield-ref repr 'boolean-cond?)))
	      (comp condition)
	      (generate-type-check linker (comp condition) '_b_<boolean>))))
    (if (not (is-empty-expr? else-expr))
	`(if ,t-condition ,(comp then-expr) ,(comp else-expr))
	`(if ,t-condition ,(comp then-expr)))))


(define (tcomp-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-compile linker repr1)))
	 (t-subexprs (map comp subexprs)))
    (cons 'begin t-subexprs)))


;; HUOM: Jos paluuarvo on tyhjä, niin
;; semantiikka voi poiketa Schemen do-lauseesta
;; vastaavassa tapauksessa.
(define (tcomp-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-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)
	       (generate-type-check linker (comp condition) '_b_<boolean>)))
	  (t-result (if (not (is-empty-expr? result)) (comp result) '()))
	  (t-body (if (not (is-empty-expr? body)) (comp body) '())))
      (list
       'do
       '()
       (if (not-null? t-result)
	   (list t-condition t-result)
	   (list t-condition))
       (if (not-null? t-body)
	   t-body
	   '(quote ()))))))


(define (tcomp-fw-decl linker repr)
  (if (or (hfield-ref repr 'redecl?)
	  (and (hfield-ref linker 'strip?)
	       (not (decl-is-used? linker repr)))) 
      '(quote ())
      (let* ((var (hfield-ref repr 'variable))
	     (var-name (get-target-var-name-for-loc linker var))
	     (type (get-entity-type var)))
	(cond
	 ((is-primitive-class? type)
	  `(define ,var-name _b_unspecified))
	 ((is-pair-class? type)
	  `(define ,var-name (cons _b_unspecified _b_unspecified)))
	 ((not (hfield-ref var 'read-only?))
	  `(define ,var-name _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 (make-vector ,(+ nr-of-fields 1)
					      _b_unspecified)))))))))


(define (do-tcomp-param-ltype-def linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <param-logical-type-def>))
  (let* ((var (hfield-ref repr 'variable))
	 (var-name (get-target-var-name
		    linker
		    (hfield-ref var 'address)))
	 (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))
	 (keyword (if (hfield-ref repr 'declared?)
		      'vector-copy-contents-rev
		      'define))
	 (t-val (theme-target-compile linker r-val))
	 (t-tvars (map* (lambda (r-tvar)
			  (get-target-var-name
			   linker
			   (hfield-ref r-tvar 'address)))
			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) (list 'make-tvar-object tvar-number))
		tvar-numbers)))
    `(,keyword
      ,var-name
      (let ((tvar-object-list (list ,@t-tvar-objects)))
	(_i_make-param-ltype
	 ,name
	 tvar-object-list
	 (apply (lambda ,t-tvars ,t-val) tvar-object-list)
	 _b_<object>
	 ,nr-of-tvars)))))


(define (tcomp-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)
      (do-tcomp-param-ltype-def linker repr)
      '(quote ())))


;; (define (tcomp-param-ltype-instance linker repr)
;;   (dwli2 "tcomp-param-ltype-instance")
;;   (assert (hrecord-is-instance? linker <linker>))
;;   (assert (hrecord-is-instance? repr <expr-param-logical-type-instance>))
;;   (dwli2 "tcomp-param-ltype-instance/1")
;;   (if (not (eqv? (get-expr-value (hfield-ref repr 'param-logical-type))
;; 		 tplt-uniform-list))
;;       (do-compile-param-type-instance linker repr #f)
;;       (let* ((member-type-repr 
;; 	      (if (not-null? (hfield-ref repr 'params))
;; 		  (car (hfield-ref repr 'params))
;; 		  (car (hfield-ref repr 'args))))
;; 	     (member-type-texpr (theme-target-compile linker member-type-repr)))
;; 	(if (not-null? (hfield-ref repr 'value))
;; 	    `(_i_make-concrete-uniform-list ,member-type-texpr)
;; 	    `(_i_make-uniform-list ,member-type-texpr)))))



(define (get-arg-defs list-var-name arg-names)
  (assert (symbol? list-var-name))
  (assert (list? arg-names))
  (assert (and-map? string? arg-names))
  (let* ((count (length arg-names))
	 (indices (get-integer-sequence 0 count)))
    (map (lambda (name index) (list name (list 'list-ref list-var-name index)))
	 arg-names indices)))


(define (compile-param-proc-body linker body t-tvars)
  (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? t-tvars))
  (cond
   ((hrecord-is-instance? body <procedure-expression>)
    (compile-proc-expr linker body #t t-tvars))
   ;; Should we remove the following?
   ((hrecord-is-instance? body <prim-proc-ref>)
    (compile-prim-proc-ref linker body #t t-tvars))
   ((hrecord-is-instance? body <checked-prim-proc>)
    (compile-checked-prim-proc linker body #t t-tvars))
   (else
    ;; We should never arrive here.
    (raise 'internal-error-2))))


(define (tcomp-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))))
	   (type-vars (hfield-ref repr 'type-variables))
	   (t-params
	    (map vcomp type-vars))
	   (t-type (theme-target-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 (compile-param-proc-body
			 linker (hfield-ref repr 'body) t-params))
	   (binder (get-binder-for-tc linker)))
      (assert (is-t-instance? binder to-type tpc-param-proc))
      (hfield-set! linker 'tcomp-inside-param-proc? inside-param-proc-old?)
      `(_i_make-param-proc ,t-type
			   ,t-proc-body
			   (quote ,s-name)))))


(define (tcomp-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))
      (do-compile-param-proc-instance linker repr)
      (do-compile-param-proc-instance-expr linker repr)))


(define (tcomp-param-proc-dispatch linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  ;; Procedure do-compile-param-proc-instance works also for
  ;; <expr-param-proc-dispatch>.
  (do-compile-param-proc-instance linker repr))


(define (tcomp-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?)))
    (if (and (entity-type-dispatched? repr)
	     (not (linker-entity-is-none? linker result-type)))
	(let ((t-result-type (theme-target-compile linker result-type)))
	  (list '_i_dispatch-generic-proc
		(theme-target-compile linker (hfield-ref repr 'generic-proc))
		t-result-type
		(cons 'list
		      (map* (lambda (repr-arg)
			      (theme-target-compile linker repr-arg))
			    (hfield-ref repr 'arg-types)))
		appl-pure? appl-always-returns? appl-never-returns?))
	(list '_i_dispatch-generic-proc
	      (theme-target-compile linker (hfield-ref repr 'generic-proc))
	      (quote '())
	      (cons 'list
		    (map* (lambda (repr-arg)
			    (theme-target-compile linker repr-arg))
			  (hfield-ref repr 'arg-types)))
	      appl-pure? appl-always-returns? appl-never-returns?))))


(define (compile-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 (tcomp-object-fwd linker obj-target '() #f))
	  (p-type (tcomp-object-fwd linker r-type '() #f)))
      `(cons ,p-target ,p-type))))


(define (compile-param-signature linker to)
  (let* ((t-tvars (compile-type-vars
		   linker
		   (tno-field-ref to 'l-tvars)))
	 (nr-of-tvars (length t-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) (list 'make-tvar-object tvar-number))
	       tvar-numbers))
	 (r-members (tno-field-ref to 'l-members))
	 (t-members (map* (lambda (r-member)
			    (compile-signature-member linker r-member))
			  r-members)))
    `(make-param-signature (list ,@t-tvar-objects)
			   ((lambda ,t-tvars (list ,@t-members))
			    ,@t-tvar-objects))))


(define (tcomp-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)
			      (compile-signature-member linker r-member))
			    r-members))
	   (var-name (get-target-var-name linker (hfield-ref var 'address)))
	   (declared? (hfield-ref repr 'declared?))
	   (def-kw (if declared? 'set! 'define)))
      `(,def-kw ,var-name (make-signature (list ,@p-members))))))


;; TO BE DONE (?)
(define (tcomp-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 (compile-param-signature linker to))
	 (declared? (hfield-ref repr 'declared?))
	 (def-kw (if declared? 'set! 'define)))
    `(,def-kw ,var-name ,t-expr)))


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


(define (tcomp-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-compile linker
					       (hfield-ref repr 'condition)))
	    (condition-source-expr (hfield-ref repr 'condition-source-expr)))
	`(if (not ,t-condition)
	     (_i_raise-assertion-failed (quote ,condition-source-expr))))
      '(quote ())))


(define (tcomp-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)))
    (if (or (null? x-message) (symbol? x-message) (pair? x-message))
	`(theme-debug-print (quote ,x-message))
	`(theme-debug-print ,x-message))))


(define (tcomp-empty linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <empty-expression>))
  '(quote ()))


(define (tcomp-do-nothing linker repr) #f)


(define (tcomp-error linker repr)
  (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 tcomp-proc-table
  (list
   (cons <generic-procedure-definition> tcomp-gen-proc-def)
   (cons <variable-definition> tcomp-var-def)
   (cons <set-expression> tcomp-set-expr)
   (cons <variable-reference> tcomp-var-ref)
   (cons <prim-proc-ref> tcomp-prim-proc-ref)
   (cons <checked-prim-proc> tcomp-checked-prim-proc)
   (cons <prim-class-def> tcomp-prim-class-def)
   (cons <class-definition> tcomp-class-def)
   (cons <param-class-definition> tcomp-param-class-def)
   (cons <expr-constructor> tcomp-constructor)
   (cons <zero-expr> tcomp-zero)
   (cons <field-ref-expr> tcomp-field-ref)
   (cons <field-set-expr> tcomp-field-set)
   (cons <proc-appl> tcomp-proc-appl)
   (cons <procedure-expression> tcomp-proc-expr)
   (cons <method-definition> tcomp-method-def)
   (cons <method-declaration> tcomp-method-decl)
   (cons <let-expression> tcomp-let)
   (cons <cast-expression> tcomp-cast)
   (cons <static-cast-expression> tcomp-static-cast)
   (cons <match-type-expression> tcomp-match-type)
   (cons <if-form> tcomp-if)
   (cons <compound-expression> tcomp-compound)
   (cons <until-form> tcomp-until)
   (cons <forward-declaration> tcomp-fw-decl)
   (cons <param-logical-type-def> tcomp-param-ltype-def)
   (cons <param-proc-expr> tcomp-param-proc-expr)
   (cons <expr-param-proc-instance> tcomp-param-proc-instance)
   (cons <expr-param-proc-dispatch> tcomp-param-proc-dispatch)
   (cons <generic-proc-dispatch> tcomp-generic-proc-dispatch)
   (cons <signature-definition> tcomp-signature-def)
   (cons <param-signature-definition> tcomp-param-signature-def)
   (cons <zero-setting-expr> tcomp-zero-setting)
   (cons <force-pure-expr> tcomp-force-pure-expr)
   (cons <assertion-expr> tcomp-assertion)
   (cons <debug-output-expr> tcomp-debug-output)
   (cons <empty-expression> tcomp-empty)
   (cons <normal-variable> tcomp-error)
   (cons <target-object> tcomp-error)))


(define (tcomp-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))
    (get-target-var-name linker address)))


(define (tcomp-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 (tcomp-object-fwd linker r-param-class
						 lst-visited #f))
		(r-params (tno-field-ref repr 'l-tvar-values))
		(t-params
		 (map* (lambda (param)
			 (tcomp-object-fwd linker param lst-visited #f))
		       r-params)))
	   ;; Formerly we compiled the value expression of the
	   ;; parametrized logical type if it was available.
	   `(_i_get-concrete-param-class-inst
	     ,t-param-class
	     (list ,@t-params)))))
    result))


(define (tcomp-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 (tcomp-object-fwd linker (car tvv)
				     lst-visited #f))
	 (tt-second (tcomp-object-fwd linker (cadr tvv)
				      lst-visited #f)))
    (if (contains-type-modifiers? to)
	`(_i_get-pair-class-general1
	  (list ,tt-first ,tt-second))
	`(_i_get-pair-class-general
	  (list ,tt-first ,tt-second)))))


(define (tcomp-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 (tcomp-object-fwd linker (tno-field-ref to 'first)
				  lst-visited #f))
	 (second (tcomp-object-fwd linker (tno-field-ref to 'second)
				   lst-visited #f)))
    (list 'cons first second)))


(define (tcomp-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)
		  (tcomp-object-fwd linker to-member lst-visited #f))
		r-member-types)))
    `(_i_make-concrete-union (list ,@p-member-types))))


(define (tcomp-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 (tcomp-object-fwd linker member-type-repr
					      lst-visited #f)))
    `(_i_construct-vector ,member-type-texpr)))


(define (tcomp-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 (tcomp-object-fwd linker member-type-repr
					      lst-visited #f)))
    `(_i_construct-mutable-vector ,member-type-texpr)))


(define (tcomp-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 (tcomp-object-fwd linker member-type-repr
					      lst-visited #f)))
    `(_i_construct-value-vector ,member-type-texpr)))


(define (tcomp-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 (tcomp-object-fwd linker member-type-repr
					      lst-visited #f)))
    `(_i_construct-mutable-value-vector ,member-type-texpr)))


(define (tcomp-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)
		 (tcomp-object-fwd
		  linker
		  repr1
		  lst-visited
		  #f)))
	 (internal-proc-name '_i_make-procedure-type))
    ;; We use <none> for a missing value.
    (assert (not-null? result-type))
    (list internal-proc-name
	  (comp arg-list-type)
	  (comp result-type)
	  pure-proc?
	  appl-always-returns?
	  appl-never-returns?
	  static-method?
	  simple?)))


(define (tcomp-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))
	 (r-type (get-entity-type to))
	 (t-type (tcomp-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 (tcomp-object-fwd linker to lst-visited
					#t))
	  (binder (get-binder-for-tc 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)))
	    `(let ((,t-var-name (make-vector ,i-elements '())))
	       (vector-set! ,t-var-name i-object-class ,t-type)
	       (vector-copy-contents-rev ,t-var-name ,p-contents)
	       ,t-var-name))
	  `(let ((,t-var-name (make-singleton '())))
	     (vector-set! ,t-var-name i-singleton-element ,p-contents)
	     ,t-var-name)))))


(define (tcomp-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))
	 (vcomp (lambda (argvar)
		  (get-target-var-name linker
				       (hfield-ref argvar 'address))))
	 (t-type-vars (map* vcomp 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))
	 (t-tvar-objects
	  (map (lambda (tvar-number) (list 'make-tvar-object tvar-number))
	       tvar-numbers))
	 (t-inst-type (tcomp-object-fwd linker inst-type lst-visited #f)))
    `(_i_make-param-proc-class
      ,first-number ,nr-of-tvars
      (list ,@t-tvar-objects)
      ((lambda ,t-type-vars ,t-inst-type) ,@t-tvar-objects))))


(define (tcomp-gen-proc-class linker repr lst-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-tc-gen-proc? repr))
  (let* ((comp (lambda (rexpr) (tcomp-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)))
    `(make-gen-proc-class (list ,@t-method-classes))))


(define (tcomp-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)
	     (tcomp-object-fwd linker subrepr lst-visited #f))
	   subtypes)))
    `(create-type-list (list ,@compiled-subexprs))))


(define (tcomp-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 (tcomp-object-fwd linker component
					       lst-visited #f)))
    (list '_i_make-rest-expression compiled-component)))


(define (tcomp-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 (tcomp-object-fwd
			      linker component lst-visited #f)))
    (list '_i_make-splice-expression compiled-component)))


(define (tcomp-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)
	     (tcomp-object-fwd linker subrepr lst-visited #f))
	   subtypes)))
    (cons '_i_make-type-join compiled-subtypes)))


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


(define (tcomp-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 (tcomp-object-fwd linker r-param-type
					 lst-visited #f))
	 (r-args (tno-field-ref to 'l-type-args))
	 (p-args (map (lambda (repr) (tcomp-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)))))
    `(,decl-proc ,p-param-type (list ,@p-args))))


(define (tcomp-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)
			    (compile-signature-member linker r-member))
			  r-members)))
    `(make-signature (list ,@p-members))))


(define (tcomp-param-signature linker to l-visited)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-param-signature? to))
  (compile-param-signature linker to))


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


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


(define (tcomp-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?
		 (do-tcomp-object linker to lst-new-visited #t)
		 (let* ((a (assv to
				 (hfield-ref linker 'lst-enclosing-cycles))))
		   (if a
		       (get-target-var-name linker (cdr a))
		       (if (hashq-ref (hfield-ref linker 'ht-cycles) to)
			   (tcomp-cycle linker to lst-new-visited)
			   (do-tcomp-object linker to
					    lst-visited #f)))))))
	(set! gl-indent old-indent)
	result))))


(set! tcomp-object-fwd tcomp-object)


(define (theme-target-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)
	     (tcomp-primitive-object linker repr))
	    ((is-expression? repr)
	     (let ((proc (hrecord-type-inquire tcomp-proc-table 
					       (hrecord-type-of repr))))
	       (if proc
		   (proc linker repr)
		   (begin
		     (write-line (hrecord-type-get-name (hrecord-type-of repr)))
		     (raise 'compilation-not-implemented)))))
	    ((is-target-object? repr)
	     (tcomp-object linker repr '() #f))
	    (else
	     (raise 'invalid-entity)))))
      (hfield-set! linker 'current-repr prev-repr)
      (set! gl-indent old-indent)
      result)))


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


(define (theme-target-compile-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)))
    (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
			     (compile-param-class-instantiation
			      linker address to param-class params)))
			(hash-clear! ht-cycles)
			result))))
	     ;; ((ltype)
	     ;;  (assert (= (length instance) 4))
	     ;;  (if (param-ltype-inst-contains-tvars? instance)
	     ;; 	  '()
	     ;; 	  (let ((param-ltype (list-ref instance 2))
	     ;; 		(params (list-ref instance 3)))
	     ;; 	    (compile-param-ltype-instantiation
	     ;; 	     linker var param-ltype params))))
	     ((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
		       (compile-param-proc-instantiation
			linker address to expr)))
		  (hash-clear! ht-cycles)
		  result)))
	     (else (raise 'internal-error-in-param-def-instance)))))
      (hfield-set! linker 'current-instance '())
      result)))


(set! theme-target-compile-instance-fwd theme-target-compile-instance)


(define (theme-target-compile-instances linker lst-instances)
  (map (lambda (inst) (theme-target-compile-instance linker inst))
       lst-instances))


(define (theme-target-compile-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))
		(var-name (get-target-var-name linker address))
		(t-clas (theme-target-compile linker clas)))
	   (compile-param-class-instance-predef t-clas var-name))))
    ;; ((ltype)
    ;;  (if (param-ltype-inst-contains-tvars? instance)
    ;; 	 '()
    ;; 	 (let* ((var (list-ref instance 1))
    ;; 		(address (hfield-ref var 'address))
    ;; 		(var-name (get-target-var-name linker address)))
    ;; 	   (compile-param-ltype-instance-predef var-name))))
    (else '())))


(set! theme-target-compile-instance-predef-fwd
      theme-target-compile-instance-predef)


(define (theme-target-compile-instance-predefs linker lst-instances)
  (map (lambda (inst) (theme-target-compile-instance-predef linker inst))
       lst-instances))


(define (compile-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 (theme-target-compile-var-def linker
		 ;;							  r-value-expr)))
		 (let ((t-value-expr (tcomp-object linker r-value-expr '() #f)))
		   `(define ,var-name ,t-value-expr))
		 ;;	(let* ((comp (lambda (r-subexpr)
		 ;;		       (theme-target-compile-var-def linker r-subexpr)))
		 (let* ((comp (lambda (r-subexpr)
				(tcomp-object linker r-subexpr '() #f)))
			(subexprs (hfield-ref r-value-expr 'subexprs))
			(t-value-exprs (map* comp subexprs)))
		   `(define ,var-name (list ,@t-value-exprs))))))
	(hash-clear! ht-cycles)
	result)))
  

(set! compile-factorized-expr-fwd compile-factorized-expr)


(define (compile-param-class-instance-predef clas var-name)
  `(define
     ,var-name
     (make-pci-preobject2 ,clas)))


(define (compile-param-class-instantiation linker address to param-class params)
  (let* ((t-param-class (theme-target-compile-fwd linker param-class))
	 (t-params (map* (lambda (param)
			   (theme-target-compile-fwd linker param))
			 params))
	 (var-name (get-target-var-name-fwd linker address))
	 (result
	  `(vector-copy-contents-rev
	    ,var-name (_i_make-param-class-inst
		       ,t-param-class
		       (list ,@t-params)))))
    result))


(define (compile-param-ltype-instance-predef var-name)
  '(quote ()))


(define (compile-param-ltype-instantiation linker var param-ltype params)
  (let* ((t-param-ltype (theme-target-compile-fwd linker param-ltype))
	 (t-params (map* (lambda (param)
			   (theme-target-compile-fwd linker param))
			 params))
	 (address (hfield-ref var 'address))
	 (var-name (get-target-var-name-fwd linker address)))
    `(define ,var-name
       (_i_get-concrete-param-ltype-inst ,t-param-ltype
					 (list ,@t-params)))))


(define (compile-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)
      '(quote ())
      (let ((var-name (get-target-var-name-fwd linker address))
	    (t-expr (theme-target-compile-fwd linker expr)))
	(list 'define var-name t-expr))))


(define (compile-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-fwd 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 (theme-target-compile-instance-predefs
			 linker instantiations))
	     (t-inst (theme-target-compile-instances linker instantiations))
	     (t-proc-expr (theme-target-compile-fwd 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)))


;; 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 (do-compile-param-proc-instance 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))))
	  (list '_i_make-procedure
		(theme-target-compile-fwd linker r-inst-type)
		(get-target-var-name-fwd
		 linker (hfield-ref (cdr r-inst) 'address))))
	;; We should enter here only when compiling parametrized procedures.
	(let* ((r-inst-type (get-entity-type repr))
	       (t-inst-type (theme-target-compile-fwd linker r-inst-type))
	       (t-param-proc (theme-target-compile-fwd linker r-param-proc))
	       (t-params (map* (lambda (r-param)
				 (theme-target-compile-fwd linker r-param))
			       r-params)))
	  `(_i_make-procedure
	    (begin 'param-proc-instance ,t-inst-type)
	    (lambda arguments
	      (apply (vector-ref ,t-param-proc i-param-proc-raw-proc)
		     (append (list ,@t-params) arguments))))))))


(define (do-compile-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-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-compile-fwd linker r-param-proc))
	 (t-params (map* (lambda (r-param)
			   (theme-target-compile-fwd linker r-param))
			 r-params)))
    `(_i_make-procedure
      ,t-inst-type
      (lambda arguments
	(apply (vector-ref ,t-param-proc i-param-proc-raw-proc)
	       (append (list ,@t-params) arguments))))))


(define (tcomp-entity linker entity)
  (hfield-set! linker 'current-toplevel-repr entity)
  (let ((result
	 (cond
	  ;; Objects have no effect as toplevel expressions.
	  ((is-target-object? entity)
	   '())
	  ((is-expression? 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-compile-fwd linker entity)))
	       (hash-clear! ht-cycles)
	       result)))
	  ((hrecord-is-instance? entity <linker-instance-predef>)
	   (theme-target-compile-instance-predef-fwd
	    linker
	    (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <linker-instance>)
	   (theme-target-compile-instance-fwd
		     linker
		     (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <factorized-expr>)
	   (compile-factorized-expr-fwd linker entity))
	  (else 
	   (dvar1-set! entity)
	   (raise 'invalid-entity)))))
    result))


(define (tcomp-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)))
    (let* ((sx-def1
	    (if (linker-entity-is-none? linker result-type)
		'(define main0
		   (lambda args
		     (if (_i_check-procedure-arg-list-type?
			  args
			  (vector-ref _main 0))
			 (apply (vector-ref _main 1) args)
			 (raise 'invalid-arguments-for-main))))
		'(define main0
		   (lambda args
		     (if (_i_check-procedure-arg-list-type?
			  args
			  (vector-ref _main 0))
			 (let ((result
				(apply (vector-ref _main 1) args)))
			   (theme-exit result))
			 (raise 'invalid-arguments-for-main))))))
	   (sx-def2
	    '(define main
	       (lambda (args)
		 (guard (exc (else
			      (my-error-exit exc)))
			(set-rte-exception-info! #t)
			(if (and (or (null? args)
				     (= (length args) 1))
				 (eq? (vector-ref
				       (vector-ref _main i-object-class)
				       i-procedure-class-arg-list-type)
				      _b_<null>))
			    (main0)
			    (main0 args)))))))
      (list sx-def1 sx-def2))))


(define (tcomp-define-racket-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))
	 (sx-def1
	  (if (linker-entity-is-none? linker result-type)
		'(define main0
		   (lambda args
		     (if (_i_check-procedure-arg-list-type?
			  args
			  (vector-ref _main 0))
			 (begin
			   (apply (vector-ref _main 1) args)
			   (void))
			 (raise 'invalid-arguments-for-main))))
		'(define main0
		   (lambda args
		     (if (_i_check-procedure-arg-list-type?
			  args
			  (vector-ref _main 0))
			 (let ((result
				(apply (vector-ref _main 1) args)))
			   (theme-exit result))
			 (raise 'invalid-arguments-for-main))))))
	 (sx-def2
	  '(define main
	     (lambda args
	       (guard (exc (else
			    (my-error-exit exc)))
		      (set-rte-exception-info! #t)
		      (if (and (null? args)
			       (eq? (vector-ref
				     (vector-ref _main i-object-class)
				     i-procedure-class-arg-list-type)
				    _b_<null>))
			  (main0)
			  ;; The first argument is the program name.
			  (main0 (cons "" args))))))))
    (list sx-def1 sx-def2)))

