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


;; *** Scheme target compilation with optimization ***


(import (th-scheme-utilities stdutils))


(define x-no-opt (vector 1))

(define theme-target-scheme-compile-fwd '())
(define tc-scheme-instance-fwd '())


(define (tc-scheme-compile-sequence linker l-target-exprs)
  (cons 'begin l-target-exprs))


(define (scm-make-instance-test linker t-obj expr-type)
  (assert (is-entity? expr-type))
  (cond
   ((eq? expr-type tc-object)
    #t)
   ((eq? expr-type tt-none)
    #f)
   ((not (is-known-object? expr-type))
    (let ((t-expr-type
	   (theme-target-scheme-compile-fwd linker expr-type)))
      (list '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))
    (list 'pair? t-obj))
   (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-scheme-compile-fwd linker expr-type)))
	    (cond
	     ((and (is-t-param-class-instance? expr-type)
		   (not (is-tc-pair? expr-type)))
	      (list '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.
	      (list 'is-instance-of-simple-class? t-obj t-expr-type))
	     (else 
	      (list 'is-instance? t-obj t-expr-type)))))))))


(define (scm-make-subtype-test linker ent-type1 ent-type2)
  (assert (is-entity? ent-type1))
  (assert (is-entity? ent-type2))
  (let ((sx-type1
	 (theme-target-scheme-compile-fwd linker ent-type1))
	(sx-type2
	 (theme-target-scheme-compile-fwd linker ent-type2)))
    (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)))
      (list 'is-subtype? sx-type1 sx-type2))
     ((is-t-simple-class? ent-type2)
      (list 'is-simple-class-subtype? sx-type1 sx-type2))
     ((and (is-t-param-class-instance? ent-type2)
	   (not (is-tc-pair? ent-type2)))
      (list 'is-param-inst-subclass? sx-type1 sx-type2))
     (else
      (list 'is-subtype? sx-type1 sx-type2)))))


(define (scm-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)))
      (list s-pred-name x1 x2))))


(define (scm-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)
      #t
      (let* ((type1 (tno-field-ref (car l-fields1) 'type))
	     (type2 (tno-field-ref (car l-fields2) 'type))
	     (x-elem1 (list 'vector-ref x-obj1 i))
	     (x-elem2 (list 'vector-ref x-obj2 i))
	     ;; No deep recursion into contents.
	     (x-test (scm-make-equiv-expression1 linker s-kind #f
						 type1 x-elem1
						 type2 x-elem2))
	     (x-next (scm-optimize-eq-by-value1 linker s-kind (+ i 1)
						(cdr l-fields1)
						(cdr l-fields2)
						x-obj1
						x-obj2)))
	`(if ,x-test ,x-next #f))))


(define (scm-is-var-ref? x)
  ;; Symbol constants are compiled to quote expressions.
  (symbol? x))


;; This procedure works only for noninheritable classes.
(define (scm-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 (scm-is-var-ref? x1)))
	       (wrap2? (not (scm-is-var-ref? x2)))
	       (x-obj1
		(if wrap1?
		    (tc-scheme-var-ref0 linker
					(linker-alloc-loc linker 'tmp1 #f))
		    x1))
	       (x-obj2
		(if wrap2?
		    (tc-scheme-var-ref0 linker
					(linker-alloc-loc linker 'tmp2 #f))
		    x2))
	       (x-body (scm-optimize-eq-by-value1 linker s-kind 1
						  l-fields1
						  l-fields2
						  x-obj1
						  x-obj2))
	       (x-body2
		(if wrap2?
		    `(let ((,x-obj2 ,x2)) ,x-body)
		    x-body))
	       (x-body1
		(if wrap1?
		    `(let ((,x-obj1 ,x1)) ,x-body2)
		    x-body2)))
	  x-body1)
	x-no-opt)))

	    
(define (scm-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 (scm-is-var-ref? x1)))
	 (wrap2? (not (scm-is-var-ref? x2)))
	 (x-obj1
	  (if wrap1?
	      (tc-scheme-var-ref0 linker
				  (linker-alloc-loc linker 'tmp1 #f))
	      x1))
	 (x-obj2
	  (if wrap2?
	      (tc-scheme-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))
	 (x-elem11 (list 'car x-obj1))
	 (x-elem12 (list 'cdr x-obj1))
	 (x-elem21 (list 'car x-obj2))
	 (x-elem22 (list 'cdr x-obj2))
	 ;; No deeper recursion.
	 (x-test1 (scm-make-equiv-expression1 linker s-kind #f
					      type11 x-elem11
					      type21 x-elem21))
	 (x-test2 (scm-make-equiv-expression1 linker s-kind #f
					      type12 x-elem12
					      type22 x-elem22))
	 (x-body
	  `(if ,x-test1 ,x-test2 #f))
	 (x-body2
	  (if wrap2?
	      `(let ((,x-obj2 ,x2)) ,x-body)
	      x-body))
	 (x-body1
	  (if wrap1?
	      `(let ((,x-obj1 ,x1)) ,x-body2)
	      x-body2)))
    x-body1))


(define (scm-make-equiv-expression2
	 linker s-kind rec? type1 x-arg1 type2 x-arg2)
  (let* ((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.
		 (list 'eqv? x-arg1 x-arg2))
		((eq? s-pred1 s-pred2)
		 (list s-pred1 x-arg1 x-arg2))
		(else x-no-opt))))
	    ((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?))
		 x-no-opt)
		((and s-pred1 (eq? s-pred1 s-pred2))
		 ;; If type1 and type2 are custom primitive classes
		 ;; they should be equal here.
		 (list 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?)))
		 (list '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?))
		 (scm-optimize-eq-by-value linker s-kind
					   type1 x-arg1
					   type2 x-arg2))
		(else x-no-opt))))
	    ((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?))
		 x-no-opt)
		((and s-pred1 (eq? s-pred1 s-pred2))
		 (list 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.
		 (scm-optimize-eq-by-value linker s-kind
					   type1 x-arg1
					   type2 x-arg2))
		(else x-no-opt))))
	    (else (raise 'internal-error)))))
    (if (not (eq? x-opt x-no-opt))
	x-opt
	(scm-make-normal-equiv-expression linker s-kind
					  x-arg1 x-arg2))))


(define (scm-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)))
    (if (and cl1? cl2?
	     (not (is-t-subtype? binder type1 type2))
	     (not (is-t-subtype? binder type2 type1)))
	#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)
	      (list s-pred x-arg1 x-arg2)))
	   ((or (not cl1?) (not cl2?))
	    (scm-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?)
	      (list 'eq? x-arg1 x-arg2))
	     (rec?
	      (scm-optimize-pair-eq-by-value linker s-kind
					     type1 x-arg1 type2 x-arg2))
	     (else
	      (scm-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?)
		(list 'eq? x-arg1 x-arg2)
		(scm-make-normal-equiv-expression
		 linker s-kind x-arg1 x-arg2)))
	   (else
	    (scm-make-equiv-expression2 linker s-kind rec?
					type1 x-arg1 type2 x-arg2)))))))


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


(define (tc-scheme-var-ref0 linker address)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address <address>))
  (get-target-var-name linker address))


(define (tc-scheme-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)))
	  (list 'check-var-unspecified s-name
		(list 'quote s-source-name)))
	(tc-scheme-var-ref0 linker address))))


(define (tc-scheme-primitive-object linker repr)
  (assert (hfield-ref repr 'primitive?))
  (cond
   ((is-t-atomic-object? repr)
    (if (not (memq (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 (tc-scheme-compile-type-var linker tvar)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (is-t-type-variable? tvar))
  (tc-scheme-var-ref0 linker (hfield-ref tvar 'address)))


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


(define (tc-scheme-letrec-unspecified-check linker expr s-var-name)
  (list 'check-letrec-unspecified expr (list 'quote s-var-name)))


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


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


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


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


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


(define (tc-scheme-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-gensyms (map (lambda (address)
			     (get-target-var-name linker address))
			   lst-addr)))
    (cond
     (simple-args?
      (let ((t-body1 (tc-scheme-call-stack-debug linker repr t-body)))
	`(lambda ,lst-gensyms ,t-body1)))
     (simple-args-with-tail?
      (let ((t-body1 (tc-scheme-call-stack-debug linker repr t-body)))
	`(lambda (,@(drop-right lst-gensyms 1) . ,(last 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-actual-body
	      (if (not-null? t-args)
		  (tc-scheme-construct-procedure0 linker
						  lst-gensyms t-body
						  t-arg-descs
						  sym-args-gensym)
		  t-body))
	     (t-actual-body1 (tc-scheme-call-stack-debug linker repr
							 t-actual-body)))
	`(lambda ,sym-args-gensym ,t-actual-body1))))))


(define (tc-scheme-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-gensyms (get-gensyms linker l-all-args))
	 (t-body1 (tc-scheme-call-stack-debug linker repr t-body)))
    `(lambda ,l-gensyms ,t-body1)))


(define (tc-scheme-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-gensyms (get-gensyms linker l-all-args))
	 (l-normal-gensyms (drop-right l-gensyms 1))
	 (l-rest-gensym (last l-gensyms))
	 (t-body1 (tc-scheme-call-stack-debug linker repr t-body)))
    `(lambda (,@l-normal-gensyms . ,l-rest-gensym) ,t-body1)))


(define (tc-scheme-param-proc-body-nonsimple-args
	 linker repr l-params t-body l-args t-arg-descs s-name)
  (let* ((l-param-gensyms (get-gensyms linker l-params))
	 (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-actual-body
	  (tc-scheme-construct-procedure0 linker
					  l-arg-gensyms
					  t-body t-arg-descs
					  s-args-gensym))
	 (t-actual-body1 (tc-scheme-call-stack-debug linker repr
						     t-actual-body)))
    `(lambda (,@l-param-names . ,s-args-gensym)
       ,t-actual-body1)))


(define (tc-scheme-param-proc-body-no-args
	 linker repr l-params t-body s-name)
  (let* ((l-gensyms (get-gensyms linker l-params))
	 (t-body1 (tc-scheme-call-stack-debug linker repr t-body)))
    `(lambda ,l-gensyms ,t-body1)))


(define (tc-scheme-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-scheme-generate-type-check linker t-body
					    t-result-type-desc))))
    (cond
     ((null? l-args)
      (tc-scheme-param-proc-body-no-args
       linker repr l-params t-body1 s-name))
     (simple-args?
      (tc-scheme-param-proc-body-simple-args
       linker repr l-params t-body1 l-args s-name))
     (simple-args-with-tail?
      (tc-scheme-param-proc-body-simple-args-with-tail
       linker repr l-params t-body1 l-args s-name))
     (else
      (tc-scheme-param-proc-body-nonsimple-args
       linker repr l-params t-body1 l-args t-arg-descs s-name)))))


(define (tc-scheme-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-scheme-compile linker desc))
			   arg-descs))
	 (body (hfield-ref repr 'body))
	 (c-body (theme-target-scheme-compile linker body))
	 (type (get-entity-type repr))
	 (c-type (theme-target-scheme-compile linker type))
	 (result-type (hfield-ref repr 'result-type))
	 (c-result-type (theme-target-scheme-compile linker result-type))
	 (s-name (hfield-ref repr 's-name)))
    (list '_i_make-procedure
	  c-type
	  (tc-scheme-construct-procedure linker repr args c-body
					 c-arg-descs
					 c-result-type
					 simple? simple-with-tail?
					 s-name))))


(define (tc-scheme-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-scheme-compile linker desc))
			   arg-descs))
	 (body (hfield-ref repr 'body))
	 (c-body (theme-target-scheme-compile linker body))
	 (type (get-entity-type repr))
	 (c-type (theme-target-scheme-compile linker type))
	 (result-type (hfield-ref repr 'result-type))
	 (c-result-type (theme-target-scheme-compile linker result-type)))
    (let ((no-result? (linker-entity-is-none? linker result-type))
	  (type-dispatched? (entity-type-dispatched? body)))
      (tc-scheme-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-scheme-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-scheme-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))))
	      (let ((t-check
		     (cond
		      ((or (not (is-known-object? result-type))
			   (not (is-t-class? result-type)))
		       '(is-subtype? cl result-type))
		      ((is-t-simple-class? result-type)
		       '(is-simple-class-subtype? cl result-type))
		      ((and (is-t-param-class-instance? result-type)
			    (not (is-tc-pair? result-type)))
		       '(is-param-inst-subclass? cl result-type))
		      (else
		       '(is-subtype? cl result-type)))))
		`(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))
		      (,t-check
		       result)
		      (else
		       (_i_result-type-error
			result
			result-type
			,str-source-name)))))))))))
  
	  
(define (tc-scheme-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 ((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 linker type '() #f)
		       name))
		((is-tc-param-proc? type)
		 (list '_i_make-param-proc
		       (tcomp-object 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)))
		   (l-gensyms (get-gensyms linker l-tvars)))
	       `(lambda (,@l-gensyms . arguments)
		  (apply ,name arguments))))))
    result))


(define (tc-scheme-param-prim-proc-wrapper linker address result-type
					   l-tvars)
  (let ((name (get-target-var-name linker address))
	(t-result-type (theme-target-scheme-compile linker result-type))
	(source-name (hfield-ref address 'source-name))
	(l-gensyms (get-gensyms linker l-tvars)))
    (if (linker-entity-is-none? linker result-type)
	`(lambda (,@l-gensyms . arguments)
	   (apply ,name arguments))
	`(lambda (,@l-gensyms . 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 (tc-scheme-param-prim-proc-wrapper2 linker address type result-type
					    l-tvars)
  ;; <none> result type must be taken care by the caller.
  (let ((name (get-target-var-name linker address))
	(t-type (theme-target-scheme-compile linker type))
	(t-result-type (theme-target-scheme-compile linker result-type))
	(source-name (hfield-ref address 'source-name))
	(l-gensyms (get-gensyms linker l-tvars)))
    (list '_i_make-param-proc
	  t-type
	  `(lambda (,@l-gensyms . arguments)
	     (let ((result
		    (apply ,name
			   (make-list-with-tail (list ,@l-gensyms) arguments)))
		   (result-type ,t-result-type))
	       (_i_check-result-type
		result result-type
		(symbol->string (quote ,source-name)))
	       result))
	  '(quote ()))))


(define (tc-scheme-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-scheme-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)))
	       (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)
			 (tc-scheme-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)))
	       (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)))
		   (tc-scheme-param-prim-proc-wrapper2
		    linker
		    (hfield-ref repr 'address)
		    type
		    result-type
		    tvars))))
	    (else (raise 'internal-error-1)))))
      result)))


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


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


(define (tc-scheme-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-scheme-compile linker cur-init-value)))
	      (set! body
		    (append body
			    (list
			     (list 'vector-set! object-arg i t-contents))))))))
    body))



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


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


(define (tc-scheme-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-scheme-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)))
	  (address-hash-set! (get-ht-raw-procs linker)
			     (hfield-ref variable 'address)
			     addr-raw)
	  `(_splice ,t-expr1
		    (define ,s-raw-name
		      (vector-ref ,s-var-name 1))))
	t-expr1)))


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


(define (tc-scheme-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-scheme-compile
			  linker
			  (hfield-ref repr 'value-expr)))
			(r-type
			 (get-entity-type (hfield-ref repr 'variable))))
		    (tc-scheme-declared-var-def linker address t-expr r-type
						read-only?))
		  (tc-scheme-nondeclared-var-def linker repr))))
	(assert (hfield-ref address 'toplevel?))
	result)
      (begin
	'(quote ()))))


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


(define (scm-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)))
	`(lambda args (proc-not-linked (quote ,s-name))))
      '(quote ())))


(define (tc-scheme-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
	 ((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
		  (scm-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
		(vector _b_unspecified ,x-default-impl))
	      (define ,s-raw-name ,x-default-impl))))
	 ((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 (tc-scheme-prim-proc-ref linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (tc-scheme-compile-prim-proc-ref linker repr #f '()))


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


(define (tc-scheme-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-scheme-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 ((t-args (map* comp args)))
	(strong-assert (= (length t-args) 2))
	`(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)))
	(scm-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)))
	(scm-make-subtype-test linker ent-type1 ent-type2)))
     ((eq? proc tp-equal-values)
      (strong-assert (= (length args) 2))
      ;; Arguments are not compiled here.
      (scm-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.
      (scm-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.
      (scm-make-equiv-expression linker 'equal-contents?
				 (car args) (cadr args)))
     (else
      (let* ((t-proc (theme-target-scheme-compile linker proc))
	     (t-args (map* comp args)))
	(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)))
		    (cons s-var-name t-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 (tc-scheme-apply-expr linker repr)
  (let* ((arglist (hfield-ref repr 'arglist))
	 (proc (car arglist))
	 (arglist2 (cadr arglist))
	 (comp (lambda (rexpr) (theme-target-scheme-compile linker rexpr)))
	 (t-proc (comp proc))
	 (t-arglist2 (comp arglist2)))
    (if (is-tc-simple-proc? (get-entity-type proc))
	`(apply (vector-ref ,t-proc 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)))
		      (cons 'list t))
		    (comp static-arg-types))))
	  `(_i_call-proc ,t-proc ,t-arglist2 (cadr ,t-static))))))


(define (tc-scheme-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-scheme-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)))
	      (cons 'list t)))
	   (else
	    (comp static-arg-types))))
	 (result
	  `(_i_call-param-proc
	    ,t-param-proc
	    (list ,@t-args)
	    ,t-static)))
    result))


(define (tc-scheme-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-scheme-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))))
		(list 'cons t-args)
		(let* ((t-proc (theme-target-scheme-compile linker proc))
		       (comp (lambda (rexpr)
			       (theme-target-scheme-compile linker rexpr)))
		       (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)))
			      (cons 'list t))
			    (comp static-arg-types))))
		  (if (and (not (hfield-ref repr 'runtime-arglist-typecheck?))
			   (and-map? entity-type-dispatched? args))
		      `(_i_call-proc ,t-proc (list ,@t-args) ,t-static)
		      `(let ((proc ,t-proc)
			     (args (list ,@t-args))
			     (l-static ,t-static))
			 (if (is-instance-of-simple-class?
			      (vector-ref proc i-object-class)
			      _b_:simple-proc)
			     (_i_call-proc
			      proc
			      (check-arglist-type proc args '())
			      l-static)
			     (_i_call-proc proc args l-static))))))))
      result)))


(define (tc-scheme-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-scheme-compile linker (hfield-ref repr 'proc)))
	 (t-arglist
	  (map* (lambda (repr-arg)
		  (theme-target-scheme-compile linker repr-arg))
		(hfield-ref repr 'arglist)))
	 (t-expr
	  `(_i_call-generic-proc ,t-proc (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-scheme-compile
    ;; 			    linker (get-entity-type repr))))
    ;; 	  (tc-scheme-generate-type-check linker t-expr t-type-expr))
    ;; 	t-expr)))
    t-expr))

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


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


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


(define (tc-scheme-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-scheme-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-scheme-param-proc-body
			 linker repr (hfield-ref repr 'body) l-params s-name))
	   (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?)
      (list '_i_make-param-proc t-type t-proc-body (list 'quote s-name)))))


(define (tc-scheme-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-scheme-compile linker repr1)))
	 (t-condition
	  (if (or (entity-type-dispatched? condition)
		  (not (hfield-ref repr 'boolean-cond?)))
	      (comp condition)
	      (tc-scheme-generate-type-check linker
					     (comp condition)
					     (comp tc-boolean)))))
    (cond
     ((equal? t-condition #t) (comp then-expr))
     ((equal? t-condition #f) (comp else-expr))
     (else
      (if (is-empty-expr? else-expr)
	  (if (eq? (hfield-ref linker 's-intermediate-language)
		   'racket)
	    `(if ,t-condition ,(comp then-expr) (void))
	    `(if ,t-condition ,(comp then-expr)))
	  `(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-scheme-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-scheme-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-scheme-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))
	   (t-header
	    (if (is-empty-expr? result)
		`(,t-condition)
		`(,t-condition ,t-result))))
      `(do () ,t-header ,t-body))))


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


(define (tc-scheme-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-scheme-compile linker init-expr)
		     (tc-scheme-generate-type-check
		      linker
		      (theme-target-scheme-compile linker init-expr)
		      (theme-target-scheme-compile linker
						    type)))))
	    (list s-source-name t-var-name type-check))
	  (list
	   s-source-name
	   t-var-name
	   (theme-target-scheme-compile linker init-expr))))))


(define (tc-scheme-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-scheme-compile linker init-expr))
	   (t-init-expr (tc-scheme-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-scheme-generate-type-check
		      linker
		      t-init-expr
		      (theme-target-scheme-compile linker
						   type)))))
	    (list s-source-name t-var-name type-check))
	  (list
	   s-source-name
	   t-var-name
	   t-init-expr)))))


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


(define (tc-scheme-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-scheme-parse-let-variables linker variables
						       recursive?))
	   (t-body (theme-target-scheme-compile linker body))
	   (t-gensyms (map cadr t-variables))
	   (t-vals (map caddr t-variables)))
      (assert (= (length t-gensyms) (length t-vals)))
      (let ((t-var-exprs (map list t-gensyms t-vals)))
	(list keyword
	      t-var-exprs
	      t-body)))))


(define (tc-scheme-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-scheme-compile linker value-expr))
	    ((hrecord-is-instance? value-expr <variable-reference>)
	     (let* ((t-obj
		     (tc-scheme-var-ref0
		      linker
		      (hfield-ref (hfield-ref value-expr 'variable)
				  'address)))
		    (t-test (scm-make-instance-test linker t-obj type))
		    (t-default-expr
		     (if (is-empty-expr? default-expr)
			 (list '_i_cast-error
			       (theme-target-scheme-compile linker
							    type)
			       t-obj)
			 (theme-target-scheme-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
		     (scm-make-instance-test linker s-gensym-obj type))
		    (t-value-expr (theme-target-scheme-compile
				   linker value-expr))
		    (t-default-expr
		     (if (is-empty-expr? default-expr)
			 (list '_i_cast-error
			       (theme-target-scheme-compile linker
							    type)
			       s-gensym-obj)
			 (theme-target-scheme-compile
			  linker default-expr))))
	       `(let ((,s-gensym-obj ,t-value-expr))
		  (if ,t-test ,s-gensym-obj ,t-default-expr)))))))
      result)))


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


(define (tc-scheme-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* ((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
			 (scm-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-scheme-compile linker
							      tt-constructor))
		     (ctr
		      (tc-scheme-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 (tc-scheme-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-scheme-compile-class-def linker repr)
      '(quote ())))


(define (tc-scheme-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-scheme-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)))
	  (if (and (is-target-object? r-object)
		   (or
		    (hfield-ref r-object 'incomplete?)
		    (eq? (hfield-ref r-object 'al-field-values) #f)))
	      `(check-field-unspecified (vector-ref ,t-object ,field-index)
					(quote ,r-field-name))
	      (list 'vector-ref t-object field-index))))
       ((symbol? r-field-name)
	(list '_i_field-ref t-object `(quote ,r-field-name)))
       (else
	(let ((t-field-name (theme-target-scheme-compile linker
							 r-field-name)))
	  (list '_i_field-ref t-object t-field-name)))))))

       
(define (tc-scheme-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-scheme-compile linker r-object))
	   (t-field-value (theme-target-scheme-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-scheme-compile linker
						       r-field-type))
			 (t-wrapped-value
			  (if (entity-type-dispatched? r-field-value)
			      t-field-value
			      (tc-scheme-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-scheme-compile linker r-field-name)
		    t-field-value)))))
      result)))


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


(define (tc-scheme-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* ((var-name (get-target-var-name-for-loc linker var))
		    (r-super
		     (tno-field-ref val 'cl-instance-superclass))
		    (t-super (theme-target-scheme-compile linker r-super))
		    (t-fields
		     (scm-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 (tc-scheme-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-scheme-param-class-def0 linker repr)
      '(quote ())))


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


(define (tc-scheme-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-scheme-compile linker expr-to-eval))
	 (opt? (list-ref lst-clause 3)))
    (assert (boolean? opt?))
    (cond
     ((and has-var? (not opt?))
      (list (scm-make-instance-test linker t-obj-match-ref expr-type)
	`(let ((,s-var-gensym ,t-obj-match-ref))
	   ,texpr-to-eval)))
     ((and has-var? opt?)
      `(#t
	(let ((,s-var-gensym ,t-obj-match-ref))
	  ,texpr-to-eval)))
     ((and (not has-var?) (not opt?))
      (list (scm-make-instance-test linker t-obj-match-ref expr-type)
	    texpr-to-eval))
     ((and (not has-var?) opt?)
      `(#t ,texpr-to-eval))
     (else
      ;; We should not arrive here.
      (raise 'internal-error)))))


(define (tc-scheme-match-type-body linker t-clauses t-else)
  (assert (list? t-clauses))
  `(cond
    ,@t-clauses
    (else ,t-else)))


(define (tc-scheme-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-scheme-compile linker expr-to-match))
	 (texpr-match-var-ref? (scm-is-var-ref? texpr-to-match))
	 (s-gensym-obj-match
	  (if (not texpr-match-var-ref?)
	      (get-target-var-name linker
				   (linker-alloc-loc linker 'obj-match #f))
	      '()))
	 (t-obj-match-ref
	  (if (not texpr-match-var-ref?)
	      s-gensym-obj-match
	      texpr-to-match))
	 (texpr-clauses
	  (map (lambda (lst-repr-clause)
		 (tc-scheme-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))
	      '(_i_match-type-strong-no-match)
	      (theme-target-scheme-compile linker expr-else)))
	 (t-body (tc-scheme-match-type-body linker texpr-clauses texpr-else)))
    (if (not texpr-match-var-ref?)
	`(let ((,s-gensym-obj-match ,texpr-to-match))
	   ,t-body)
	t-body)))


;; 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-scheme-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 (eq? r-inst #f))
	(let ((r-inst-type (get-entity-type (cdr r-inst))))
	  (list '_i_make-procedure
		(theme-target-scheme-compile linker r-inst-type)
		(get-target-var-name
		 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-scheme-compile linker r-inst-type))
	       (t-param-proc (theme-target-scheme-compile linker r-param-proc))
	       (t-params
		(map* (lambda (r-param)
			(theme-target-scheme-compile 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 (tc-scheme-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-scheme-compile linker r-inst-type))
	 (r-param-proc (hfield-ref repr 'param-proc))
	 (r-params (hfield-ref repr 'params))
	 (t-param-proc (theme-target-scheme-compile linker r-param-proc))
	 (t-params
	  (map* (lambda (r-param)
		  (theme-target-scheme-compile 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 (tc-scheme-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-scheme-param-proc-instance1 linker repr)
      (tc-scheme-param-proc-instance-expr linker repr)))


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


(define (tc-scheme-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 (tc-scheme-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-scheme-compile linker gen-proc)))
	    (if (not (symbol? t-gen-proc))
		(raise 'invalid-method-definition))
	    (let ((t-procexpr (theme-target-scheme-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 (tc-scheme-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 (tc-scheme-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-scheme-compile linker result-type)))
	  (list '_i_dispatch-generic-proc
		(theme-target-scheme-compile
		 linker (hfield-ref repr 'generic-proc))
		t-result-type
		(cons 'list
		      (map* (lambda (repr-arg)
			      (theme-target-scheme-compile linker repr-arg))
			    (hfield-ref repr 'arg-types)))
		appl-pure? appl-always-returns? appl-never-returns?))
	(list '_i_dispatch-generic-proc
	      (theme-target-scheme-compile
	       linker (hfield-ref repr 'generic-proc))
	      (quote '())
	      (cons 'list
		    (map* (lambda (repr-arg)
			    (theme-target-scheme-compile linker repr-arg))
			  (hfield-ref repr 'arg-types)))
	      appl-pure? appl-always-returns? appl-never-returns?))))


(define (tc-scheme-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 (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 (tc-scheme-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-scheme-prim-class-def0 linker repr)
      '(quote ())))


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


(define (tc-scheme-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-scheme-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))))))


(define (tc-scheme-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)
			    (tc-scheme-signature-member linker r-member))
			  r-members)))
    `(make-param-signature (list ,@t-tvar-objects)
			   ((lambda ,t-tvars (list ,@t-members))
			    ,@t-tvar-objects))))


(define (tc-scheme-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 (tc-scheme-force-pure-expr linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? repr <force-pure-expr>))
  (theme-target-scheme-compile-fwd linker
				   (hfield-ref repr 'repr-component)))


(define (tc-scheme-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-scheme-compile linker
					  (hfield-ref repr 'condition)))
	    (condition-source-expr (hfield-ref repr 'condition-source-expr)))
	
	(if (eq? (hfield-ref linker 's-intermediate-language) 'racket)
	    `(if (not ,t-condition)
		 (_i_raise-assertion-failed (quote ,condition-source-expr))
		 (void))
	    `(if (not ,t-condition)
		 (_i_raise-assertion-failed (quote ,condition-source-expr)))))
      '(quote ())))


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


(define (theme-target-scheme-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-scheme-primitive-object linker repr))
	    ((is-expression? repr)
	     (let ((proc (hrecord-type-inquire tc-scheme-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-scheme-compile-fwd theme-target-scheme-compile)


(define (tc-scheme-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)))
    (dvar1-set! instance)
    (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 param-class ht-cycles '())
		      (for-each (lambda (ent)
				  (detect-cycles binder ent ht-cycles '()))
				params)
		      (let ((result
			     (tc-scheme-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-scheme-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! tc-scheme-instance-fwd tc-scheme-instance)


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


(define (tc-scheme-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-scheme-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)))
    ;; 	   (tc-scheme-param-ltype-instance-predef var-name))))
    (else '())))


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


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


(define (tc-scheme-param-ltype-instantiation linker var param-ltype params)
  (let* ((t-param-ltype (theme-target-scheme-compile linker param-ltype))
	 (t-params (map* (lambda (param)
			   (theme-target-scheme-compile 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 (tc-scheme-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 linker address))
	    (t-expr (theme-target-scheme-compile linker expr)))
	(list 'define var-name t-expr))))


(define (tc-scheme-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-scheme-instance-predefs
			 linker instantiations))
	     (t-inst (tc-scheme-instances linker instantiations))
	     (t-proc-expr (theme-target-scheme-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-scheme-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-scheme-compile linker entity)))
	       (hash-clear! ht-cycles)
	       result)))
	  ((hrecord-is-instance? entity <linker-instance-predef>)
	   (tc-scheme-instance-predef
	    linker
	    (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <linker-instance>)
	   (tc-scheme-instance
	    linker
	    (hfield-ref entity 'lst-instance)))
	  ((hrecord-is-instance? entity <factorized-expr>)
	   (compile-factorized-expr linker entity))
	  (else 
	   (dvar1-set! entity)
	   (raise 'invalid-entity)))))
    result))
