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



;; *** Phase 2 compilation ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(ice-9 pretty-print)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define theme-compile-repr-fwd '())
(define do-compile-object-fwd '())
(define theme-compile-object-fwd '())
(define theme-compile-object0-fwd '())


(define gl-ctr4 0)
(define gl-ctr15 0)
(define gl-flag5? #f)


(define (debug-print-address address)
  (d2wl 'debug1 (hfield-ref address 'module))
  (d2wl 'debug1 (hfield-ref address 'number))
  (d2wl 'debug1 (hfield-ref address 'source-name))
  (d2wl 'debug1 (hfield-ref address 'toplevel?)))


(use-modules (srfi srfi-19))

(define (display-time)
  (dwl3 (current-time time-utc)))


;; This is not for toplevel variables.
(define (theme-compile-variable compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (list 'internal-variable
	(theme-compile-address (hfield-ref var 'address))
	(theme-compile-repr compiler env (get-entity-type var))
	(hfield-ref var 'type-dispatched?)
	(hfield-ref var 'exact-type?)
	(hfield-ref var 'read-only?)
	(hfield-ref var 'volatile?)
	(hfield-ref var 'forward-decl?)))


(define (theme-compile-declared-variable compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (let* ((p-address (theme-compile-address (hfield-ref var 'address)))
	 (p-type (theme-compile-repr compiler env (get-entity-type var))))
    (list 'internal-variable
	  p-address
	  p-type
	  (hfield-ref var 'type-dispatched?)
	  (hfield-ref var 'exact-type?)
	  (hfield-ref var 'read-only?)
	  (hfield-ref var 'volatile?)
	  #t)))


;; TBD: Remove the following procedure.
(define (theme-compile-variable-with-expr compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (list 'internal-variable-with-expr
	(theme-compile-address (hfield-ref var 'address))
	(theme-compile-repr compiler env (get-entity-type var))
	(hfield-ref var 'type-dispatched?)
	(hfield-ref var 'exact-type?)
	(hfield-ref var 'read-only?)
	(hfield-ref var 'volatile?)
	(hfield-ref var 'forward-decl?)
	(theme-compile-repr compiler env (hfield-ref var 'value-expr))))


(define (theme-compile-tvar-address repr)
  (assert (is-t-type-variable? repr))
  (theme-compile-address (hfield-ref repr 'address)))


(define (compile-type-variables type-vars)
  (map theme-compile-tvar-address type-vars))


;; TBD: Remove the following procedure.
(define (compile-object-field compiler env field)
  (cons (car field)
	(theme-compile-repr compiler env (cdr field))))


;; TBD: Remove the following procedure.
(define (compile-object-fields compiler env obj)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? obj))
  (let ((field-values (hfield-ref obj 'al-field-values)))
    (map* (lambda (field) (compile-object-field compiler env field))
	  field-values)))


(define (compile-primitive-object compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
  (assert (hfield-ref to 'primitive?))
  (cond
   ((memq to lst-visited) (raise 'illegal-cycle-in-primitive-object))
   ((eqv? to to-nil)
    (list 'primitive-value '()))
   (else
    (list 'primitive-value (hfield-ref to 'obj-prim-contents)))))


(define (compile-scheme-primitive-value compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-primitive-object? repr))
  (if (and (not (is-t-atomic-object? repr))
	   (not-null? (hfield-ref repr 'address)))
      (co-object-with-address compiler env repr '())
      (compile-primitive-object compiler env repr '())))


;; TBD: Remove the following procedure.
(define (parse-type-expr compiler env type-expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? type-expr))
  (assert (is-t-subtype?
	   (compiler-get-binder compiler)
	   (get-entity-type type-expr)
	   tt-type))
  (theme-compile-repr compiler env type-expr))


(define (compute-class-field-repr compiler env field)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-field? field))
  (let ((sym-name (tno-field-ref field 's-name))
	(to-type (tno-field-ref field 'type))
	(acc-read (tno-field-ref field 's-read-access))
	(acc-write (tno-field-ref field 's-write-access))
	(has-init-value? (tno-field-ref field 'has-init-value?))
	(obj-init-value (tno-field-ref field 'x-init-value)))
    (let* ((t-type (theme-compile-repr compiler env to-type))
	   (t-init-value
	    (if has-init-value?
		(theme-compile-repr compiler env obj-init-value)
		'(empty))))
      (list sym-name t-type acc-read acc-write has-init-value? t-init-value))))


(define (compute-class-fields-repr compiler env fields)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (map (lambda (fld) (compute-class-field-repr compiler env fld)) fields))


(define (compute-class-decl compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (let ((val (hfield-ref var 'value)))
    (if (null? val)
	(raise 'class-declaration-missing)
	(cond
	 ((and (hrecord-is-instance? val <target-object>)
	       (is-t-instance?
		(compiler-get-binder compiler)
		val tc-class))
	  (let ((r-super
		 (tno-field-ref val 'cl-superclass))
		(name (tno-field-ref val 'str-name)))

	    (let ((p-super
		   (theme-compile-repr compiler env r-super)))
	      (let ((result
		     `(define-class
			,name
			,p-super
			,(compute-class-fields-repr
			  compiler
			  env
			  (tno-field-ref val 'l-fields))
			,(tno-field-ref val 'inheritable?)
			,(tno-field-ref val 'immutable?)
			,(tno-field-ref val 'eq-by-value?)
			,(tno-field-ref val 's-ctr-access))))
		result))))
	 (else (raise 'internal-error-in-class))))))


(define (do-compute-param-class-decl compiler env val)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (cond
   ((and (hrecord-is-instance? val <target-object>)
	 (is-t-instance? (compiler-get-binder compiler) val tc-class))
    (let ((r-inst-super
	   (tno-field-ref val 'cl-instance-superclass))
	  (r-inst-fields
	   (tno-field-ref val 'l-instance-fields))
	  (name (tno-field-ref val 'str-name)))
      (let* ((p-inst-super
	      (theme-compile-repr compiler env r-inst-super))
	     (p-inst-fields (compute-class-fields-repr
			     compiler env r-inst-fields)))
	(let ((result
	       `(p-class ,name
			 ,p-inst-super
			 ,p-inst-fields
			 ,(tno-field-ref val 'instances-inheritable?)
			 ,(tno-field-ref val 'instances-immutable?)
			 ,(tno-field-ref val 'instances-eq-by-value?)
			 ,(tno-field-ref val 's-instance-ctr-access))))
	  result))))
   (else (raise 'internal-error-in-class))))


(define (compute-param-class-decl compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (let ((obj (hfield-ref var 'value)))
    (if (not-null? obj)
	(let* ((type-vars (compile-type-variables
			   (tno-field-ref obj 'l-tvars)))
	       (class-decl (do-compute-param-class-decl compiler env obj))
	       (result
		(list 'define-param-class
		      type-vars
		      class-decl)))
	  result)
	(raise 'class-description-not-found))))


(define (compute-param-logical-type-decl compiler env var)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (let ((obj (hfield-ref var 'value)))
    (strong-assert (not-null? obj))
    (let* ((name (tno-field-ref obj 'str-name))
	   (type-vars (compile-type-variables
		       (tno-field-ref obj 'l-tvars)))
	   (p-value-expr
	    (theme-compile-repr compiler env
				(tno-field-ref obj 'x-value-expr))))
      (list 'define-param-logical-type
	    name
	    type-vars
	    p-value-expr))))


(define (compute-variable-def compiler env var type-decl value-expr
			      prevent-stripping?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? var <normal-variable>))
  (assert (is-entity? value-expr))
  (let* ((interface-read-expr?
	  ;; Not sure if incomplete objects work here.
	  (is-target-object? value-expr))
	 (t-type-decl (theme-compile-repr compiler env type-decl))
	 (t-value-expr (theme-compile-repr compiler env value-expr)))
    `(define-variable
       ,t-type-decl
       ,interface-read-expr?
       ,t-value-expr
       ,prevent-stripping?)))


(define (do-compute-general-variable-def compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? expr <variable-definition>))
  (let* ((var (hfield-ref expr 'variable))
	 (value (hfield-ref var 'value)))
    (cond 
     ((hrecord-is-instance? expr <param-class-definition>)
      (compute-param-class-decl compiler env var))
     ((hrecord-is-instance? expr <param-logical-type-def>)
      (compute-param-logical-type-decl compiler env var))
     ((hrecord-is-instance? expr <class-definition>)
      (compute-class-decl compiler env var))
     (else (compute-variable-def compiler env var
				 (hfield-ref expr 'type-decl)
				 (hfield-ref expr 'value-expr)
				 (hfield-ref expr 'prevent-stripping?))))))


(define (compute-general-variable-def compiler env expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (strong-assert (hrecord-is-instance? expr <variable-definition>))
  (let* ((var (hfield-ref expr 'variable))
	 (r-address (hfield-ref var 'address))
	 (p-address (theme-compile-address r-address))
	 (name (hfield-ref r-address 'source-name))
	 (forward-decl? (hfield-ref var 'forward-decl?))
	 (declared? (hfield-ref expr 'declared?))
	 (exact-type? (hfield-ref var 'exact-type?))
	 (read-only? (hfield-ref var 'read-only?))
	 (volatile? (hfield-ref var 'volatile?))
	 (contents
	  (do-compute-general-variable-def compiler env expr)))
    (list name forward-decl? declared?
	  p-address exact-type? read-only? volatile? contents)))


(define (cr-general-variable-def compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <variable-definition>))
  (cons 'general-variable
	(compute-general-variable-def compiler env repr)))


(define (cr-gen-proc-def compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <generic-procedure-definition>))
  (let* ((r-address (hfield-ref (hfield-ref repr 'variable) 'address))
	 (c-address (theme-compile-address r-address)))
    (list 'gen-proc c-address)))


(define (cr-set-expr compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <set-expression>))
  (let ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	(value-expr (hfield-ref repr 'value-expr))
	(need-revision? (hfield-ref repr 'need-revision?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?)))
    `(set! ,need-revision?
	   ,always-returns?
	   ,never-returns?
	   ,(theme-compile-address address)
	   ,(theme-compile-repr compiler env value-expr))))


(define (cr-var-ref compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <variable-reference>))
  (let* ((variable (hfield-ref repr 'variable))
	 (r-address (hfield-ref variable 'address)))
    (check-address r-address)
    (let ((c-address (theme-compile-address r-address))
	  (forward-decl?
	   (and (hrecord-is-instance? variable <normal-variable>)
		(is-forward-decl? variable))))
      (let ((result
	     (if (not forward-decl?)
		 `(var-ref ,c-address)
		 `(var-forward-ref ,c-address))))
	result))))


(define (cr-prim-proc-ref compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <prim-proc-ref>))
  (let* ((address (hfield-ref repr 'address))
	 (c-address (theme-compile-address address))
	 (c-type (theme-compile-repr compiler env (get-entity-type repr)))
	 (need-revision? (hfield-ref repr 'need-revision?)))
    `(prim-proc-ref ,need-revision? ,c-address ,c-type)))


(define (cr-checked-prim-proc compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <checked-prim-proc>))
  (let* ((address (hfield-ref repr 'address))
	 (c-address (theme-compile-address address))
	 (c-type (theme-compile-repr compiler env (get-entity-type repr)))
	 (need-revision? (hfield-ref repr 'need-revision?)))
    `(checked-prim-proc ,need-revision? ,c-address ,c-type)))


(define (cr-prim-class-def compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <prim-class-def>))
  (let ((comp (lambda (pred)
		(if (not-null? pred)
		    (theme-compile-repr compiler env pred)
		    '()))))
    (let* ((name (hfield-ref repr 'name))
	   (target-name (hfield-ref repr 'target-name))
	   (t-address (theme-compile-address
		       (hfield-ref (hfield-ref repr 'variable) 'address)))
	   (goops? (hfield-ref repr 'goops?))
	   (t-superclass (theme-compile-repr compiler env
					     (hfield-ref repr 'superclass)))
	   (inh? (hfield-ref repr 'inh?))
	   (imm? (hfield-ref repr 'imm?))
	   (ebv? (hfield-ref repr 'ebv?))
	   (checked? (hfield-ref repr 'checked?))
	   (member-target-name (hfield-ref repr 'member-target-name))
	   (equal-target-name (hfield-ref repr 'equal-target-name))
	   (equal-objects-target-name
	    (hfield-ref repr 'equal-objects-target-name))
	   (equal-contents-target-name
	    (hfield-ref repr 'equal-contents-target-name))
	   (t-zero-address
	    (let ((zero-address (hfield-ref repr 'zero-address)))
	      (if (not-null? zero-address)
		  (theme-compile-address zero-address)
		  '()))))
      (assert (string? name))
      (list 'prim-class-def
	    t-address
	    name
	    target-name
	    goops?
	    t-superclass
	    inh?
	    imm?
	    ebv?
	    checked?
	    member-target-name
	    equal-target-name
	    equal-objects-target-name
	    equal-contents-target-name
	    t-zero-address))))


(define (cr-proc-appl compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <proc-appl>))
  ;; The value of the form is left empty.
  (let* ((comp (lambda (repr2)
		 (theme-compile-repr compiler env repr2)))
	 (p-type (comp (get-entity-type repr)))
	 (p-proc (comp (hfield-ref repr 'proc)))
	 (p-arglist (map* comp (hfield-ref repr 'arglist)))
	 (p-params (map* comp (hfield-ref repr 'params)))
	 (p-static-arg-types (map* comp (hfield-ref repr 'static-arg-types)))
	 (p-default-params (map* comp (hfield-ref repr 'l-default-params)))
	 (result
	  `(proc-appl
	    ,(hfield-ref repr 'need-revision?)
	    ,(hfield-ref repr 'type-dispatched?)
	    ,(hfield-ref repr 'always-returns?)
	    ,(hfield-ref repr 'never-returns?)
	    ,p-type
	    ,(hfield-ref repr 'exact-type?)
	    ,(hfield-ref repr 'pure?)
	    ()
	    ,p-proc
	    ,p-arglist
	    ,p-params
	    ,p-static-arg-types
	    ,(hfield-ref repr 'runtime-arglist-typecheck?)
	    ,p-default-params)))
    result))


;; Proseduurilausekkeen puhtaus (pure?) tarkoittaa,
;; ettei lausekkeella itsellään ole sivuvaikutuksia.
;; Kenttä pure-proc? tietueissa <procedure-expression>
;; ja <procedure-type-expression> ilmaisee onko proseduurin
;; kutsumisella sivuvaikutuksia.

(define (cr-proc-expr compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <procedure-expression>))
  (let* ((proc-type (theme-compile-repr compiler
					env (get-entity-type repr)))
	 (pure? (hfield-ref repr 'pure?))
	 (arg-names (hfield-ref repr 'arg-names))
	 (comp (lambda (repr) (theme-compile-repr compiler env repr)))
	 (p-arg-descs (map comp (hfield-ref repr 'arg-descs)))
	 (p-arg-variables (map (lambda (expr)
				 (theme-compile-variable compiler env expr))
			       (hfield-ref repr 'arg-variables)))
	 (p-result-type (comp (hfield-ref repr 'result-type)))
	 (pure-proc? (hfield-ref repr 'pure-proc?))
	 (force-pure-proc? (hfield-ref repr 'force-pure-proc?))
	 (body (hfield-ref repr 'body))
	 (s-kind (hfield-ref repr 's-kind))
	 (s-name (hfield-ref repr 's-name))
	 (need-revision? (hfield-ref repr 'need-revision?))
	 (appl-always-returns? (hfield-ref repr 'appl-always-returns?))
	 (appl-never-returns? (hfield-ref repr 'appl-never-returns?))
	 (static-method? (hfield-ref repr 'static-method?)))
    (let ((result
	   `(procedure ,need-revision?
		       ,proc-type
		       ,pure?
		       ,arg-names
		       ,p-arg-descs
		       ,p-arg-variables
		       ,p-result-type
		       ,(comp body)
		       ,s-kind
		       ,s-name
		       ,pure-proc?
		       ,force-pure-proc?
		       ,appl-always-returns?
		       ,appl-never-returns?
		       ,static-method?)))
      result)))


(define (cr-param-proc-expr compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <param-proc-expr>))
  (let* ((s-kind (hfield-ref repr 's-kind))
	 (s-name (hfield-ref repr 's-name))
	 (r-ppc (get-entity-type repr))
	 (r-body (hfield-ref repr 'body))
	 (r-type-vars (hfield-ref repr 'type-variables))
	 (p-ppc (theme-compile-repr compiler env r-ppc))
	 (p-body (theme-compile-repr compiler env r-body))
	 (p-type-vars (compile-type-variables r-type-vars)))
    (list 'param-proc s-kind s-name p-type-vars p-ppc p-body)))


;; MIETI: laitetaanko geneerisestä proseduurista vain osoite


(define (cr-method-def compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <method-definition>))
  (let ((gen-proc (hfield-ref repr 'gen-proc))
	(procexpr (hfield-ref repr 'procexpr)))
    ;; The compiler allocates always addresses for generic procedures
    ;; and methods.
    (assert (not-null? (hfield-ref gen-proc 'address)))
    (assert (not-null? (hfield-ref procexpr 'address)))
    (let* ((t-gen-proc (theme-compile-address (hfield-ref gen-proc 'address)))
	   (m-address (hfield-ref procexpr 'address))
	   (type (get-entity-type procexpr))
	   (t-type (theme-compile-repr compiler env type))
	   (t-procexpr (theme-compile-repr compiler env procexpr))
	   (static? (hfield-ref repr 'static-method?))
	   (declared? (hfield-ref repr 'declared?)))
      `(method ,t-gen-proc ,t-type ,t-procexpr ,static? ,declared?))))


(define (cr-method-declaration compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <method-declaration>))
  (let ((gen-proc (hfield-ref repr 'gen-proc))
	(method (hfield-ref repr 'method)))
    (assert (not-null? (hfield-ref gen-proc 'address)))
    (assert (not-null? (hfield-ref method 'address)))
    (let ((method-type (get-entity-type method))
	  (method-addr (hfield-ref method 'address)))
    (strong-assert (is-target-object? method-type))
    (strong-assert (is-address? method-addr))
    (let* ((t-gen-proc (theme-compile-address (hfield-ref gen-proc 'address)))
	   (t-address (theme-compile-address method-addr))
	   (t-type (theme-compile-repr compiler env method-type))
	   (static? (hfield-ref repr 'static-method?)))
      `(declare-method ,t-gen-proc ,t-address ,t-type ,static?)))))


(define (compile-let-var compiler env varspec)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (if (or (not (list? varspec)) (not (= (length varspec) 6)))
      (begin
	(dvar1-set! varspec)
	(raise 'invalid-let-variable-in-phase2))
      (let ((name (list-ref varspec 0))
	    (variable (list-ref varspec 1))
	    (type-decl (list-ref varspec 3))
	    (init-expr (list-ref varspec 4))
	    (bind-object (list-ref varspec 5)))
	(let* ((s-name (get-contents name))
	       (p-address (theme-compile-address
			   (hfield-ref variable 'address)))
	       (t-type-decl
		(if (not-null? type-decl)
		    (theme-compile-repr compiler env type-decl)
		    '()))
	       (t-bind-object? (is-t-true? bind-object))
	       (t-init-expr (theme-compile-repr compiler env init-expr))
	       (t-variable
		(theme-compile-variable compiler env variable)))
	  `(let-var ,s-name ,p-address ,t-variable ,t-type-decl ,t-init-expr
		    ,t-bind-object?)))))


(define (compile-let-vars compiler env lst-variables)
  (map (lambda (varspec) (compile-let-var compiler env varspec))
       lst-variables))


(define (cr-let compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <let-expression>))
  ;; The following code is there to test body compilation error handling.
  (if gl-test2 (raise 'test-error-2))
  (let ((variables (hfield-ref repr 'variables)))
    (if (not (list? variables))
	(begin
	  (if (hrecord? variables)
	      (dwl4 (hrecord-type-get-name (hrecord-type-of variables))))
	  (raise 'invalid-variable-specification-list))
	(let* ((readonly-bindings? (hfield-ref repr 'readonly-bindings?))
	       (recursive? (hfield-ref repr 'recursive?))
	       (order? (hfield-ref repr 'order?))
	       (vars (compile-let-vars compiler env variables))
	       (body (hfield-ref repr 'body))
	       (comp (lambda (repr1) (theme-compile-repr compiler env repr1)))
	       (type (get-entity-type repr))
	       (exact-type? (hfield-ref repr 'exact-type?))
	       (pure? (hfield-ref repr 'pure?))
	       (need-revision? (hfield-ref repr 'need-revision?))
	       (type-dispatched? (hfield-ref repr 'type-dispatched?))
	       (always-returns? (hfield-ref repr 'always-returns?))
	       (never-returns? (hfield-ref repr 'never-returns?)))
	  (let* ((p-type (comp type))
		 (p-body (comp body)))
	    `(let ,need-revision? ,type-dispatched?
		  ,always-returns? ,never-returns?
		  ,p-type
		  ,exact-type? ,pure?
		  ,readonly-bindings? ,recursive? ,order?
		  ,vars ,p-body))))))


(define (cr-cast compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <cast-expression>))
  (let ((type (get-entity-type repr))
	(pure? (hfield-ref repr 'pure?))
	(value-expr (hfield-ref repr 'value-expr))
	(default-expr (hfield-ref repr 'default-expr))
	(need-revision? (hfield-ref repr 'need-revision?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?)))
    (let* ((sx-type (theme-compile-repr compiler env type))
	   (sx-value-expr (theme-compile-repr compiler env value-expr))
	   (sx-default-expr (theme-compile-repr compiler env default-expr)))
    `(cast
      ,need-revision?
      ,always-returns?
      ,never-returns?
      ,sx-type
      ,pure?
      ,sx-value-expr
      ,sx-default-expr))))


(define (cr-static-cast compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <static-cast-expression>))
  (let ((type (get-entity-type repr))
	(pure? (hfield-ref repr 'pure?))
	(ent-value (hfield-ref repr 'ent-value))
	(need-revision? (hfield-ref repr 'need-revision?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?)))
    (let* ((sx-type (theme-compile-repr compiler env type))
	   (sx-value (theme-compile-repr compiler env ent-value)))
      `(static-cast
	,need-revision?
	,always-returns?
	,never-returns?
	,sx-type
	,pure?
	,sx-value))))


(define (cr-match-type compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <match-type-expression>))
  (let* ((strong? (hfield-ref repr 'strong?))
	 (expr-to-match (hfield-ref repr 'expr-to-match))
	 (lst-proper-clauses (hfield-ref repr 'lst-proper-clauses))
	 (expr-else (hfield-ref repr 'expr-else))
	 (expr-type (get-entity-type repr))
	 (exact-type? (hfield-ref repr 'exact-type?))
	 (pure? (hfield-ref repr 'pure?))
	 (need-revision? (hfield-ref repr 'need-revision?))
	 (type-dispatched? (hfield-ref repr 'type-dispatched?))
	 (always-returns? (hfield-ref repr 'always-returns?))
	 (never-returns? (hfield-ref repr 'never-returns?))
	 (optimized? (hfield-ref repr 'optimized?))
	 (comp (lambda (repr1) (theme-compile-repr compiler env repr1))))
    (let* ((p-expr-to-match (comp expr-to-match))
	   (p-clauses (map (lambda (lst-clause)
			     (list
			      (if (not-null? (car lst-clause))
				  (theme-compile-variable compiler env
							  (car lst-clause))
				  '())
			      (comp (cadr lst-clause))
			      (comp (caddr lst-clause))
			      (list-ref lst-clause 3)))
			   lst-proper-clauses))
	   (p-else-part
	    (comp expr-else))
	   (p-type (comp expr-type)))
      `(match-type ,need-revision? ,type-dispatched? ,strong?
		   ,always-returns? ,never-returns? ,p-type ,exact-type? ,pure?
		   ,p-expr-to-match ,p-clauses ,p-else-part ,optimized?))))


(define (cr-if compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (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))	
	(boolean-cond? (hfield-ref repr 'boolean-cond?))
	(type (get-entity-type repr))
	(exact-type? (hfield-ref repr 'exact-type?))
	(pure? (hfield-ref repr 'pure?))
	(need-revision? (hfield-ref repr 'need-revision?))
	(type-dispatched? (hfield-ref repr 'type-dispatched?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?))
	(comp (lambda (repr1) (theme-compile-repr compiler env repr1))))
    (let* ((type2 (if
		   (and (not-null? type)
			(not (is-t-type-variable? type)))
		   (comp type)
		   (comp tc-object)))
	   (sx-cond (comp condition))
	   (sx-then (comp then-expr))
	   (sx-else (comp else-expr))
	   (result
	    `(if ,need-revision? ,type-dispatched?
		 ,always-returns? ,never-returns?
		 ,type2 ,exact-type? ,pure?
		 ,sx-cond ,sx-then ,sx-else
		 ,boolean-cond?)))
      result)))


(define (cr-compound compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <compound-expression>))
  (let* ((subexprs (hfield-ref repr 'subexprs))
	 (type (get-entity-type repr))
	 (comp (lambda (repr1) (theme-compile-repr compiler env repr1)))
	 (t-subexprs (map* comp subexprs))
	 (need-revision? (hfield-ref repr 'need-revision?))
	 (type-dispatched? (hfield-ref repr 'type-dispatched?))
	 (always-returns? (hfield-ref repr 'always-returns?))
	 (never-returns? (hfield-ref repr 'never-returns?)))
    `(begin
       ,need-revision?
       ,type-dispatched?
       ,always-returns?
       ,never-returns?
       ,(comp type)
       ,(hfield-ref repr 'exact-type?)
       ,(hfield-ref repr 'pure?)
       ,t-subexprs)))


(define (cr-until compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <until-form>))
  (let ((condition (hfield-ref repr 'condition))
	(result (hfield-ref repr 'result))
	(body (hfield-ref repr 'body))
	(type (get-entity-type repr))
	(need-revision? (hfield-ref repr 'need-revision?))
	(type-dispatched? (hfield-ref repr 'type-dispatched?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?))
	(comp (lambda (repr1) (theme-compile-repr compiler env repr1))))
    (let* ((c-condition (comp condition))
	   (c-result (comp result))
	   (c-body (comp body))
	   (c-type (comp type)))
      `(until
	,need-revision?
	,type-dispatched?
	,always-returns?
	,never-returns?
	,c-type
	,(hfield-ref repr 'exact-type?)
	,(hfield-ref repr 'pure?)
	,c-condition
	,c-result
	,c-body))))


(define (cr-forward-declaration compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <forward-declaration>))
  (let* ((variable (hfield-ref repr 'variable))
	 (read-only? (hfield-ref variable 'read-only?))
	 (volatile? (hfield-ref variable 'volatile?))
	 (s-keyword
	  (cond
	   ((and read-only? (not volatile?)) 'declare)
	   ((and read-only? volatile?) (raise 'internal-error))
	   (volatile? 'declare-volatile)
	   (else 'declare-mutable)))
	 (p-location (theme-compile-declared-variable
		      compiler env variable))
	 (r-declared-type (hfield-ref repr 'declared-type))
	 (p-declared-type (theme-compile-repr compiler env r-declared-type)))
    `(,s-keyword ,p-location ,p-declared-type)))


(define (cr-field-ref compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <field-ref-expr>))
  (let ((const-field-name? (hfield-ref repr 'const-field-name?))
	(r-object (hfield-ref repr 'object))
	(r-field-name (hfield-ref repr 'field-name))
	(need-revision? (hfield-ref repr 'need-revision?))
	(type-dispatched? (hfield-ref repr 'type-dispatched?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?)))
    (let* ((p-object (theme-compile-repr compiler env r-object))
	   (p-field-name (if const-field-name?
			     r-field-name
			     (theme-compile-repr compiler env r-field-name))))
      (list 'field-ref need-revision? type-dispatched?
	    always-returns? never-returns? const-field-name?
	    p-object p-field-name))))


(define (cr-field-set compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <field-set-expr>))
  (let ((const-field-name? (hfield-ref repr 'const-field-name?))
	(r-object (hfield-ref repr 'object))
	(r-field-name (hfield-ref repr 'field-name))
	(r-field-value (hfield-ref repr 'field-value))
	(need-revision? (hfield-ref repr 'need-revision?))
	(always-returns? (hfield-ref repr 'always-returns?))
	(never-returns? (hfield-ref repr 'never-returns?)))
    (let* ((p-object (theme-compile-repr compiler env r-object))
	   (p-field-name (if const-field-name?
			     r-field-name
			     (theme-compile-repr compiler env r-field-name)))
	   (p-field-value (theme-compile-repr compiler env r-field-value)))
      (list 'field-set! need-revision? always-returns? never-returns?
	    const-field-name?
	    p-object p-field-name p-field-value))))


(define (cr-constructor compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <expr-constructor>))
  (let ((clas (hfield-ref repr 'clas)))
    (assert (is-target-object? clas))
    `(constructor ,(theme-compile-repr compiler env clas))))


(define (cr-param-proc-instance compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <expr-param-proc-instance>))
  (let* ((p-param-proc (theme-compile-repr compiler env
					   (hfield-ref repr 'param-proc)))
	 (p-param-values
	  (map* (lambda (val) (theme-compile-repr compiler env val))
		(hfield-ref repr 'params)))
	 (need-revision? (hfield-ref repr 'need-revision?)))
    (list 'param-proc-instance need-revision? p-param-proc p-param-values)))


(define (cr-param-proc-dispatch compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <expr-param-proc-dispatch>))
  (let* ((p-param-proc (theme-compile-repr compiler env
					   (hfield-ref repr 'param-proc)))
	 (p-argument-types
	  (map* (lambda (val) (theme-compile-repr compiler env val))
		(hfield-ref repr 'argument-types)))
	 (need-revision? (hfield-ref repr 'need-revision?)))
    (list 'param-proc-dispatch need-revision? p-param-proc p-argument-types)))


(define (cr-generic-proc-dispatch compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <generic-proc-dispatch>))
  (let* ((comp (lambda (ent) (theme-compile-repr compiler env ent)))
	 (sx-type (comp (get-entity-type repr)))
	 (sx-gen-proc (comp (hfield-ref repr 'generic-proc)))
	 (l-sx-arg-types (map* comp (hfield-ref repr 'arg-types))))
  `(generic-proc-dispatch
    ,(hfield-ref repr 'need-revision?)
    ,sx-type
    ,(hfield-ref repr 'exact-type?)
    ,(hfield-ref repr 'pure?)
    ,(hfield-ref repr 'with-result?)
    ,(hfield-ref repr 'appl-pure?)
    ,(hfield-ref repr 'appl-always-returns?)
    ,(hfield-ref repr 'appl-never-returns?)
    ,sx-gen-proc
    ,l-sx-arg-types)))


(define (cr-zero-setting compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <zero-setting-expr>))
  (let* ((address-cl (hfield-ref (hfield-ref repr 'var-class)
				 'address))
	 (zero-proc (hfield-ref repr 'zero-proc))
	 (t-address-cl (theme-compile-address address-cl))
	 (t-zero-proc (theme-compile-repr compiler env zero-proc))
	 (param? (hfield-ref repr 'param?)))
    (list 'set-zero t-address-cl t-zero-proc param?)))


(define (cr-zero compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <zero-expr>))
  (let* ((r-clas (hfield-ref repr 'clas))
	 (t-clas (theme-compile-repr compiler env r-clas)))
    (list 'zero t-clas)))


(define (cr-force-pure-expr compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <force-pure-expr>))
  (list 'force-pure-expr
	(theme-compile-repr compiler env
			    (hfield-ref repr 'repr-component))))


(define (cr-prevent-stripping compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <prevent-stripping-expr>))
  (let ((t-address (theme-compile-address (hfield-ref repr 'target-address))))
    (list 'prevent-stripping t-address)))


(define (cr-assertion compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <assertion-expr>))
  (let* ((r-condition (hfield-ref repr 'condition))
	 (t-condition (theme-compile-repr compiler env r-condition))
	 (s-condition (hfield-ref repr 'condition-source-expr))
	 (strong? (hfield-ref repr 'strong?)))
    (list 'assert strong? t-condition s-condition)))


(define (cr-define-syntax compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (hrecord-is-instance? repr <expr-define-syntax>))
  ;; Macro definitions need only be compiled to interface files.
  (if (eq? (hfield-ref compiler 'unit-type) 'interface)
      (let ((t-address (theme-compile-address
			(hfield-ref repr 'address-syntax)))
	    (x-handler (hfield-ref repr 'x-handler)))
	(list 'define-syntax t-address x-handler))
      '(empty)))


(define (cr-do-nothing compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  #f)


(define (cr-empty-expression compiler env repr)
  '(empty))


(define (cr-error compiler env repr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  ;; TBD: Move the following output into the error module.
  (write-error-info "Unknown expression type")
  (raise 'unknown-expr-type))


(define cr-proc-table
  (list
   (cons <method-definition> cr-method-def)
   (cons <method-declaration> cr-method-declaration)
   (cons <class-definition> cr-general-variable-def)
   (cons <generic-procedure-definition> cr-gen-proc-def)
   (cons <prim-class-def> cr-prim-class-def)
   (cons <variable-definition> cr-general-variable-def)
   (cons <set-expression> cr-set-expr)
   (cons <variable-reference> cr-var-ref)
   (cons <prim-proc-ref> cr-prim-proc-ref)
   (cons <checked-prim-proc> cr-checked-prim-proc)
   (cons <proc-appl> cr-proc-appl)
   (cons <procedure-expression> cr-proc-expr)
   (cons <param-proc-expr> cr-param-proc-expr)
   (cons <let-expression> cr-let)
   (cons <cast-expression> cr-cast)
   (cons <static-cast-expression> cr-static-cast)
   (cons <match-type-expression> cr-match-type)
   (cons <if-form> cr-if)
   (cons <compound-expression> cr-compound)
   (cons <until-form> cr-until)
   (cons <forward-declaration> cr-forward-declaration)
   (cons <field-ref-expr> cr-field-ref)
   (cons <field-set-expr> cr-field-set)
   (cons <param-class-definition> cr-general-variable-def)
   (cons <param-logical-type-def> cr-general-variable-def)
   (cons <expr-constructor> cr-constructor)
   (cons <expr-param-proc-instance> cr-param-proc-instance)
   (cons <expr-param-proc-dispatch> cr-param-proc-dispatch)
   (cons <generic-proc-dispatch> cr-generic-proc-dispatch)
   (cons <signature-definition> cr-general-variable-def)
   (cons <param-signature-definition> cr-general-variable-def)
   (cons <zero-setting-expr> cr-zero-setting)
   (cons <zero-expr> cr-zero)
   (cons <force-pure-expr> cr-force-pure-expr)
   (cons <prevent-stripping-expr> cr-prevent-stripping)
   (cons <expr-define-syntax> cr-define-syntax)
   (cons <assertion-expr> cr-assertion)
   (cons <empty-expression> cr-empty-expression)
   (cons <variable> cr-error)
   (cons <target-object> cr-error)))


(define (co-abstract-param-type-inst compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
  (let* ((r-param-type (tno-field-ref to 'type-meta))
	 (p-param-type (theme-compile-object-fwd compiler env r-param-type
						 lst-visited))
	 (r-args (tno-field-ref to 'l-type-args))
	 (p-args (map* (lambda (repr) (theme-compile-object-fwd
				       compiler env repr lst-visited))
		       r-args)))
    (list 'apti p-param-type p-args)))


(define (co-object-with-address compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
   (let ((address (hfield-ref to 'address)))
    (assert (not-null? address))
    (list 'object-ref (theme-compile-address address))))

 
(define (co-type-variable compiler env to)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-type-variable? to))
   (let ((address (hfield-ref to 'address)))
    (assert (not-null? address))
    (list 'tvar (theme-compile-address address))))


(define (co-incomplete-object compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
  (raise 'trying-to-compile-incomplete-object))


(define (co-pair-class compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (and (is-target-object? to) (is-tc-pair? to)))
  (let* ((tvv (tno-field-ref to 'l-tvar-values))
	 (tt-first (theme-compile-object-fwd compiler env (car tvv)
					     lst-visited))
	 (tt-second (theme-compile-object-fwd compiler env (cadr tvv)
					      lst-visited)))
    (list ':pair tt-first tt-second)))


(define (co-union compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (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)
		  (theme-compile-object-fwd compiler env to-member lst-visited))
		r-member-types)))
    (list ':union p-member-types)))


(define (co-uniform-list compiler env to lst-visited)
;;  (assert (hrecord-is-instance? compiler <compiler>))
;;  (assert (hrecord-is-instance? env <environment>))
;;  (assert (and (is-target-object? to) (is-t-uniform-list? to)))
  (raise 'invalid-uniform-list))


(define (co-param-proc-class compiler env ppc lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-param-proc? ppc))
  (let* ((r-type-vars (tno-field-ref ppc 'l-tvars))
	 (r-inst-type (tno-field-ref ppc 'type-contents))
	 (p-type-vars (compile-type-variables r-type-vars))
	 (p-inst-type (theme-compile-object-fwd compiler env r-inst-type
						lst-visited)))
    (list 'param-proc-class p-type-vars p-inst-type)))


(define (co-param-class-instance compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-param-class-instance? to))
  (let* ((param-class (get-entity-type to))
	 (args (tno-field-ref to 'l-tvar-values))
	 (p-param-class (theme-compile-object-fwd compiler env param-class
						  lst-visited))
	 (p-args (map* (lambda (param)
			 (theme-compile-object-fwd compiler env param
						   lst-visited))
		       args)))
      (append (list 'param-class-instance p-param-class)
	      (list p-args))))


(define (co-signature compiler env sgn lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-signature? sgn))
  (let* ((r-members (tno-field-ref sgn 'l-members))
	 (p-members
	  (map* (lambda (r-member)
		  (let* ((sx1
			  (theme-compile-repr compiler env (car r-member)))
			 (sx2
			  (theme-compile-repr compiler env (cdr r-member))))
		    (list sx1 sx2)))
		r-members)))
    (list 'signature p-members)))


(define (co-param-signature compiler env psgn lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-param-signature? psgn))
  (let* ((r-type-vars (tno-field-ref psgn 'l-tvars))
	 (r-members (tno-field-ref psgn 'l-members))
	 (p-type-vars (compile-type-variables r-type-vars))
	 (p-members
	  (map* (lambda (r-member)
		  (let* ((sx1
			  (theme-compile-repr compiler env (car r-member)))
			 (sx2
			  (theme-compile-repr compiler env (cdr r-member))))
		    (list sx1 sx2)))
		r-members)))
    (list 'param-signature p-type-vars p-members)))


(define (co-param-sgn-instance compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-param-sgn-instance? to))
  (let* ((param-sgn (get-entity-type to))
	 (args (tno-field-ref to 'l-tvar-values))
	 (p-param-sgn (theme-compile-object-fwd compiler env param-sgn
						lst-visited))
	 (p-args (map (lambda (param)
			(theme-compile-object-fwd compiler env param
						  lst-visited))
		      args)))
      (append (list 'param-sgn-instance p-param-sgn)
	      (list p-args))))


;; This procedure is probably erroneous. Procedure co-param-class-instance
;; is used instead.
(define (co-vector-class compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-vector? to))
  (let* ((mt (hfield-ref to 'member-type))
	 (mtc (theme-compile-object-fwd compiler env mt lst-visited))
	 (result
	  `(vector-class ,mtc)))
    result))


;; This procedure is probably erroneous. Procedure co-param-class-instance
;; is used instead.
(define (co-mutable-vector-class compiler env repr lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-mutable-vector? repr))
  (let* ((mt (hfield-ref repr 'member-type))
	 (mtc (theme-compile-object-fwd compiler env mt lst-visited))
	 (result
	  `(mutable-vector-class ,mtc)))
    result))


;; This procedure is probably erroneous. Procedure co-param-class-instance
;; is used instead.
(define (co-value-vector-class compiler env repr lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-value-vector? repr))
  (let* ((mt (hfield-ref repr 'member-type))
	 (mtc (theme-compile-object-fwd compiler env mt lst-visited))
	 (result
	  `(value-vector-class ,mtc)))
    result))


;; This procedure is probably erroneous. Procedure co-param-class-instance
;; is used instead.
(define (co-mutable-value-vector-class compiler env repr lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-mutable-value-vector? repr))
  (let* ((mt (hfield-ref repr 'member-type))
	 (mtc (theme-compile-object-fwd compiler env mt lst-visited))
	 (result
	  `(mutable-value-vector-class ,mtc)))
    result))


;; Mahdollisesti sisäkkäiset <type-list-expression>:it pitäisi
;; myös kääntää.
(define (co-general-proc-type compiler env to lst-visited simple?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (or
	   (is-tt-procedure? to)
	   (is-tc-simple-proc? to)))
  (assert (boolean? simple?))
  (let* ((compile (lambda (expr) (theme-compile-object-fwd compiler env expr
							   lst-visited)))
	 (keyword
	  (if simple? 'simple-proc-class 'proc-type))
	 (sx-arglist (compile (tno-field-ref to 'type-arglist)))
	 (sx-result (compile (tno-field-ref to 'type-result)))
	 (result
	  (list keyword
		sx-arglist
		sx-result
		(tno-field-ref to 'pure-proc?)
		(tno-field-ref to 'appl-always-returns?)
		(tno-field-ref to 'appl-never-returns?)
		(tno-field-ref to 'static-method?))))
    result))


(define (co-gen-proc-class compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-gen-proc? to))
  (let* ((r-method-classes (tno-field-ref to 'l-method-classes))
	 (t-method-classes
	  (map*
	   (lambda (mtc)
	     (theme-compile-object-fwd compiler env mtc lst-visited))
	   r-method-classes)))
    (cons 'gen-proc-class t-method-classes)))


(define (co-rest compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-rest? to))
  (let ((component-type
	 (theme-compile-object-fwd compiler env
				   (tno-field-ref to 'type-component)
				   lst-visited)))
    (list 'rest component-type)))


(define (co-splice compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-splice? to))
  (let ((component-type
	 (theme-compile-object-fwd compiler env
				   (tno-field-ref to 'type-component)
				   lst-visited)))
    (list 'splice component-type)))


(define (co-type-list compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-type-list? to))
  (let ((compiled-subexprs
	 ;; Not sure if the evaluation order has any significance here.
	 (map*
	  (lambda (expr)
	    (theme-compile-object-fwd compiler env expr lst-visited))
	  (tno-field-ref to 'l-subtypes))))
    (list 'type-list compiled-subexprs)))


(define (co-type-loop compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-type-loop? to))
  ;; Note that we do not pass the type loop local environment
  ;; (currently not stored anywhere) to theme-compile-object-fwd here.
  (let* ((r-iter-var-address
	  (hfield-ref (tno-field-ref to 'tvar) 'address))
	 (p-iter-var-address
	  (theme-compile-address r-iter-var-address))
	 (p-subtype-list
	  (theme-compile-object-fwd compiler env
				    (tno-field-ref to 'x-subtypes)
				    lst-visited))
	 (p-iter-expr
	  (theme-compile-object-fwd compiler env
				    (tno-field-ref to 'x-iter-expr)
				    lst-visited)))
    (list 'type-loop p-iter-var-address p-subtype-list p-iter-expr)))


(define (co-type-join compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-t-type-join? to))
  (let ((compiled-subtypes
	 ;; Not sure if the evaluation order has any significance here.
	 (map*
	  (lambda (expr)
	    (theme-compile-object-fwd compiler env expr lst-visited))
	  (tno-field-ref to 'l-subtypes))))
    (list 'type-join compiled-subtypes)))


(define (co-pair compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-tc-pair? (get-entity-type to)))
  (let* ((p-first
	  (theme-compile-object-fwd compiler env (tno-field-ref to 'first)
				    lst-visited))
	 (p-second
	  (theme-compile-object-fwd compiler env (tno-field-ref to 'second)
				    lst-visited)))
    (list 'pair p-first p-second)))


(define (compile-cycle compiler env to lst-visited)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
  (let* ((address (compiler-alloc-loc compiler 'cycle-2 #f))
	 (p-address (theme-compile-address address))
	 (p-type (theme-compile-object-fwd compiler env (get-entity-type to)
					   lst-visited))
	 (lst-old-encl (hfield-ref compiler 'lst-enclosing-cycles)))
    (hfield-set! compiler 'lst-enclosing-cycles
		 (cons (cons to address)
		       (hfield-ref compiler 'lst-enclosing-cycles)))
    (let ((p-contents (theme-compile-object0-fwd compiler env to lst-visited
						 #t)))
      (hfield-set! compiler 'lst-enclosing-cycles lst-old-encl)
      (list 'cycle p-type p-address p-contents))))
    

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


(set! do-compile-object-fwd do-compile-object)


(define (theme-compile-object0 compiler env to lst-visited compile-always?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (is-target-object? to))
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((lst-new-visited (cons to lst-visited)))

      (let ((result
	     (if compile-always?
		 (begin
		   (do-compile-object compiler env to lst-new-visited #t))
		 ;; TBD: Change assv to assq (?).
		 (let* ((a (assv to
				 (hfield-ref compiler 'lst-enclosing-cycles))))
		   (if a
		       (begin
			 (list 'object-ref (theme-compile-address (cdr a))))
		       (if (hashq-ref (hfield-ref compiler 'ht-cycles) to)
			   (compile-cycle compiler env to lst-new-visited)
			   (do-compile-object compiler env to
					      lst-visited #f)))))))
	    (set! gl-indent old-indent)
	    result))))


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


(define (theme-compile-object compiler env to lst-visited)
  (theme-compile-object0 compiler env to lst-visited #f))


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


(define (theme-compile-repr compiler env repr)
  (assert (hrecord-is-instance? env <environment>))
  (let ((old-indent gl-indent)
	(prim? (is-t-primitive-object? repr)))
    (set! gl-indent (+ gl-indent 1))
    (assert
     (or
      prim?
      (hrecord-is-instance? repr <entity>)))
    (let ((prev-repr (hfield-ref compiler 'current-repr)))
      (if (is-entity? repr)
	  (hfield-set! compiler 'current-repr repr))
      (let ((result
	     (cond
	      (prim? (compile-scheme-primitive-value compiler env repr))
	      ((is-expression? repr)
	       (let ((proc (hrecord-type-inquire cr-proc-table 
						 (hrecord-type-of repr))))
		 (if proc
		     (proc compiler env repr)
		     (begin
		       (write-error-info (hrecord-type-get-name (hrecord-type-of repr)))
		       (dvar1-set! repr)
		       (raise 'compilation-not-implemented)))))
	      ((is-target-object? repr)
	       (theme-compile-object compiler env repr '()))
	      (else (raise 'illegal-element-to-compile)))))
	(if (is-entity? repr)
	    (hfield-set! compiler 'current-repr prev-repr))
	(set! gl-indent old-indent)
	result))))


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


(define (do-compile-unit compiler env expr-list module-output-file
			 file-name)
  (dwli "Number of toplevel expressions: ")
  (dwli (length expr-list))
  (assert (hrecord-is-instance? env <environment>))
  (for-each (lambda (repr)
	      (hfield-set! compiler 'current-toplevel-repr repr)
	      ;; Not sure if we should reset ht-cycles for each expression.
	      ;; (let* ((binder (compiler-get-binder compiler))
	      ;; 	     (repr1 (handle-cycles binder repr))
	      ;; 	     (p-repr (theme-compile-repr compiler env repr1)))
	      (let ((binder (compiler-get-binder compiler))
		    (ht-cycles (hfield-ref compiler 'ht-cycles)))
		(hash-clear! ht-cycles)
		(hfield-set! compiler 'lst-enclosing-cycles '())
		(hfield-set! compiler 'lst-visited '())
		;; (display-time)
		(detect-cycles binder repr ht-cycles '())
		;; (display-time)
		(let ((p-repr (theme-compile-repr compiler env repr)))
		  (guard
		   (exc (else
			 (raise (make-file-exception
				 'error-writing-file file-name))))
		   (if (hfield-ref compiler 'pretty-print-modules?)
		       (pretty-print p-repr module-output-file)
		       (write p-repr module-output-file))
		   (newline module-output-file)))
		(hfield-set! compiler 'current-toplevel-repr '())))
	    expr-list))

