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



;; *** Translation 1 ***


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


(define xlat-table '())


(define xlat-default-fwd '())


(define (translate-location compiler symtbl expr)
  (let ((location (get-symbol symtbl expr)))
    (if location
	(begin
	  (cond
	   ((hrecord-is-instance? location <keyword>)
	    location)
	   ((hrecord-is-instance? location <normal-variable>)
	    (begin
	      (if (not (check-normal-variable? location))
		  (begin
		    (dvar1-set! location)
		    (raise 'internal-invalid-variable))
		  (if (hfield-ref location 'letrec-variable?)
		      (if (access-letrec-variable?
			   (hfield-ref compiler 'current-letrec-env)
			   location
			   #f)
			  (make-var-ref-to-var location)
			  (raise (list 'unaccessible-letrec-variable
				       (cons 's-name expr))))
		      (make-var-ref-to-var location)))))
	   ((is-target-object? location)
	    location)
	   ((is-t-type-variable? location)
	    location)
	   (else
	    (begin
	      (raise 'internal-invalid-binding)))))
        (begin
	  (set-error-info! compiler expr)
	  (raise 'unbound-variable)))))


(define (translate-atom compiler symtbl toplevel? quoted? sexpr)
  (if (and (not quoted?) (symbol? sexpr))
      (begin (translate-location compiler symtbl sexpr))
      (let* ((type (get-primitive-type sexpr))
	     ;; Should type be an expression or a variable in the following?
	     (to (make-primitive-object
		  type
		  sexpr)))
	to)))


(define (check-illegal-keywords l-exprs)
  (for-each (lambda (sexpr)
	      (if (and (symbol? sexpr) (assq sexpr keywords))
		  (raise (list 'illegal-use-of-keyword
			       (cons 's-keyword sexpr)))))
	    l-exprs))

;;; Translation of lists

(define (translate-list-expr compiler symtbl toplevel? expr-head expr-tail)
  (if (not (hrecord? expr-head))
      (raise 'internal-error)
      (let ((proc (hrecord-type-inquire
		   xlat-table (hrecord-type-of expr-head))))
	(if (not (eq? (hrecord-type-of expr-head) <keyword-quote>))
	    (begin
	      (if (not (list? expr-tail))
		  (raise 'expected-list))
	      (check-illegal-keywords expr-tail)))
	(let ((result
	       (if proc
		   (proc compiler symtbl toplevel? expr-head expr-tail)
		   (xlat-default-fwd compiler symtbl toplevel?
				     expr-head expr-tail))))
	  result))))


;; Translation of an arbitrary expression
;; If the expression is a list translate the head
;; and call translate-expr recursively (dispatch used).
(define (translate-expr compiler symtbl toplevel? expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (not (hrecord? expr)))
  (check-env symtbl)
  (let ((result
	 (cond
	  ((pair? expr)
	   (let ((prev-expr (hfield-ref compiler 'current-expr)))
	     (hfield-set! compiler 'current-expr expr)
	     (let ((res2
		    (if (source-code-element? (car expr))
			(translate-list-expr
			 compiler
			 symtbl
			 toplevel?
			 (translate-expr compiler symtbl #f (car expr))
			 (cdr expr))
			(raise 'dispatch-error))))
	       (hfield-set! compiler 'current-expr prev-expr)
	       res2)))
	  ((source-code-element? expr)
	   (translate-atom compiler symtbl #f #f expr))
	  (else
	   (dvar1-set! expr)
	   (raise 'invalid-dispatch)))))
    result))


(set! translate-expr-fwd translate-expr)


(define (wrap-compound-expression compiler env s-subexprs)
  (assert (list? s-subexprs))
  (assert (hrecord-is-instance? env <environment>))
  (do-wrap-compound-expression
   s-subexprs
   (lambda (s-expr)
     (translate-expr compiler env #f s-expr))))


(define (translate-define-mutable-expression
         compiler symtbl toplevel? expr-tail volatile?)
  (if (not (= (length expr-tail) 3))
      (raise 'invalid-define-mutable-expr)
      (let ((s-name (car expr-tail))
            (s-type (cadr expr-tail))
            (s-value (caddr expr-tail)))
        (if (not (s-symbol? s-name))
            (raise 'invalid-variable-name)
	    (begin
	      (hfield-set! compiler 's-cur-toplevel-def s-name)
	      (let ((type
		     (translate-expr compiler symtbl #f s-type))
		    (value-expr 
		     (translate-expr compiler symtbl #f s-value)))
		(if (not (is-legal-value-ref? compiler value-expr))
		    (raise (list 'illegal-incomplete-ref
				 (cons 's-name s-name)
				 (cons 'address '()))))
		(if (is-known-object? type)
		    (let* ((bound-value (get-symbol symtbl s-name))
			   (rebind? (check-existing-binding? compiler
							     bound-value))
			   (type-val (get-entity-type value-expr))
			   (val (get-entity-value value-expr))
			   (old-type (if (eq? bound-value #f)
					 #f
					 (get-entity-type bound-value)))
			   (binder (compiler-get-binder compiler)))
		      (cond
		       ((and rebind? (is-target-object? bound-value))
			(raise 'definition-mutability-mismatch))
		       ((and rebind? (not (is-normal-variable? bound-value)))
			;; If the code works correctly we should never enter here.
			(raise 'internal-error))
		       ((and rebind?
			     (not (eq? volatile?
				       (hfield-ref bound-value 'volatile?))))
			(raise 'volatility-mismatch))
		       ((not (is-t-instance? binder type tt-type))
			(raise 'not-a-type))
		       ((not (is-t-subtype? binder type-val type))
			(raise 'type-spec-violated))
		       ((and (not (eq? old-type #f))
			     (not (equal-types? binder type old-type)))
			(raise (list 'mutable-forward-def-type-mismatch
				     (cons 's-name s-name)
				     (cons 'tt-new type)
				     (cons 'tt-old old-type))))
		       (else
			(let* ((variable
				(if (not (eq? bound-value #f))
				    (begin
				      (assert (hrecord-is-instance?
					       bound-value
					       <normal-variable>))
				      (hfield-set! bound-value 'forward-decl?
						   #f)
				      bound-value)
				    (let ((address
					   (compiler-alloc-loc compiler
							       s-name #t)))
				      (make-normal-variable0
				       address type #t #f #f
				       volatile?
				       #f #f '() '()
				       #f #f))))
			       (result
				(make-normal-var-def
				 type
				 variable
				 value-expr
				 rebind?)))
			  (if (not rebind?)
			      (add-symbol! symtbl s-name variable))
			  (hfield-set! compiler 's-cur-toplevel-def '())
			  result))))
		    (raise 'define-mutable:invalid-type))))))))


(define (translate-define-expression compiler symtbl toplevel? expr-tail)
  (let ((arg-count (length expr-tail)))
    (if (not (or (= arg-count 2) (= arg-count 3)))
	(raise 'invalid-define)
	(let* ((has-type-spec? (= arg-count 3))
	       (s-name (car expr-tail))
	       (s-type (if has-type-spec? (cadr expr-tail) '()))
	       (s-value (if has-type-spec? (caddr expr-tail) (cadr expr-tail)))
	       (binder (compiler-get-binder compiler)))
	  (if (not (s-symbol? s-name))
	      (raise 'invalid-variable-name)
	      (begin
		(hfield-set! compiler 's-cur-toplevel-def s-name)
		(let* ((bound-value (get-symbol symtbl s-name))
		       (rebind? (check-existing-binding? compiler bound-value))
		       (tt-declared0
			(if has-type-spec?
			    (translate-expr compiler symtbl #f s-type)
			    '()))
		       (tmp1 (begin (set-proc-expr compiler s-value
						   'toplevel s-name) 0))
		       (value-expr 
			(translate-expr compiler symtbl #f s-value))
		       (tmp2 (begin (unset-proc-expr compiler s-value) 0))
		       (tt-old (if (eq? bound-value #f)
				   #f
				   (get-entity-type bound-value)))
		       (tt-actual (get-entity-type value-expr))
		       (tt-declared (if has-type-spec?
					tt-declared0
					tt-actual)))
		  (cond
		   ((and rebind?
			 (not (is-target-object? bound-value)))
		    (raise 'declaration-mutability-mismatch))
		   ((and rebind?
			 (null? (hfield-ref bound-value 'address)))
		    (raise 'internal:invalid-declaration))
		   ((or (not (is-known-object? tt-actual))
			(not (is-t-instance? binder tt-actual tt-type)))
		    (raise 'invalid-value-type))
		   ((or (not (is-known-object? tt-declared))
			(not (is-t-instance? binder tt-declared tt-type)))
		    (raise 'invalid-declared-type))
		   ((and (not (eq? tt-old #f))
			 (not (is-t-subtype? binder tt-declared tt-old)))
		    (raise (list 'forward-def-type-mismatch
				 (cons 's-name s-name)
				 (cons 'tt-new tt-declared)
				 (cons 'tt-old tt-old))))
		   ((and has-type-spec?
			 (not (is-t-subtype? binder tt-actual tt-declared)))
		    (raise 'type-spec-violated))
		   (else
		    (let* ((to-value (get-entity-value value-expr))
			   (to2
			    ;; If to-value is null we know only the type
			    ;; and address of the variable and we set
			    ;; al-field-values to #f.
			    (if (and 
				 (not-null? to-value)
				 (not
				  (hrecord-is-instance? value-expr
							<prim-proc-ref>))
				 (not
				  (hrecord-is-instance? value-expr
							<checked-prim-proc>)))
				to-value
				(make-unknown-object
				 tt-declared
				 (is-final-class? binder tt-declared))))
			   (address (if rebind?
					(hfield-ref bound-value 'address) 
					(compiler-alloc-loc compiler s-name #t)))
			   (to-new 
			    (if (null? (hfield-ref to2 'address))
				(make-object-with-address
				 to2 address)
				to2))
			   (variable
			    (make-normal-variable
			     address
			     tt-actual
			     (hfield-ref to2 'exact-type?)
			     #t
			     #f
			     to2
			     #f)))
		      (if (and
			   rebind?
			   (not (is-legal-value-object? compiler to-new)))
			  (raise (list 'illegal-incomplete-value
				       (cons 's-name s-name)
				       (cons 'address address))))
		      (if (not (is-legal-value-ref? compiler value-expr))
			  (raise (list 'illegal-incomplete-ref
				       (cons 's-name s-name)
				       (cons 'address address))))
		      ;; We bind the variable name to an object.
		      (if (not rebind?)
			  (add-symbol! symtbl s-name to-new)
			  (begin
			    (set-object1! bound-value to-new)
			    ;; to-new may be incomplete if the value
			    ;; expression is a declared value.
			    (hfield-set! bound-value 'incomplete? #f)))
		      (hfield-set! compiler 's-cur-toplevel-def '())
		      (make-normal-var-def
		       tt-declared variable value-expr rebind?)))))))))))


(define (translate-constructor-expr compiler symtbl to-class)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (is-target-object? to-class))
  (let ((binder (compiler-get-binder compiler)))
    (cond
     ((is-t-apti? to-class)
      (if (hfield-ref compiler 'inside-param-def?)
	  (get-empty-constructor to-class)
	  (raise 'illegal-abstract-class-for-constructor)))
     ((not (is-known-object? to-class))
      (raise 'illegal-class-for-constructor))
     ((and (not (hfield-ref compiler 'inside-param-def?))
	   (not (is-t-instance? binder to-class tc-class)))
      (raise 'constructor-not-a-class))
     ((is-t-type-variable? to-class)
      (make-hrecord <expr-constructor>
		    tt-general-proc-with-value
		    #f
		    #f
		    '() 
		    #t
		    #t
		    #t
		    '()
		    to-class))
     ((is-t-instance? binder to-class tpc-pair)
      (let ((type (translate-simple-proc-class-expression
		   binder
		   (tno-field-ref to-class 'l-tvar-values)
		   to-class #t #t #f #f)))
	(make-hrecord <expr-constructor>
		      type
		      #t
		      #t
		      '() 
		      #t
		      #t
		      #f
		      '()
		      to-class)))
     (else
      (let ((type-constructor
	     (tno-field-ref to-class 'type-constructor))
	    (access
	     (tno-field-ref to-class 's-ctr-access))
	    (modname-cl (tno-field-ref to-class 'module))
	    (modname-cur (get-current-module-name compiler)))
	(cond
	 ((null? type-constructor)
	  (raise 'internal-undefined-constructor))
	 ((not (check-constructor-access? access modname-cur modname-cl))
	  (raise 'constructor-access-violation))
	 (else (get-constructor-expr to-class type-constructor))))))))


(define (translate-set-expression
	 compiler symtbl toplevel? constant? expr-tail)
  (if (not (= (length expr-tail) 2))
      (raise 'invalid-set)
      (let ((s-name (car expr-tail))
	    (s-value (cadr expr-tail)))
	(let* ((value-expr 
		(translate-expr compiler symtbl #f s-value))
	       (var (translate-expr compiler symtbl #f s-name))
	       (variable
		(cond
		 ((is-target-object? var) var)
		 ((hrecord-is-instance? var <variable-reference>)
		  (hfield-ref var 'variable))
		 (else
		  (raise 'set!:invalid-variable)))))
	  (cond
	   ((eqv? variable #f)
	    (raise 'unbound-variable-in-set!))
	   ((not (is-normal-variable? variable))
	    (raise 'trying-to-set-nonmutable-variable))
	   ((hfield-ref variable 'read-only?)
	    (raise 'attempted-setting-of-read-only-variable))
	   ((entity-type-is-none1? (compiler-get-binder compiler) value-expr)
	    (raise 'set-expression-with-type-none))
	   ;; We need not check may-change-variable? for module
	   ;; references since they are toplevel variables.
	   ((and (symbol? s-name) (not (may-change-variable? symtbl s-name)))
	    (raise 'purity-violation-in-set-expr))
	   (else
	    ;; We may set the <set-expression>'s to be pure
	    ;; because testing may-change-variable? takes care
	    ;; of purity violations.
	    (if (hfield-ref compiler 'inside-param-def?)
		(make-hrecord <set-expression>
			      tt-none
			      #t
			      #t
			      '()
			      #t
			      #f
			      #t
			      '()
			      (entity-always-returns? value-expr)
			      (entity-never-returns? value-expr)
			      variable
			      value-expr)
		(let ((value-type (get-entity-type value-expr))
		      (variable-type (get-entity-type variable)))
		  (if (not (is-t-subtype?
			    (compiler-get-binder compiler)
			    value-type
			    variable-type))
		      (begin
			(dvar1-set! value-type)
			(dvar2-set! variable-type)
			(raise 'type-mismatch-in-set!))
		      (make-hrecord <set-expression>
				    tt-none
				    #t
				    #t
				    '()
				    #t
				    #f
				    #f
				    '()
				    (entity-always-returns? value-expr)
				    (entity-never-returns? value-expr)
				    variable
				    value-expr))))))))))


(define (translate-field compiler env s-field)
  (if (pair? s-field)
      (let ((len (length s-field)))
	(if (or (= len 4) (= len 5))
	    (let* ((field-name 
		    (car s-field))
		   (r-field-type
		    (translate-expr compiler env #f 
				    (cadr s-field)))
		   (r-read-access (list-ref s-field 2))
		   (r-write-access (list-ref s-field 3))
		   (has-init-value? (= len 5))
		   (r-init-value
		    (if has-init-value?
			(translate-expr compiler env #f 
					(list-ref s-field 
						  i-source-field-init-value))
			'()))
		   (binder (compiler-get-binder compiler)))
	      (cond
	       ((entity-is-none1? binder r-field-type)
		(raise 'none-as-a-field-type))
	       ((not (memv r-read-access '(hidden module public)))
		(raise 'invalid-read-access))
	       ((not (memv r-write-access '(hidden module public)))
		(raise 'invalid-write-access))
	       ((not (is-t-subtype?
		      binder
		      (get-entity-type r-field-type)
		      tt-type))
		(raise 'invalid-field-type))
	       ((and has-init-value?
		     (not
		      (is-t-instance?
		       binder
		       r-init-value
		       r-field-type)))
		(raise (list 'field-initializer-type-mismatch
			     (cons 's-field-name field-name)
			     (cons 'tt-field r-field-type)
			     (cons 'tt-init (get-entity-type r-init-value)))))
	       (else
		(make-field field-name r-field-type
			    r-read-access r-write-access
			    has-init-value? r-init-value))))
	    (raise 'invalid-field-spec-length)))
      (raise 'invalid-field-spec)))


(define (translate-field-list compiler s-field-list env)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (list? s-field-list))
  (assert (hrecord-is-instance? env <environment>))
  (let ((result
	 (map (lambda (s-field) (translate-field compiler env s-field))
	      s-field-list)))
    result))


(define (do-translate-class compiler env s-name decl
			    r-superclass t-field-list
			    inheritable? immutable? eq-by-value?
			    ctr-access)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (assert (symbol? s-name))
  (assert (and (is-target-object? decl) (hfield-ref decl 'incomplete?)))
  (assert (hrecord-is-instance? r-superclass <target-object>))
  (assert (list? t-field-list))
  (assert (boolean? inheritable?))
  (assert (boolean? immutable?))
  (assert (boolean? eq-by-value?))
  (assert (memq ctr-access gl-access-specifiers))
  ;; Should we pass address to make-target-class?
  (let* ((to (make-target-class
	      (hfield-ref decl 'address)
	      (get-current-module-name compiler)
	      r-superclass t-field-list
	      inheritable? immutable? eq-by-value?
	      ctr-access))
	 ;; Classes are always declared forward.
	 (variable
	  (bind-object! compiler env s-name decl to tc-class))
	 (binder (compiler-get-binder compiler)))
    (make-constructor! binder decl)
    (make-hrecord <class-definition>
		  tt-none #t #t '()
		  #f #f #f '()
		  variable tc-class '() #t #f #f)))


(define (translate-define-class compiler symtbl expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  (if (= (length expr-tail) 8)
      (let ((s-name (car expr-tail))
	    (s-superclass (cadr expr-tail))
	    (inheritable? (caddr expr-tail))
	    (immutable? (list-ref expr-tail 3))
	    (eq-by-value? (list-ref expr-tail 4))
	    (ctr-access (list-ref expr-tail 5))
	    (s-zero-proc (list-ref expr-tail 6))
	    (s-field-list (list-ref expr-tail 7)))
	(if (or
	     (not (boolean? inheritable?))
	     (not (boolean? immutable?))
	     (not (boolean? eq-by-value?))
	     (not (memq ctr-access gl-access-specifiers)))
	    (raise 'syntax-error-in-define-class))
	(if (null? s-superclass)
	    (raise 'superclass-not-specified))
	(let* ((bound-value (get-symbol symtbl s-name))
	       (rebind? (check-existing-binding? compiler bound-value))
	       (decl
		(if rebind?
		    empty-expression
		    (translate-forward-declaration compiler symtbl s-name
						   tc-class #t #f)))
	       (to-decl
		(if rebind?
		    (begin
		      (assert (not (eq? bound-value #f)))
		      (get-entity-value bound-value))
		    (hfield-ref (hfield-ref decl 'variable) 'value))))
	  (let* ((to-superclass
		  (translate-expr compiler symtbl #f s-superclass))
		 (binder (compiler-get-binder compiler)))
	    (if (not
		 (and (is-target-object? to-superclass)
		      (is-t-instance? binder to-superclass tc-class)))
		(raise 'invalid-superclass))
	    (let ((t-field-list (translate-field-list compiler s-field-list
						      symtbl)))
	      (cond
	       ((entity-is-none1? (compiler-get-binder compiler)
				  to-superclass)
		(raise 'none-as-superclass))
	       ;; Myöskään piilossa olevat kenttien nimet eivät
	       ;; saa mennä päällekäin.
	       ((contains-duplicate-field-names? to-superclass t-field-list)
		(raise 'duplicate-field-name))
	       ;; If the superclass is incomplete to-superclass should be null.
;;	       ((is-forward-decl? var-superclass)
;;		(raise 'forward-declared-superclass))
	       ((not (tno-field-ref to-superclass 'inheritable?))
		(raise 'noninheritable-superclass))
	       ((tno-field-ref to-superclass 'goops?)
		(raise 'illegal-goops-superclass))
	       (else
		(let* ((class-def
			(do-translate-class compiler symtbl s-name to-decl
					    to-superclass t-field-list
					    inheritable? immutable? eq-by-value?
					    ctr-access))
		       (var (hfield-ref class-def 'variable))
;;		       (to-clas (hfield-ref var 'value)))
		       (to-clas to-decl))
		  (assert (not-null? to-clas))
		  (if (and (tno-field-ref to-clas 'immutable?)
			   (not (is-valid-immutable-class? to-clas)))
		      (raise 'invalid-immutable-class))
		  (if (not (is-null-sexpr? s-zero-proc))
		      (begin
			(let* ((zero-proc-body
				(translate-expr compiler symtbl #f s-zero-proc))
			       (zero-proc-class
				(translate-simple-proc-class-expression
				 binder
				 '()
				 to-clas #t #t #f #f))
			       (zero-proc
				(make-hrecord
				 <procedure-expression>
				 zero-proc-class #t #t '()
				 #t #f #f '()
				 '() '() '() to-clas
				 zero-proc-body
				 'zero
				 '()
				 '()
				 #t
				 #f
				 #t
				 #f
				 #f))
			       (zero-setting
				(make-hrecord <zero-setting-expr>
					      zero-proc-class #t #t '()
					      #f #f #f '()
					      var zero-proc #f)))
			  (list decl class-def zero-setting)))
		      (list decl class-def)))))))))
      (raise 'syntax-error-in-define-class)))


(define (get-first-arg-type arg-types)
  (if (pair? arg-types)
      (car arg-types)
      (raise 'syntax-error-in-make)))


(define (make-type-var compiler type-var-name)
  ;; Type variables are lexical.
  (let ((type-var
	 (make-type-variable
	  (compiler-alloc-loc compiler type-var-name #f))))
    (cons type-var-name type-var)))


(define (make-type-vars compiler type-var-names)
  (map (lambda (type-var-name) (make-type-var compiler type-var-name))
       type-var-names))


(define (translate-procedure-expression compiler env
					s-arglist s-result-type
					s-attr
					s-body
					s-kind s-name)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (strong-assert (list? s-arglist))
  (strong-assert (list? s-body))
  (check-env env)
  (let* ((names (map car s-arglist))
	 (s-arg-descs (map cadr s-arglist))
	 (arg-descs
	  (map (lambda (subexpr)
		 (translate-expr compiler env #f subexpr))
	       s-arg-descs))
	 (binder (compiler-get-binder compiler))
	 (impl-arg-types (get-impl-arg-types binder arg-descs)))
    (let* ((alloc-var (lambda (name toplevel?)
			(compiler-alloc-loc compiler name toplevel?)))
	   (arg-bindings
	    (make-argument-bindings binder alloc-var names
				    impl-arg-types))
	   (arg-variables (map cdr arg-bindings))
	   (t-result-type
	    (if (not-null? s-result-type)
		(translate-expr compiler env #f
				s-result-type)
		tt-none))
	   (attr (parse-proc-attributes s-attr))
	   (pure-proc? (hfield-ref attr 'pure?))
	   (force-pure? (hfield-ref attr 'force-pure?))
	   (appl-always-returns? (hfield-ref attr 'always-returns?))
	   (appl-never-returns? (hfield-ref attr 'never-returns?))
	   (static-method? (hfield-ref attr 'static-method?))
	   (proc-type (translate-simple-proc-class-expression
		       binder
		       arg-descs t-result-type
		       pure-proc?
		       appl-always-returns?
		       appl-never-returns?
		       static-method?))
	   (env-with-args
	    (if pure-proc?
		(make-pure-proc-env
		 env arg-bindings)
		(make-environment
		 env arg-bindings))))
      (let* ((cur-letrec-env (hfield-ref compiler
					 'current-letrec-env))
	     (old-inside-proc?
	      (if (null? cur-letrec-env)
		  #f
		  (hfield-ref cur-letrec-env 'inside-proc?))))
	(if (not-null? cur-letrec-env)
	    (hfield-set! cur-letrec-env 'inside-proc? #t))
	(let ((t-body
	       (wrap-compound-expression compiler env-with-args
					 s-body))
	      (inside-param-def? (hfield-ref compiler 'inside-param-def?)))
	  (if (not-null? cur-letrec-env)
	      (hfield-set! cur-letrec-env 'inside-proc?
			   old-inside-proc?))
	  ;; If purity specifier is gl-force-pure
	  ;; the procedure body is allowed to be nonpure.
	  (cond
	   ((and (not inside-param-def?)
		 pure-proc?
		 (not force-pure?)
		 (not (is-pure-entity? t-body)))
	    (dvar1-set! t-body)
	    (raise 'purity-mismatch))
	   ((and (not inside-param-def?)
		 appl-always-returns?
		 (not (entity-always-returns? t-body)))
	    (raise 'proc-attribute-mismatch))
	   ((and (not inside-param-def?)
		 appl-never-returns?
		 (not (entity-never-returns? t-body)))
	    (raise 'proc-attribute-mismatch))
	   (else
	    (let ((body-never-returns?
		   (entity-never-returns? t-body)))
	      (if (and (not (hfield-ref compiler 'inside-param-def?))
		       (not body-never-returns?)
		       (not (check-procedure-result-type?
			     binder
			     (get-entity-type t-body)
			     t-result-type)))
		  (begin
		    (dvar1-set! compiler)
		    (dvar2-set! env)
		    (dvar3-set! (list s-body body-never-returns?))
		    (dvar4-set! (list t-body t-result-type))
		    (raise (list 'result-type-mismatch-1
				 (cons 'declared-type t-result-type)
				 (cons 'actual-type (get-entity-type t-body)))))
		  (let ((to (make-procedure proc-type #t #f
					    '() s-name '()))
			(need-revision?
			 (hfield-ref compiler
				     'inside-param-def?)))
		    (make-hrecord <procedure-expression>
				  proc-type #t #t '()
				  #t #t need-revision? to
				  names
				  arg-descs
				  arg-variables
				  t-result-type
				  t-body
				  s-kind
				  s-name
				  '()
				  pure-proc?
				  force-pure?
				  appl-always-returns?
				  appl-never-returns?
				  static-method?)))))))))))


(define (translate-procedure-expression-aut compiler env
					    s-arglist
					    s-attr
					    s-body
					    s-kind s-name)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env <environment>))
  (strong-assert (list? s-arglist))
  (strong-assert (list? s-body))
  (check-env env)
  (let* ((names (map car s-arglist))
	 (s-arg-descs (map cadr s-arglist))
	 (arg-descs
	  (map (lambda (subexpr)
		 (translate-expr compiler env #f subexpr))
	       s-arg-descs))
	 (binder (compiler-get-binder compiler))
	 (impl-arg-types (get-impl-arg-types binder arg-descs)))
    (let* ((alloc-var (lambda (name toplevel?)
			(compiler-alloc-loc compiler name toplevel?)))
	   (arg-bindings
	    (make-argument-bindings binder alloc-var names
				    impl-arg-types))
	   (arg-variables (map cdr arg-bindings))
	   (attr (parse-proc-attributes s-attr))
	   (pure-proc? (hfield-ref attr 'pure?))
	   (force-pure? (hfield-ref attr 'force-pure?))
	   (appl-always-returns? (hfield-ref attr 'always-returns?))
	   (appl-never-returns? (hfield-ref attr 'never-returns?))
	   (static-method? (hfield-ref attr 'static-method?))
	   (env-with-args
	    (if pure-proc?
		(make-pure-proc-env
		 env arg-bindings)
		(make-environment
		 env arg-bindings))))
      (let* ((cur-letrec-env (hfield-ref compiler
					 'current-letrec-env))
	     (old-inside-proc?
	      (if (null? cur-letrec-env)
		  #f
		  (hfield-ref cur-letrec-env 'inside-proc?))))
	(if (not-null? cur-letrec-env)
	    (hfield-set! cur-letrec-env 'inside-proc? #t))
	(let* ((t-body
		(wrap-compound-expression compiler env-with-args
					  s-body))
	       (t-result-type (get-entity-type t-body))
	       (proc-type (translate-simple-proc-class-expression
			   binder
			   arg-descs t-result-type
			   pure-proc?
			   appl-always-returns?
			   appl-never-returns?
			   static-method?))
	       (inside-param-def? (hfield-ref compiler 'inside-param-def?)))
	  (if (not-null? cur-letrec-env)
	      (hfield-set! cur-letrec-env 'inside-proc?
			   old-inside-proc?))
	  ;; If purity specifier is gl-force-pure
	  ;; the procedure body is allowed to be nonpure.
	  (cond
	   ((and (not inside-param-def?)
		 pure-proc?
		 (not force-pure?)
		 (not (is-pure-entity? t-body)))
	    (dvar1-set! t-body)
	    (raise 'purity-mismatch))
	   ((and (not inside-param-def?)
		 appl-always-returns?
		 (not (entity-always-returns? t-body)))
	    (raise 'proc-attribute-mismatch))
	   ((and (not inside-param-def?)
		 appl-never-returns?
		 (not (entity-never-returns? t-body)))
	    (raise 'proc-attribute-mismatch))
	   (else
	    (let ((body-never-returns?
		   (entity-never-returns? t-body)))
	      (let ((to (make-procedure proc-type #t #f '()
					s-name '()))
		    (need-revision?
		     (hfield-ref compiler
				 'inside-param-def?)))
		(make-hrecord <procedure-expression>
			      proc-type #t #t '()
			      #t #t need-revision? to
			      names
			      arg-descs
			      arg-variables
			      t-result-type
			      t-body
			      s-kind
			      s-name
			      '()
			      pure-proc?
			      force-pure?
			      appl-always-returns?
			      appl-never-returns?
			      static-method?))))))))))


(define (translate-param-proc-expr compiler symtbl
				   type-params
				   s-arglist
				   s-result-type
				   s-body
				   s-attr
				   s-kind s-name
				   aut-result-type?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? aut-result-type?))
  (let ((inside-param-def-old?
	 (hfield-ref compiler 'inside-param-def?)))
    (hfield-set! compiler 'inside-param-def? #t)
    (let ((r-type-params (map cdr type-params))
	  (old-fixed-tvars (compiler-get-fixed-tvars compiler)))
      (compiler-set-fixed-tvars!
       compiler
       (append old-fixed-tvars r-type-params))
      (let* ((r-proc0
	      ;; The parametrized procedure is named but the component
	      ;; procedure is not.
	      (if aut-result-type?
		  (translate-procedure-expression-aut
		   compiler symtbl s-arglist
		   s-attr s-body '() '())
		  (translate-procedure-expression
		   compiler symtbl s-arglist s-result-type
		   s-attr s-body '() '())))
	     (r-proc-type (get-entity-type r-proc0))
	     (to-param-proc-class
	      (make-param-proc-class-object
	       "instance of :param-proc"
	       r-type-params
	       r-proc-type))
	     (to-param-proc
	      (make-param-proc-object
	       s-name
	       to-param-proc-class
	       '()
	       '()))
	     (r-proc (make-param-proc2 r-type-params
				       to-param-proc-class r-proc0
				       s-kind
				       '()
				       to-param-proc)))
	(tno-field-set! to-param-proc 'x-value-expr r-proc0)
	(compiler-set-fixed-tvars! compiler old-fixed-tvars)
	(hfield-set! compiler 'inside-param-def? inside-param-def-old?)
	r-proc))))


(define (translate-general-proc-type1 compiler env1 simple? s-arg-list
				      s-result-type s-attributes)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env1 <environment>))
  (assert (boolean? simple?))
  (let* ((arg-desc-exprs
	  (map* (lambda (expr)
		  (translate-expr compiler env1 #f expr))
		s-arg-list))
	 (binder (compiler-get-binder compiler))
	 (parsed-attr (parse-proc-attributes s-attributes))
	 (pure-proc? (hfield-ref parsed-attr 'pure?))
	 (appl-always-returns? (hfield-ref parsed-attr 'always-returns?))
	 (appl-never-returns? (hfield-ref parsed-attr 'never-returns?))
	 (static-method? (hfield-ref parsed-attr 'static-method?))
	 (result-type (translate-expr compiler env1 #f s-result-type)))
    (if (not (and-map? (lambda (argdesc) (is-type? binder argdesc))
		       arg-desc-exprs))
	(raise 'procedure-type-arg-syntax-error))
    (translate-general-proc-type-expression
     binder
     simple?
     arg-desc-exprs
     result-type
     pure-proc?
     appl-always-returns?
     appl-never-returns?
     static-method?)))


(define (translate-general-proc-type compiler env1 expr-tail simple?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env1 <environment>))
  (assert (boolean? simple?))
  (if (or (not (pair? expr-tail)) (not (= (length expr-tail) 3)))
      (raise 'invalid-procedure-class-definition)
      (let ((s-arg-list (car expr-tail))
	    (s-result-type (list-ref expr-tail 1))
	    (s-attributes (list-ref expr-tail 2)))
	(translate-general-proc-type1 compiler env1 simple? s-arg-list
				      s-result-type
				      s-attributes))))


(define (do-translate-param-proc-class compiler local-env
				       type-params s-arg-list s-result-type
				       s-attr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? local-env <environment>))
  (let* ((r-type-params (map cdr type-params))
	 (arg-desc-exprs
	  (map* (lambda (expr)
		  (translate-expr compiler local-env #f expr))
		s-arg-list))
	 (attr (parse-proc-attributes s-attr))
	 (pure-proc? (hfield-ref attr 'pure?))
	 (appl-always-returns? (hfield-ref attr 'always-returns?))
	 (appl-never-returns? (hfield-ref attr 'never-returns?))
	 ;; Maybe we should not allow attribute "static" with procedure types.
	 (static-method? (hfield-ref attr 'static-method?))
	 (result-type (translate-expr compiler local-env #f s-result-type))
	 (binder (compiler-get-binder compiler))
	 (inst-type (translate-simple-proc-class-expression
		     binder
		     arg-desc-exprs result-type
		     pure-proc? appl-always-returns? appl-never-returns?
		     static-method?)))
    (make-param-proc-class-object "instance of :param-proc"
				  r-type-params
				  inst-type)))


(define (do-translate-param-proc-class2 compiler env1
					s-tvars s-arg-list s-result-type
					s-attr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env1 <environment>))
  (let* ((type-params (make-type-vars compiler s-tvars))
	 (local-env (make-environment
		     env1 type-params)))
    (do-translate-param-proc-class compiler local-env type-params
				   s-arg-list s-result-type
				   s-attr)))


(define (translate-param-proc-class compiler env1 expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env1 <environment>))
  (if (or (not (pair? expr-tail)) (not (= (length expr-tail) 4)))
      (raise 'invalid-param-proc-class-definition)
      (let ((s-tvars (car expr-tail))
	    (s-arg-list (cadr expr-tail))
	    (s-result-type (list-ref expr-tail 2))
	    (s-attr (list-ref expr-tail 3)))
	(do-translate-param-proc-class2 compiler env1
					s-tvars s-arg-list s-result-type
					s-attr))))


(define (parse-let-var-nonconstant compiler env1 varspec volatile?)
  (if (not (= (length varspec) 3))
      (raise 'invalid-let-variable)
      (let ((name (car varspec)))
	(if (not (symbol? name)) (raise 'invalid-let-var-name))
	(let* ((to-name (make-primitive-object tc-symbol name))
	       (type (translate-expr compiler env1 #f (cadr varspec))))
	  (if (not (is-type?
		    (compiler-get-binder compiler) type))
	      (raise (list 'invalid-let-var-type (cons 's-name name))))
	  (let* ((init-expr (translate-expr
			     compiler
			     env1
			     #f 
			     (caddr varspec)))
		 (binder (compiler-get-binder compiler))
		 (result
		  (cond
		   ((and (not (hfield-ref compiler 'inside-param-def?))
			 (entity-is-none1? binder type))
		    (raise 'none-as-declared-type))
		   ((and (not (hfield-ref compiler 'inside-param-def?))
			 (entity-type-is-none1? binder init-expr))
		    (raise (list 'initializer-expression-with-type-none
				 (cons 's-name name))))
		   (else
		    (if (not (hfield-ref compiler 'inside-param-def?))
			(let ((to-init-type (get-entity-type init-expr)))
			  (cond
			   ;; The following check is probably unnecessary.
			   ((null? type)
			    (raise 'internal-invalid-letvar-type-1))
			   ((null? to-init-type)
			    (raise 'internal-invalid-letvar-type-2))
			   ((is-t-subtype?
			     binder
			     to-init-type
			     type)
			    (let ((variable
				   (make-normal-variable5
				    (compiler-alloc-loc compiler name #f)
				    type
				    #f
				    #f
				    volatile?
				    '())))
			      (list to-name
				    variable
				    variable type init-expr
				    gl-false)))
			   (else
			    (raise (list 'let:type-mismatch
					 (cons 's-name name)
					 (cons 'tt-declared type)
					 (cons 'tt-actual to-init-type))))))
			(let ((variable 
			       (make-normal-variable6
				(compiler-alloc-loc compiler name #f)
				type
				#t
				(is-final-class? binder type)
				#f
				volatile?
				#f
				'()
				'())))
			  (list to-name
				variable
				variable type init-expr
				gl-false)))))))
	    result)))))


(define (parse-let-var-constant compiler env1 varspec)
  (if (not (or (= (length varspec) 2) (= (length varspec) 3)))
      (raise 'invalid-let-variable)
      (let ((has-type-spec? (= (length varspec) 3))
	    (name (car varspec)))
	(if (not (symbol? name)) (raise 'invalid-let-var-name))
	(let* ((to-name (make-primitive-object tc-symbol name))
	       (sexpr-init (if has-type-spec? (caddr varspec) (cadr varspec)))
	       (tmp1 (begin (set-proc-expr compiler sexpr-init 'local name) 0))
	       (init-expr (translate-expr
			   compiler
			   env1
			   #f 
			   sexpr-init))
	       (tmp2 (begin (unset-proc-expr compiler sexpr-init) 0))
	       (type-actual (get-entity-type init-expr))
	       (type-declared
		(if has-type-spec?
		    (translate-expr compiler env1 #f
				    (cadr varspec))
		    '()))
	       (type-var (if (not-null? type-declared)
			     type-declared
			     type-actual)))
	  (if (and has-type-spec?
		   (not (is-type?
			 (compiler-get-binder compiler) type-declared)))
	      (raise (list 'invalid-let-var-type (cons 's-name name))))
	  ;; If we are inside a parametrized procedure
	  ;; the type of the initializer expression may not be final.
	  (let* ((binder (compiler-get-binder compiler))
		 (value (get-entity-value init-expr))
		 (address (compiler-alloc-loc compiler name #f))
		 (to-new
		  ;; Optimizing types caused problems with
		  ;; let expressions result types when a result type
		  ;; was a variable.
		  (if (and
		       (is-known-object? value)
		       (not (is-type? binder value)))
		      (make-object-with-address value address)
		      value))
		 (known-init? (is-known-object? init-expr))
		 (init-expr2
		  (if known-init?
		      to-new
		      init-expr))
		 (variable
		  (let ((type-dispatched?
			 (entity-type-dispatched? init-expr))
			(free-tvars?
			 (or (contains-free-tvars? type-actual)
			     (contains-free-tvars? type-declared))))
		    (cond
		     ((and (not type-dispatched?)
			   (not (hfield-ref compiler 'inside-param-def?)))
		      (raise 'let:illegal-nondispatched-expression))
		     ((entity-is-none1? binder type-actual)
		      (raise (list 'let:initializer-none
				   (cons 's-name name))))
		     ((and (not-null? type-declared)
			   (entity-is-none1? binder type-declared))
		      (raise 'let:type-none))
		     ((and (not type-dispatched?)
			   (hfield-ref compiler 'inside-param-def?))
		      (make-normal-variable3
		       address
		       type-var
		       #f
		       #f
		       #t
		       #f
		       to-new
		       '()))
		     ((or (not (is-known-object? type-actual))
			  (and (not-null? type-declared)
			       (not (is-known-object? type-declared))))
		      (raise 'let:invalid-type))
		     ((or
		       (and (hfield-ref compiler 'inside-param-def?)
			    (or (not type-dispatched?) free-tvars?))
		       (or (null? type-declared)
			   (is-t-subtype? binder type-actual type-declared)))
		      (make-normal-variable3
		       address
		       type-var
		       type-dispatched?
		       (is-final-class? binder type-var)
		       #t
		       #f
		       to-new
		       '()))
		     (else
		      (raise (list 'let:type-mismatch
				   (cons 's-name name)
				   (cons 'tt-declared type-declared)
				   (cons 'tt-actual type-actual))))))))
	    (list to-name variable
		  (if known-init? init-expr2 variable)
		  type-declared init-expr
		  (if known-init? gl-true gl-false)))))))


(define (parse-let-vars compiler env1 readonly? volatile? s-vars)
  (if readonly?
      (map-in-order (lambda (varspec)
		      (parse-let-var-constant compiler env1 varspec))
		    s-vars)
      (map-in-order (lambda (varspec)
		      (parse-let-var-nonconstant compiler env1 varspec
						 volatile?))
		    s-vars)))


(define (get-bindings vars)
  (map (lambda (var)
	 (assert (is-t-primitive-object? (car var)))
	 (cons (get-contents (car var)) (caddr var)))
       vars))


(define (translate-let-expression compiler env1 expr-tail constant-bindings?
				  volatile?)
  ;; TBD: Raise an exception if both constant-bindings? and volatile? are #t.
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? env1 <environment>))
  (assert (list? expr-tail))
  (assert (not (and constant-bindings? volatile?)))
  (check-env env1)
  (if (< (length expr-tail) 2)
      (raise 'too-short-let)
      (let* ((s-vars (car expr-tail))
	     (s-body (cdr expr-tail))
	     (varspecs (parse-let-vars compiler env1 constant-bindings?
				       volatile? s-vars))
	     (bindings (get-bindings varspecs))
	     (local-env (make-environment env1 bindings))
	     (init-exprs
	      (map pick5th varspecs)))
	(let* ((t-body
		(wrap-compound-expression compiler local-env s-body))
	       (subexpr-type (get-entity-type t-body))
	       (exact-type? (hfield-ref t-body 'exact-type?))
	       (subexpr-pure? (is-pure-entity? t-body))
	       (subexpr-value (get-entity-value t-body))
	       (init-exprs-pure?
		(and-map? is-pure-entity? init-exprs))
	       (let-expr-pure? (and subexpr-pure? init-exprs-pure?))
	       (type-dispatched? (entity-type-dispatched? t-body))
	       (always-returns?
		(and (entity-always-returns? t-body)
		     (and-map? entity-always-returns? init-exprs)))
	       (never-returns?
		(or (entity-never-returns? t-body)
		    (or-map? entity-never-returns? init-exprs))))
	  (if (and (not type-dispatched?)
		   (not (hfield-ref compiler 'inside-param-def?)))
	      (raise 'let:illegal-nondispatched-expr))
	  (make-hrecord <let-expression>
			subexpr-type           ; <expression>
			type-dispatched?
			exact-type?
			'()
			let-expr-pure?
			#f
			;; TBD: Should we set need-revision? to #f if
			;; type-dispatched? = #t ?
			(hfield-ref compiler 'inside-param-def?)
			subexpr-value
			always-returns?        ; <dynamic-expression>
			never-returns?
			constant-bindings?     ; <let-expression>
			#f
			#f
			varspecs
			t-body)))))


(define (translate-letrec-expression compiler env expr-tail
				     constant-bindings? volatile? order?)
  ;; TBD: Raise an exception if both constant-bindings? and volatile? are #t.
  (if (< (length expr-tail) 2)
      (raise 'too-short-letrec)
      (let* ((s-varspecs (car expr-tail))
	     (s-body (cdr expr-tail))
	     (letrec-vars-parse-result
	      (parse-letrec-vars compiler env s-varspecs constant-bindings?
				 volatile?))
	     (letrec-vars (car letrec-vars-parse-result))
	     (new-env (cadr letrec-vars-parse-result))
	     (t-body
	      (wrap-compound-expression
	       compiler new-env s-body))
	     (subexpr-type (get-entity-type t-body))
	     (exact-type? (hfield-ref t-body 'exact-type?))
	     (subexpr-pure? (is-pure-entity? t-body))
	     (subexpr-value (get-entity-value t-body))
	     (type-dispatched? (entity-type-dispatched? t-body))
	     (init-exprs (map pick5th letrec-vars))
	     (init-exprs-pure?
	      (and-map? is-pure-entity? init-exprs))
	     (letrec-pure? (and subexpr-pure? init-exprs-pure?))
	     (always-returns?
	      (and (entity-always-returns? t-body)
		   (and-map? entity-always-returns? init-exprs)))
	     (never-returns?
	      (or (entity-never-returns? t-body)
		  (or-map? entity-never-returns? init-exprs))))
	(if (and (not type-dispatched?)
		 (not (hfield-ref compiler 'inside-param-def?)))
	    (raise 'letrec:illegal-nondispatched-expr))
	(make-hrecord <let-expression>
		      subexpr-type           ; <expression>
		      type-dispatched?
		      exact-type?
		      '()
		      letrec-pure?
		      #f
		      (hfield-ref compiler 'inside-param-def?)
		      subexpr-value
		      always-returns?        ; <dynamic-expression>
		      never-returns?
		      constant-bindings?     ; <let-expression>
		      #t
		      order?
		      letrec-vars
		      t-body))))


(define (translate-genproc-appl compiler symtbl expr-head expr-tail)
  ;; It is essential to use map* here.
  ;; tarkista seuraava
  (let ((arglist (map* (lambda (expr)
			 (translate-expr compiler symtbl #f expr))
		       expr-tail))
	(inside-param-def? (hfield-ref compiler 'inside-param-def?))
	(binder (compiler-get-binder compiler)))
    ;; TBD: Should we check that expr-head is a target object?
    (translate-general-genproc-appl
     binder
     expr-head arglist #t)))


(define (translate-param-proc-appl compiler symtbl expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (is-entity? expr-head))
  (assert (list? expr-tail))
  (check-env symtbl)
  (let ((arglist (map* (lambda (expr)
			 (translate-expr compiler symtbl #f expr))
		       expr-tail)))
    (do-translate-param-proc-appl (compiler-get-binder compiler)
				  (hfield-ref compiler 'inside-param-def?)
				  expr-head arglist '())))


(define (translate-simple-proc-appl compiler symtbl expr-head expr-tail)
  (let ((arguments (map* (lambda (expr)
			   (translate-expr compiler symtbl #f expr))
			 expr-tail)))
    (let ((result '()))
      (set! result
	    ;; Procedures field-ref and field-set!
	    ;; are handled differently by the compiler
	    ;; and the linker. That's why we handle them here.
	    ;; TBD: use eq? instead of eqv?
	    (cond
	     ((eqv? expr-head tp-field-ref)
	      (translate-field-ref-appl compiler expr-head arguments))
	     ((eqv? expr-head tp-field-set)
	      (translate-field-set-appl compiler expr-head arguments))
	     (else '())))
      (if (null? result)
	  (let* ((inside-param-def? (hfield-ref compiler 'inside-param-def?))
		 (result2
		  (do-translate-simple-proc-appl
		   expr-head arguments #f
		   (compiler-get-binder compiler)
		   #t
		   inside-param-def?
		   inside-param-def?)))
	    result2)
	  (begin
	    result)))))


(define (translate-pair-class compiler symtbl expr-tail)
  (if (>= (length expr-tail) 1)
      (let ((args
	     (map*
	      (lambda (expr)
		(translate-expr compiler symtbl #f expr))
	      expr-tail))
	    (binder (compiler-get-binder compiler)))
	(translate-pair-class-expression binder args))
      (raise 'invalid-pair-class-expression)))


;; It is legal to give <none> as a member of a union type.
;; In that case the union type will be equal to <none>.
(define (translate-union compiler symtbl expr-tail)
  (if (null? expr-tail)
      tt-none
      (let ((subexprs (map*
		       (lambda (expr)
			 (translate-expr compiler symtbl #f expr))
		       expr-tail))
	    (binder (compiler-get-binder compiler)))
	(get-union-of-types binder subexprs))))


(define (translate-vector compiler symtbl expr-tail)
  (if (= (length expr-tail) 1)
      (let ((member-type (translate-expr compiler symtbl #f (car expr-tail)))
 	    (binder (compiler-get-binder compiler)))
	(translate-vector-expression binder (list member-type)))
      ;; TBD: remove "uniform"
      (raise 'invalid-uniform-vector-expression)))


(define (translate-mutable-vector compiler symtbl expr-tail)
  (if (= (length expr-tail) 1)
      (let ((member-type (translate-expr compiler symtbl #f (car expr-tail)))
 	    (binder (compiler-get-binder compiler)))
	(translate-mutable-vector-expression binder
					     (list member-type)))
      (raise 'invalid-mutable-vector-expression)))


(define (translate-value-vector compiler symtbl expr-tail)
  (if (= (length expr-tail) 1)
      (let ((member-type (translate-expr compiler symtbl #f (car expr-tail)))
 	    (binder (compiler-get-binder compiler)))
	(translate-value-vector-expression binder (list member-type)))
      (raise 'invalid-value-vector-expression)))


(define (translate-mutable-value-vector compiler symtbl expr-tail)
  (if (= (length expr-tail) 1)
      (let ((member-type (translate-expr compiler symtbl #f (car expr-tail)))
 	    (binder (compiler-get-binder compiler)))
	(translate-mutable-value-vector-expression binder (list member-type)))
      (raise 'invalid-mutable-value-vector-expression)))


(define (translate-param-class-instance compiler symtbl expr-head expr-tail)
  (assert (is-target-object? expr-head))
  (let* ((r-param-class expr-head)
	 (r-type-params
	  (map (lambda (subexpr) (translate-expr compiler symtbl #f subexpr))
	       expr-tail)))
    (strong-assert (and-map? is-target-object? r-type-params))
;;    (check-no-none-types r-type-params)
    (translate-param-class-instance-expr
     (compiler-get-binder compiler)
     r-param-class
     r-type-params
     (hfield-ref compiler 'inside-param-def?)
     #t)))


(define (translate-param-sgn-instance compiler symtbl expr-head expr-tail)
  (assert (is-target-object? expr-head))
  (let* ((r-param-sgn expr-head)
	 (r-type-params
	  (map (lambda (subexpr) (translate-expr compiler symtbl #f subexpr))
	       expr-tail)))
    (strong-assert (and-map? is-target-object? r-type-params))
;;    (check-no-none-types r-type-params)
    (translate-param-sgn-instance-expr
     (compiler-get-binder compiler)
     r-param-sgn
     r-type-params)))


(define (translate-param-logical-type-instance compiler symtbl
					       expr-head expr-tail)
  (assert (is-target-object? expr-head))
  (let* ((r-param-ltype expr-head)
	 (r-type-params
	  (map (lambda (subexpr) (translate-expr compiler symtbl #f subexpr))
	       expr-tail)))
    (strong-assert (and-map? is-target-object? r-type-params))
    (let ((result
	   (if (hfield-ref r-param-ltype 'incomplete?)
	       (make-apti r-param-ltype r-type-params)
	       (translate-param-ltype-instance-expr
		(compiler-get-binder compiler)
		r-param-ltype
		r-type-params))))
      result)))


(define (translate-uniform-list compiler symtbl toplevel? expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  ;;  (check-env symtbl)
  (if (not (= (length expr-tail) 1))
      (raise 'syntax-error-in-uniform-list-type)
      (let* ((s-arg (car expr-tail))
	     (r-arg
	      (translate-expr compiler symtbl #f s-arg))
	     (binder (compiler-get-binder compiler)))
	(translate-uniform-list-type-expression binder r-arg))))


(define (get-prim-proc-arg-names count)
  (let ((result '()))
    (do ((i 0 (+ i 1))) ((>= i count) result)
      (set! result (append result
			   (list
			    (string->symbol
			     (string-append
			      "_i_prim_arg_" (number->string i)))))))))


(define (translate-primitive-procedure compiler symtbl expr-tail check?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  (assert (boolean? check?))
  (check-env symtbl)
  (if (not (list? expr-tail))
      (raise 'invalid-procedure-definition)
      (let ((target-name (car expr-tail))
	    (header (cdr expr-tail)))
	(if (or (not (list? header)) (not (= (length header) 3)))
	    (raise 'invalid-procedure-header)
	    (let ((s-arg-desc-expr (list-ref header 0))
		  (s-result-expr (list-ref header 1))
		  (s-attr (list-ref header 2)))
	      (let* ((arg-descs
		      (map (lambda (expr)
			     (translate-expr compiler symtbl #f expr))
			   s-arg-desc-expr))
		     (result-type
		      ;; TBD: This check should probably be removed.
		      (if (not-null? s-result-expr)
			  (translate-expr compiler symtbl #f
					  s-result-expr)
			  tt-none))
		     ;; Should we use entity-is-none1? in the following?
		     (has-result? (not (target-type=?
					result-type tt-none)))
		     (attr (parse-proc-attributes s-attr))
		     (pure-proc? (hfield-ref attr 'pure?))
		     (appl-always-returns? (hfield-ref attr 'always-returns?))
		     (appl-never-returns? (hfield-ref attr 'never-returns?))
		     (static-method? (hfield-ref attr 'static-method?))
		     (binder (compiler-get-binder compiler))
		     ;; The class of a primitive procedure is
		     ;; a :simple-proc class.
		     (proc-type (translate-simple-proc-class-expression
				 binder
				 arg-descs
				 result-type
				 pure-proc?
				 appl-always-returns?
				 appl-never-returns?
				 static-method?)))
		(if (and has-result? check?)
		    (begin
		      (get-checked-prim-proc target-name proc-type))
		    (begin
		      (get-prim-proc-expression
		       target-name proc-type)))))))))


(define (translate-param-prim-proc compiler symtbl expr-tail check?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  (assert (boolean? check?))
  (check-env symtbl)
  (if (not (and (list? expr-tail) (= (length expr-tail) 5)))
      (raise 'invalid-procedure-definition)
      (let ((target-name (car expr-tail))
	    (s-tvars (cadr expr-tail))
	    (s-arg-types (list-ref expr-tail 2))
	    (s-result-type (list-ref expr-tail 3))
	    (s-attr (list-ref expr-tail 4)))
	(let* ((proc-type 
		(do-translate-param-proc-class2 compiler symtbl
						s-tvars
						s-arg-types
						s-result-type
						s-attr))
	       (result-type (tno-field-ref
			     (tno-field-ref proc-type 'type-contents)
			     'type-result))
	       ;; Should we use entity-is-none1? in the following?
	       (has-result? (not (target-type=? result-type tt-none))))
	  (if (and has-result? check?)
	      (begin
		(get-checked-prim-proc target-name proc-type))
	      (begin
		(get-prim-proc-expression
		 target-name proc-type)))))))


(define (translate-assertion compiler symtbl condition cond-to-print strong?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? strong?))
  (let* ((r-condition (translate-expr compiler symtbl #f condition))
	 (condition-bool?
	  (target-type=? (get-entity-type r-condition)
			 tc-boolean)))
    (cond
     ((and (not condition-bool?)
	   (not (hfield-ref compiler 'inside-param-def?)))
      (raise 'assertion-condition-not-boolean))
     ((and (not (is-pure-entity? r-condition))
	   (not (hfield-ref compiler 'inside-param-def?)))
      (raise 'assertion-condition-not-pure))
     (else
      ;; An assertion is a pure expression even though it may not return.
      (make-hrecord <assertion-expr>
		    tt-none #t #t '()
		    #t #f #f '()
		    #f #f
		    r-condition cond-to-print strong?)))))


(define (parse-signature-member-sexpr compiler symtbl s-member)
  (if (not (and (list? s-member) (= (length s-member) 4)))
      (begin
	;; TBD: fix this error
	(display s-member)
	(raise 'signature-syntax-error))
      (let ((s-name (car s-member))
	    (s-arg-list (cadr s-member))
	    (s-result-type (caddr s-member))
	    (s-attr (list-ref s-member 3)))
	(if (not (symbol? s-name))
	    (raise 'invalid-signature-member-name)
	    (let ((var (get-symbol symtbl s-name)))
	      (if (eq? var #f)
		  (raise 'undefined-signature-member)
		  (let* ((binder (compiler-get-binder compiler))
			 (r-arg-list
			  (map* (lambda (arg-type)
				  (translate-expr compiler symtbl #f arg-type))
				s-arg-list))
			 (r-result-type
			  (translate-expr compiler symtbl #f s-result-type))
			 (attr (parse-proc-attributes s-attr))
			 (pure-proc? (hfield-ref attr 'pure?))
			 (appl-always-returns?
			  (hfield-ref attr 'always-returns?))
			 (appl-never-returns?
			  (hfield-ref attr 'never-returns?))
			 (static-method?
			  (hfield-ref attr 'static-method?))
			 (type (translate-proc-type-expression
				binder
				r-arg-list
				r-result-type
				pure-proc?
				appl-always-returns?
				appl-never-returns?
				static-method?)))
		    (cons var type))))))))
