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


;; *** Translation 2 ***


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


;; Toplevel procedures are stored in hash table ht-procs
;; and if a procedure does not exist in ht-procs it is local.
(define gl-s-default-proc-kind 'local)


;; default translation of a list: procedure call or
;; a parametrized type instantiation

(define (xlat-default compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (is-entity? expr-head))
  (assert (and (list? expr-tail) (not (hrecord? expr-tail))))
  (check-env symtbl)
  (let* ((first-value (get-entity-value expr-head))
	 (type-expr (get-entity-type expr-head))
	 (binder (compiler-get-binder compiler))
	 (translated-expr '()))
    (set! translated-expr
	  (cond
	   ((target-object=? first-value tpc-pair)
	    (translate-pair-class compiler symtbl expr-tail))
	   ((target-object=? first-value tmt-union)
	    (translate-union compiler symtbl expr-tail))
	   ((target-object=? first-value tplt-uniform-list)
	    (translate-uniform-list compiler symtbl #f expr-tail))
	   ((target-object=? first-value tmt-procedure)
	    (translate-general-proc-type compiler symtbl expr-tail #f))
	   ((target-object=? first-value tpc-simple-proc)
	    (translate-general-proc-type compiler symtbl expr-tail #t))
	   ((target-object=? first-value tpc-param-proc)
	    (translate-param-proc-class compiler symtbl expr-tail))
	   ((target-object=? first-value tpc-vector)
	    (translate-vector compiler symtbl expr-tail))
	   ((target-object=? first-value tpc-mutable-vector)
	    (translate-mutable-vector compiler symtbl expr-tail))
	   ((target-object=? first-value tpc-value-vector)
	    (translate-value-vector compiler symtbl expr-tail))
	   ((target-object=? first-value tpc-mutable-value-vector)
	    (translate-mutable-value-vector compiler symtbl expr-tail))
	   (else '())))
    (if (null? translated-expr)
	(set! translated-expr
	      (cond
	       ((is-t-instance? binder type-expr tmc-gen-proc)
		(translate-genproc-appl compiler symtbl expr-head expr-tail))
	       ((is-t-instance? binder type-expr tpc-param-proc)
		(translate-param-proc-appl compiler symtbl expr-head
					   expr-tail))
	       ((target-type=? type-expr t-param-class)
		(translate-param-class-instance compiler symtbl expr-head
						expr-tail))
	       ((target-type=? type-expr t-param-logical-type)
		(translate-param-logical-type-instance compiler symtbl
						       expr-head
						       expr-tail))
	       ((target-type=? type-expr t-param-signature)
		(translate-param-sgn-instance compiler symtbl expr-head
					      expr-tail))
	       ;; Note that translate-simple-proc-appl is also used
	       ;; for general procedure applications.
	       ;; Note that tpc-procedure has to be checked after
	       ;; the other procedure types.
	       ((or
		 (is-t-instance? binder type-expr tpc-simple-proc)
		 (is-t-instance? binder type-expr tmt-procedure))
		(translate-simple-proc-appl compiler symtbl expr-head
					    expr-tail))
	       ((is-tc-param-proc? type-expr)
		(translate-param-proc-appl compiler symtbl expr-head
					   expr-tail))
	       (else
		
		;; TBD: fix error handling
		(display (target-object-as-string type-expr))
		(newline)
		
		(raise 'illegal-list-first-item)))))
    (if (not-null? translated-expr)
	translated-expr
	(begin
	  ;; We should never arrive here (?).
	  ;; TBD: fix the error message
	  (write-line expr-head)
	  (write-line expr-tail)
	  (raise 'could-not-parse-expression)))))


(set! xlat-default-fwd xlat-default)


(define (xlat-kw-define compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (translate-define-expression compiler symtbl toplevel? expr-tail))


(define (xlat-kw-define-variable compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (translate-define-mutable-expression compiler symtbl toplevel? expr-tail #f))


(define (xlat-kw-define-volatile compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (translate-define-mutable-expression compiler symtbl toplevel? expr-tail #t))


(define (xlat-kw-define-class compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (translate-define-class compiler symtbl expr-tail))


(define (xlat-kw-constructor compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-constructor>))
  (assert (list? expr-tail))
  (if (not (= (length expr-tail) 1))
      (raise 'syntax-error-in-constructor-expr)
      (let ((r-class (translate-expr compiler symtbl #f (car expr-tail))))
	(translate-constructor-expr compiler symtbl r-class))))


;; We allow casting an expression to <none>.
;; TBD: fix handling sexpr-default
(define (translate-cast-expression compiler symtbl sexpr-type sexpr-to-eval
				   sexpr-default type-check?)
  (let ((t-type-expr (translate-expr compiler symtbl #f sexpr-type))
	(t-value-expr (translate-expr compiler symtbl #f sexpr-to-eval))
	(t-default-expr
	 (if (null? sexpr-default)
	     empty-expression
	     (translate-expr compiler symtbl #f sexpr-default)))
	(binder (compiler-get-binder compiler)))
    (if (entity-type-is-none1? binder t-value-expr)
	(raise 'argument-with-type-none-in-cast))
    (let ((tt (if (not (is-t-type-variable? t-type-expr))
		  t-type-expr
		  '())))
      (cond
       ((and (not (hfield-ref compiler 'inside-param-def?))
	     (not (and
		   (is-known-object? tt)
		   (is-t-instance? binder tt tt-type))))
	(raise 'invalid-type-in-cast))
       ;; The following check is an optimization.
;;       ((is-t-subtype? binder (get-entity-type t-value-expr) t-type-expr)
;;	t-value-expr)
       (else
	;; The type of a cast expression shall be set exact
	;; iff the type can't be inherited.
	;; A cast expression shall be pure iff its
	;; subexpression is pure.
	(let* ((result-type
		(if (is-empty-expr? t-default-expr)
		    t-type-expr
		    (get-union-of-types0
		     binder
		     (list t-type-expr (get-entity-type t-default-expr)))))
	       (result
		(make-hrecord <cast-expression>
			      result-type
			      ;; TBD: check that t-default-expr is dispatched,
			      ;; too.
			      (entity-type-dispatched? t-value-expr)
			      (and (not-null? tt)
				   (is-final-class? binder tt))
			      '()

			      ;; TBD: check that t-default-expr is pure, too.
			      (is-pure-entity? t-value-expr)
			      #f
			      (hfield-ref compiler 'inside-param-def?)
			      '()

			      ;; TBD: check that t-default-expr returns always,
			      ;; too. No such check for never-returns?.
			      (entity-always-returns? t-value-expr)
			      (entity-never-returns? t-value-expr)

			      t-value-expr
			      t-default-expr)))
	  result))))))


(define (xlat-kw-cast compiler symtbl toplevel? expr-head expr-tail)
  (if (not (= (length expr-tail) 2))
      (raise 'syntax-error-in-cast-expression)
      (let ((type-expr (car expr-tail))
	    (value-expr (cadr expr-tail))
	    (type-check? (not (hfield-ref compiler 'inside-param-def?))))
	(translate-cast-expression compiler symtbl type-expr value-expr '()
				   type-check?))))


(define (xlat-kw-try-cast compiler symtbl toplevel? expr-head expr-tail)
  (if (not (= (length expr-tail) 3))
      (raise 'syntax-error-in-try-cast-expression)
      (let ((type-expr (car expr-tail))
	    (value-expr (cadr expr-tail))
	    (default-expr (caddr expr-tail))
	    (type-check? (not (hfield-ref compiler 'inside-param-def?))))
	(translate-cast-expression compiler symtbl type-expr value-expr
				   default-expr type-check?))))


(define (xlat-kw-static-cast compiler symtbl toplevel? expr-head expr-tail)
  (if (not (= (length expr-tail) 2))
      (raise 'syntax-error-in-static-cast-expression)
      (let* ((sexpr-type (car expr-tail))
	     (sexpr-value (cadr expr-tail))
	     (ent-type (translate-expr compiler symtbl #f sexpr-type))
	     (ent-value (translate-expr compiler symtbl #f sexpr-value))
	     (binder (compiler-get-binder compiler)))
	;; (if (entity-type-is-none1? binder ent-value)
	;;    (raise 'argument-with-type-none-in-static-cast))
	(cond
	 ((and (not (hfield-ref compiler 'inside-param-def?))
	       (or (is-t-type-variable? ent-type)
		   (not (is-known-object? ent-type))
		   (not (is-t-instance? binder ent-type tt-type))))
	  (raise 'invalid-type-in-static-cast))
	 ((and (not (hfield-ref compiler 'inside-param-def?))
	       ;; A nonreturning expression may be casted statically to
	       ;; any type.
	       (not (entity-never-returns? ent-value))
	       (not (is-t-instance? binder ent-value ent-type)))
	  (raise (list 'static-cast-type-mismatch
		       (cons 'tt-actual (get-entity-type ent-value))
		       (cons 'tt-declared ent-type))))
	 (else
	  (make-hrecord <static-cast-expression>
			ent-type
			#t
			(and (is-known-object? ent-type)
			     (is-final-class? binder ent-type))
			'()

			(is-pure-entity? ent-value)
			#f
			(hfield-ref compiler 'inside-param-def?)
			'()

			(entity-always-returns? ent-value)
			(entity-never-returns? ent-value)

			ent-value))))))

(define (translate-if-expression1 compiler symtbl
				  boolean-cond?
				  toplevel? expr-head expr-tail)
  (let ((argc (length expr-tail)))
    (if (or (= argc 2) (= argc 3))
	(let* ((t-condition (translate-expr compiler symtbl #f (car expr-tail)))
	       (t-expr-true
		(begin
		  (dwl4 (cadr expr-tail))
		  (translate-expr compiler symtbl #f (cadr expr-tail))))
	       (t-expr-false
		(if (= argc 3)
		    (translate-expr compiler symtbl #f (caddr expr-tail))
		    empty-expression))
	       (binder (compiler-get-binder compiler)))
	  (translate-if-expression binder
				   t-condition t-expr-true t-expr-false
				   boolean-cond?
				   (not (hfield-ref compiler
						    'inside-param-def?))))
	(raise 'invalid-if))))


(define (xlat-kw-if compiler symtbl toplevel? expr-head expr-tail)
  (translate-if-expression1 compiler symtbl #t toplevel? expr-head expr-tail))


(define (xlat-kw-if-object compiler symtbl toplevel? expr-head expr-tail)
  (translate-if-expression1 compiler symtbl #f toplevel? expr-head expr-tail))


(define (xlat-kw-begin compiler symtbl toplevel? expr-head expr-tail)
  ;; Maybe we could allow empty begins.
  (if (< (length expr-tail) 1)
      (raise 'empty-begin)
      (if (not toplevel?)
	  (let ((subexprs
		 (map
		  (lambda (expr) (translate-expr compiler symtbl #f expr))
		  expr-tail)))
	    (make-compound-expression subexprs))
	  ;; Toplevel expressions may be grouped with begin.
	  (map
	   (lambda (expr) (translate-expr compiler symtbl #t expr))
	   expr-tail))))	  


(define (xlat-kw-procedure compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  (let* ((named? (symbol? (car expr-tail)))
	 (s-name0 (if named? (car expr-tail) '()))
	 (s-header (if named? (cadr expr-tail) (car expr-tail)))
	 (s-body (if named? (cddr expr-tail) (cdr expr-tail))))
    (if (and (list? s-header) (= (length s-header) 3))
	(if (and (list? s-body) (>= (length s-body) 1))
	    (let* ((s-arglist (car s-header))
		   (s-result-type (cadr s-header))
		   (s-attributes (caddr s-header))
		   (l-prop (hashq-ref (hfield-ref compiler 'ht-procs)
				      expr-tail))
		   (s-kind (if l-prop (car l-prop) gl-s-default-proc-kind))
		   (s-name
		    (cond
		     (named? s-name0)
		     (l-prop (cadr l-prop))
		     (else '()))))
	      (translate-procedure-expression compiler symtbl
					      s-arglist s-result-type
					      s-attributes s-body
					      s-kind s-name))
	    (raise 'invalid-lambda-body))
	(raise 'invalid-lambda-header))))


;; TBD: change lambda to aut-lambda in exceptions in the following procedure.
(define (xlat-kw-procedure-aut compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (list? expr-tail))
  (let* ((named? (symbol? (car expr-tail)))
	 (s-name0 (if named? (car expr-tail) '()))
	 (s-header (if named? (cadr expr-tail) (car expr-tail)))
	 (s-body (if named? (cddr expr-tail) (cdr expr-tail))))
    ;; lambda-automatic header contains no result type.
    (if (and (list? s-header) (= (length s-header) 2))
	(if (and (list? s-body) (>= (length s-body) 1))
	    (let* ((s-arglist (car s-header))
		   (s-attributes (cadr s-header))
		   (l-prop (hashq-ref (hfield-ref compiler 'ht-procs)
				      expr-tail))
		   (s-kind (if l-prop (car l-prop) gl-s-default-proc-kind))
		   (s-name
		    (cond
		     (named? s-name0)
		     (l-prop (cadr l-prop))
		     (else '()))))
	      (translate-procedure-expression-aut compiler symtbl
						  s-arglist
						  s-attributes s-body
						  s-kind s-name))
	    (raise 'invalid-lambda-body))
	(raise 'invalid-lambda-header))))


(define (xlat-kw-define-gen-proc compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (cond
   ((not (list? expr-tail))
    (raise 'invalid-expression))
   ((not (= (length expr-tail) 1))
    (raise 'too-many-arguments-in-gen-proc-def))
   (else
    (let ((name (car expr-tail)))
      (if (not (symbol? name))
	  (raise 'invalid-gen-proc-name)
	  (let ((t-gen-proc (get-symbol symtbl name))
		(binder (compiler-get-binder compiler)))
	    (cond
	     ;; TBD: change eqv? to eq?.
	     ((eqv? t-gen-proc #f)
	      (car (translate-define-gen-proc compiler symtbl name)))
	     ((not (is-t-instance?
		    binder
		    (get-entity-type t-gen-proc)
		    tmc-gen-proc))
	      (raise 'duplicate-definition))
	     (else empty-expression))))))))


(define (declare-method compiler r-gen-proc r-method-type static?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (is-target-object? r-gen-proc))
  ;; TBD: Do we need strong-assert here?
  (assert (or (is-tc-simple-proc? r-method-type)
	      (is-tc-param-proc? r-method-type)))
  (let* ((binder (compiler-get-binder compiler))
	 (decl (generic-find-decl binder
				  r-gen-proc r-method-type)))
    (cond
     ((and (not-null? decl) (not (eq? static? (cdr decl))))
      (raise (list 'static-attribute-mismatch
		   (cons 'to-gen-proc r-gen-proc))))
     ((not-null? decl)
      (if (check-if-equal-types? binder '() r-method-type
				 (get-entity-type (car decl)))
	  '()
	  (raise 'internal-error-with-methods)))
     ((not (check-covariant-typing-for-method-type?
	    binder r-gen-proc r-method-type))
      (raise (list 'noncovariant-method-declaration
		   r-gen-proc r-method-type)))
     (else
      ;; A method declaration uses a toplevel variable.
      (let* ((s-name (hfield-ref (hfield-ref r-gen-proc 'address)
				 'source-name))
	     (address (compiler-alloc-loc compiler '() #t))
	     (to (get-method-declaration address
					 r-method-type)))
	(add-new-method-to-generic! binder
				    r-gen-proc to static?)
	(add-method-decl! compiler r-gen-proc to)
	to)))))


(define (declare-method2 compiler symtbl toplevel? expr-head expr-tail
			 static?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (list? expr-tail))
  (assert (boolean? static?))
  (check-toplevel toplevel?)
  (if (not (= (length expr-tail) 2))
      (raise 'declare-method-syntax-error)
      (let ((s-gen-proc (car expr-tail))
	    (s-method-type (cadr expr-tail)))
	(if (not (symbol? s-gen-proc))
	    (raise 'declare-method:invalid-generic-procedure)
	    (let* ((t-gen-proc0 (get-symbol symtbl s-gen-proc))
		   (p-gen-proc
		    (cond
		     ((eq? t-gen-proc0 #f)
		      (translate-define-gen-proc compiler symtbl s-gen-proc))
		     ((and (is-entity? t-gen-proc0)
			   (is-t-gen-proc? t-gen-proc0))
		      (cons '() t-gen-proc0))
		     (else
		      (raise 'declare-method:invalid-generic-procedure))))
		   (expr-gen-proc (car p-gen-proc))
		   (t-gen-proc (cdr p-gen-proc))
		   (expr-type (get-entity-type t-gen-proc))
		   (binder (compiler-get-binder compiler)))
	      (cond
	       ;; The following test is probably unnecessary.
	       ((not (is-t-instance?
		      binder
		      expr-type
		      tmc-gen-proc))
		(raise 'not-a-generic-procedure))
	       (else
		(let ((t-method-type
		       (translate-expr compiler symtbl #f s-method-type)))
		  (if (or (is-tc-simple-proc? t-method-type)
			  (is-tc-param-proc? t-method-type))
		      (let* ((to (declare-method compiler
						 t-gen-proc t-method-type
						 static?))
			     (method-repr
			      (if (not-null? to)
				  (get-method-declaration-repr
				   t-gen-proc
				   to
				   static?)
				  empty-expression)))
			(if (null? expr-gen-proc)
			    method-repr
			    (list expr-gen-proc
				  method-repr)))
		      (raise 'invalid-method-type))))))))))


(define (xlat-kw-declare-method compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-declare-method>))
  (declare-method2 compiler symtbl toplevel? expr-head expr-tail #f))


(define (xlat-kw-declare-static-method compiler symtbl toplevel? expr-head
				       expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-declare-static-method>))
  (declare-method2 compiler symtbl toplevel? expr-head expr-tail #t))


(define (do-add-method compiler expr-gen-proc t-gen-proc t-method s-name
		       static?)
  (let* ((binder (compiler-get-binder compiler))
	 (method-type (get-entity-type t-method))
	 (decl (generic-find-decl binder
				  t-gen-proc method-type))
	 (old-address (if (not-null? decl)
			  (hfield-ref (car decl) 'address)
			  '())))
    (if (and (not-null? decl) (not (eq? (cdr decl) static?)))
	(raise (list 'static-attribute-mismatch
		     (cons 'to-gen-proc t-gen-proc))))
    ;; When we define a declared method the covariance rule
    ;; has already been checked for the declaration.
    ;; It does not need to be done again.
    (if (and (null? decl)
	     (not (check-covariant-typing?
		   binder t-gen-proc t-method)))
	(begin
	  (dvar1-set! binder)
	  (dvar2-set! t-gen-proc)
	  (dvar3-set! t-method)
	  (raise (list 'noncovariant-method-definition
		       t-gen-proc (get-entity-type t-method)))))
    (if (or (not (is-target-object? t-method))
	    (null? (hfield-ref t-method 'address)))
	(begin
	  (let* ((var-def (get-method-definition-var-def
			   compiler t-method s-name))
		 (to-new1 (make-object-with-address
			   (get-entity-value t-method)
			   (hfield-ref (hfield-ref var-def 'variable)
				       'address)))
		 (to-new2
		  (add-method-to-generic2!
		   binder t-gen-proc decl to-new1 static?))
		 (declared? (not (eq? to-new1 to-new2))))
	    (if declared? (mark-method-decl! compiler t-gen-proc (car decl)))
	    ;; In case the method is declared
	    ;; add-method-to-generic! returns the
	    ;; declaration.
	    (let ((method-repr
		   (get-method-definition-repr
		    t-gen-proc
		    to-new1
		    static?
		    declared?
		    old-address)))
	      (if (null? expr-gen-proc)
		  (list var-def method-repr)
		  (list expr-gen-proc var-def
			method-repr)))))
	(begin
	  (let* ((to-new
		  (add-method-to-generic2! binder
					   t-gen-proc decl t-method static?))
		 (declared? (not (eq? to-new t-method))))
	    (if declared? (mark-method-decl! compiler t-gen-proc (car decl)))
	    (let ((method-repr (get-method-definition-repr
				t-gen-proc t-method static?
				declared?
				old-address)))
	      (if (null? expr-gen-proc)
		  method-repr
		  (list expr-gen-proc method-repr))))))))


(define (do-add-method2 compiler symtbl toplevel? expr-head expr-tail
			static?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (list? expr-tail))
  (assert (boolean? static?))
  (check-toplevel toplevel?)
  (if (not (= (length expr-tail) 2))
      (raise 'add-method-syntax-error)
      (let ((s-gen-proc (car expr-tail))
	    (s-method (cadr expr-tail)))
	(let* ((t-gen-proc0
		(if (symbol? s-gen-proc) (get-symbol symtbl s-gen-proc) #f))
	       (l-data
		(cond
		 ((not (eq? t-gen-proc0 #f)) (list t-gen-proc0 '()))
		 ((symbol? s-gen-proc)
		  (let ((p-gen-proc (translate-define-gen-proc
				     compiler symtbl s-gen-proc)))
		    ;; (list (hfield-ref (hfield-ref repr-gen-proc 'variable)
		    ;; 		      'value)
		    ;; 	  repr-gen-proc)))
		    (list (cdr p-gen-proc)
			  (car p-gen-proc))))
		 (else
		  (let ((t-gen-proc1
			 (translate-expr compiler symtbl #f s-gen-proc)))
		    (list t-gen-proc1 '())))))
	       (t-gen-proc (car l-data))
	       (expr-gen-proc (cadr l-data))
	       (binder (compiler-get-binder compiler))
	       (result
		(begin
		  (cond
		   ;; The following test is probably unnecessary.
		   ((not (is-t-instance?
			  binder
			  (get-entity-type t-gen-proc)
			  tmc-gen-proc))
		    (raise 'not-a-generic-procedure))
		   (else
		    (if (symbol? s-gen-proc)
			(set-proc-expr compiler s-method 'toplevel s-gen-proc))
		    (let* ((t-method
			    (translate-expr compiler symtbl #f s-method))
			   (to-type (get-entity-type t-method)))
		      (if (symbol? s-gen-proc)
			  (unset-proc-expr compiler s-method))
		      (if (or (is-tc-simple-proc? to-type)
			      (is-tc-param-proc? to-type))
			  (begin
			    (do-add-method compiler expr-gen-proc t-gen-proc
					   t-method
					   (if (symbol? s-gen-proc) s-gen-proc
					       '())
					   static?))
			  (begin
			    (dvar1-set! t-method)
			    (raise 'invalid-method)))))))))
	  result))))


(define (xlat-kw-add-method compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-add-method>))
  (do-add-method2 compiler symtbl toplevel? expr-head expr-tail #f))


(define (xlat-kw-add-static-method compiler symtbl toplevel?
				   expr-head expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-add-static-method>))
  (do-add-method2 compiler symtbl toplevel? expr-head expr-tail #t))


(define (do-xlat-kw-generic-proc-dispatch compiler symtbl toplevel?
					  expr-head expr-tail
					  with-result?)
  (let ((i-len (length expr-tail)))
    (if (or (= i-len 3) (= i-len 2))
	(let ((e-generic-proc (car expr-tail))
	      (e-arg-types (cadr expr-tail))
	      (e-attr (if (= i-len 3) (caddr expr-tail) '())))
	  (let ((r-generic-proc
		 (translate-expr compiler symtbl #f e-generic-proc))
		(r-arg-types
		 (map*
		  (lambda (e-type)
		    (translate-expr compiler symtbl #f e-type))
		  e-arg-types))
		(attr (parse-proc-attributes e-attr))
		(binder (compiler-get-binder compiler)))
	    (translate-generic-proc-dispatch
	     binder r-generic-proc r-arg-types
	     with-result?
	     (hfield-ref attr 'pure?)
	     (hfield-ref attr 'always-returns?)
	     (hfield-ref attr 'never-returns?)
	     (not (hfield-ref compiler 'inside-param-def?)))))
	(raise 'generic-proc-dispatch:invalid-number-of-arguments))))


(define (xlat-kw-generic-proc-dispatch compiler symtbl toplevel?
				       expr-head expr-tail)
  (do-xlat-kw-generic-proc-dispatch compiler symtbl toplevel?
				    expr-head expr-tail
				    #t))


(define (xlat-kw-generic-proc-dispatch-without-result
	 compiler symtbl toplevel?
	 expr-head expr-tail)
  (do-xlat-kw-generic-proc-dispatch compiler symtbl toplevel?
				    expr-head expr-tail
				    #f))


(define (xlat-kw-quote compiler symtbl toplevel? expr-head expr-tail)
  (strong-assert (= (length expr-tail) 1))
  (translate-quoted-expression (car expr-tail)))


(define (xlat-kw-let compiler symtbl toplevel? expr-head expr-tail)
  (translate-let-expression compiler symtbl expr-tail #t #f))


(define (xlat-kw-let-variables compiler symtbl toplevel? expr-head expr-tail)
  (translate-let-expression compiler symtbl expr-tail #f #f))


(define (xlat-kw-let-volatile compiler symtbl toplevel? expr-head expr-tail)
  (translate-let-expression compiler symtbl expr-tail #f #t))


(define (xlat-kw-letrec compiler symtbl toplevel? expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #t #f #f))


(define (xlat-kw-letrec-variables compiler symtbl toplevel?
				  expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #f #f #f))


(define (xlat-kw-letrec-volatile compiler symtbl toplevel?
				 expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #f #t #f))


(define (xlat-kw-letrec* compiler symtbl toplevel? expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #t #f #t))


(define (xlat-kw-letrec*-variables compiler symtbl toplevel? expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #f #f #t))


(define (xlat-kw-letrec*-volatile compiler symtbl toplevel? expr-head expr-tail)
  (translate-letrec-expression compiler symtbl expr-tail #f #t #t))


(define (xlat-kw-set compiler symtbl toplevel? expr-head expr-tail)
  (translate-set-expression compiler symtbl toplevel? #f expr-tail))


(define (xlat-kw-until compiler symtbl toplevel? expr-head expr-tail)
  (let ((n-len (length expr-tail)))
    (if (< n-len 1)
	(raise 'syntax-error-in-until)
	(let* ((header (car expr-tail))
	       (header-len (length header)))
	  (if (or
	       (= header-len 1)
	       (= header-len 2))
	      (let ((condition (car header))
		    (body (drop expr-tail 1))
		    (translate (lambda (expr)
				 (translate-expr compiler symtbl #f expr))))
		;; TBD: change this to strong-assert.
		(assert (not-null? condition))
		(let ((t-condition (translate condition))
		      (t-result
		       (if (= header-len 2)
			   (translate (cadr header))
			   empty-expression))
		      (t-body
		       (if (not-null? body)
			   (wrap-compound-expression
			    compiler
			    symtbl
			    body)
			   empty-expression)))
		  (if (or (hfield-ref compiler 'inside-param-def?)
			  (target-type=? (get-entity-type t-condition)
					 tc-boolean))
		      (let ((t-type (get-entity-type t-result))
			    ;; TBD: Should we check only t-result here? 
			    (type-dispatched?
			     (and
			      (entity-type-dispatched? t-condition)
			      (entity-type-dispatched? t-result)
			      (entity-type-dispatched? t-body)))
			    (always-returns?
			     (and
			      (entity-always-returns? t-condition)
			      (entity-always-returns? t-result)
			      (entity-always-returns? t-body)))
			    ;; It is possible that the body is not evaluated
			    ;; at all. So we don't check it in the following.
			    (never-returns?
			     (or (entity-never-returns? t-condition)
				 (entity-never-returns? t-result)))
			    (exact-type? (hfield-ref t-result 'exact-type?))
			    (pure?
			     (and
			      (is-pure-entity? t-condition)
			      (is-pure-entity? t-result)
			      (is-pure-entity? t-body))))
			(make-hrecord <until-form>
				      t-type
				      type-dispatched?
				      exact-type?
				      '()
				      pure?
				      #f
				      (hfield-ref compiler 'inside-param-def?)
				      ;; The following expression has been
				      ;; fixed.
				      (get-entity-value t-result)
				      always-returns?
				      never-returns?
				      t-condition
				      t-result
				      t-body))
		      (raise 'invalid-until-condition))))
	      (raise 'syntax-error-in-until-header))))))


(define (xlat-kw-declare compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-declare>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 2)))
  (check-toplevel toplevel?)
  (let* ((var-name (car expr-tail))
	 (e-type (cadr expr-tail))
	 (r-type (translate-expr compiler symtbl #f e-type)))
    (translate-forward-declaration compiler symtbl var-name r-type #t #f)))


(define (xlat-kw-declare-mutable compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-declare-mutable>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 2)))
  (check-toplevel toplevel?)
  (let* ((var-name (car expr-tail))
	 (e-type (cadr expr-tail))
	 (r-type (translate-expr compiler symtbl #f e-type)))
    (translate-forward-declaration compiler symtbl var-name r-type #f #f)))


(define (xlat-kw-declare-volatile compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-declare-volatile>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 2)))
  (check-toplevel toplevel?)
  (let* ((var-name (car expr-tail))
	 (e-type (cadr expr-tail))
	 (r-type (translate-expr compiler symtbl #f e-type)))
    (translate-forward-declaration compiler symtbl var-name r-type #f #t)))


(define (xlat-kw-prim-proc compiler symtbl toplevel? expr-head expr-tail)
  (translate-primitive-procedure compiler symtbl expr-tail #t))


(define (xlat-kw-unchecked-prim-proc compiler symtbl toplevel?
				     expr-head expr-tail)
  (translate-primitive-procedure compiler symtbl expr-tail #f))


(define (xlat-kw-param-prim-proc compiler symtbl toplevel? expr-head expr-tail)
  (translate-param-prim-proc compiler symtbl expr-tail #t))


(define (xlat-kw-unchecked-param-prim-proc compiler symtbl toplevel?
					   expr-head expr-tail)
  (translate-param-prim-proc compiler symtbl expr-tail #f))


(define (translate-param-field compiler env s-field)
  (if (pair? s-field)
      (let ((len (length s-field)))
	(if (or (= len 4) (= len 5))
	    (let* ((field-name 
		    (list-ref s-field i-field-name))
		   (r-field-type
		    (translate-expr compiler env #f 
				    (list-ref s-field i-field-type)))
		   (read-access (list-ref s-field i-field-read-access))
		   (write-access (list-ref s-field i-field-write-access))
		   (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))
			'())))
	      (if (eq? r-field-type tt-none)
		  (raise (list 'field-type-none1
			       (cons 's-field-name field-name))))
	      (make-field field-name r-field-type read-access write-access
			  has-init-value? r-init-value))
	    (raise 'invalid-field-spec-length)))
      (raise 'invalid-field-spec)))


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


(define (make-zero-tvars compiler n)
  (if (<= n 0)
      '()
      ;; Type variables arfe always lexical.
      (cons (make-type-variable (compiler-alloc-loc compiler 'z #f))
	    (make-zero-tvars compiler (- n 1)))))


(define (do-translate-param-class-def compiler symtbl s-name type-variables
				      s-superclass
				      inheritable? immutable? eq-by-value?
				      ctr-access
				      s-zero-proc
				      s-field-list)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (symbol? s-name))
  (assert (and (list? type-variables)
	       (and-map? (lambda (tvar)
			   (and (symbol? (car tvar))
				(is-t-type-variable? (cdr tvar))))
			 type-variables)))
  (assert (boolean? inheritable?))
  (assert (boolean? immutable?))
  (assert (boolean? eq-by-value?))
  (assert (memq ctr-access gl-access-specifiers))
  (assert (list? s-field-list))
  (hfield-set! compiler 'inside-param-def? #t)
  (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
					     t-param-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* ((local-env (make-environment
		       symtbl type-variables))
	   (t-superclass (translate-expr compiler local-env #f s-superclass))
	   (t-field-list (translate-param-field-list compiler s-field-list
						     local-env))
	   (t-type-variables (map cdr type-variables)))
      (cond
       ((not (is-known-object? t-superclass))
	(raise 'invalid-superclass))
       ((hfield-ref t-superclass 'incomplete?)
	(raise 'forward-declared-superclass))
       ((tno-field-ref t-superclass 'goops?)
	(raise 'illegal-goops-superclass))
       (else
	(let* ((address (hfield-ref to-decl 'address))
	       (tpc (make-parametrized-class-object
		     (compiler-get-binder compiler)
		     (get-current-module-name compiler)
		     (symbol->string s-name)
		     address
		     t-type-variables
		     t-superclass
		     t-field-list
		     inheritable? immutable? eq-by-value?
		     ctr-access))
	       (var
		(bind-object! compiler symtbl s-name to-decl tpc t-param-class))
	       (class-def
		(make-hrecord <param-class-definition>
			      tt-none
			      #t
			      #t
			      '()

			      #f
			      #f
			      #f
			      '()

			      var
			      t-param-class
			      '()
			      #t #f #f
			      t-type-variables)))
	  (if (not (is-null-sexpr? s-zero-proc))
	      (let* ((binder (compiler-get-binder compiler))
		     (zero-proc-body
		      (translate-expr compiler local-env #f s-zero-proc))
		     (nr-of-tvars (length type-variables))
		     (zero-tvars (make-zero-tvars compiler nr-of-tvars))
		     (bindings (map cons t-type-variables zero-tvars))
		     (final-zero-body 
		      (rebind-local-variables binder zero-proc-body bindings))
		     (result-type
		      (translate-param-class-instance-expr
		       binder tpc zero-tvars #t #t))
		     (zero-proc-inst-type
		      (translate-simple-proc-class-expression
		       binder
		       '()
		       result-type #t #t #f #f))
		     (zero-proc-class
		      (make-param-proc-class-object
		       "instance of :param-proc"
		       zero-tvars
		       zero-proc-inst-type))
		     (zero-proc0
		      (make-hrecord
		       <procedure-expression>
		       zero-proc-inst-type
		       #t
		       #t
		       '()

		       #t
		       #t
		       #f
		       '()

		       '()
		       '()
		       '()
		       result-type
		       final-zero-body
		       'zero
		       '()
		       '()
		       #t
		       #f
		       #t
		       #f
		       #f))
		     (to-zero-proc
		      (make-param-proc-object
		       '()
		       zero-proc-class
		       '()
		       '()))
		     (zero-proc (make-param-proc2 zero-tvars
						  zero-proc-class zero-proc0
						  'zero '()
						  to-zero-proc))
		     (zero-setting
		      (make-hrecord <zero-setting-expr>
				    zero-proc-class
				    #t #t '()
				    #f #f #f '()
				    var zero-proc #t)))
		(hfield-set! compiler 'inside-param-def? #f)
		(list decl class-def zero-setting))
	      (begin
		(hfield-set! compiler 'inside-param-def? #f)
		(list decl class-def)))))))))


(define (xlat-kw-def-param-class compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-def-param-class>))
  (assert (list? expr-tail))
  (check-env symtbl)
  (check-toplevel toplevel?)
  (let ((s-name (car expr-tail))
	(s-type-vars (cadr expr-tail))
	(s-class-expr (drop expr-tail 2)))
    (let ((s-superclass (car s-class-expr))
	  (inheritable? (cadr s-class-expr))
	  (immutable? (caddr s-class-expr))
	  (eq-by-value? (list-ref s-class-expr 3))
	  (ctr-access (list-ref s-class-expr 4))
	  (s-zero-proc (list-ref s-class-expr 5))
	  ;;	  (s-zero-proc '())
	  (s-field-list (list-ref s-class-expr 6)))
      (if (or (not (boolean? inheritable?))
	      (not (boolean? immutable?))
	      (not (boolean? eq-by-value?))
	      (not (memq ctr-access gl-access-specifiers)))
	  (raise 'param-class-syntax-error)
	  (begin
	    (let ((r-type-vars (make-type-vars compiler s-type-vars)))
	      (do-translate-param-class-def compiler symtbl s-name
					    r-type-vars
					    s-superclass
					    inheritable?
					    immutable?
					    eq-by-value?
					    ctr-access
					    s-zero-proc
					    s-field-list)))))))


(define (do-translate-param-logical-type-def compiler symtbl s-name
					     type-variables
					     s-value-expr)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (symbol? s-name))
  (assert (and (list? type-variables)
	       (and-map? (lambda (tvar)
			   (and (symbol? (car tvar))
				(is-t-type-variable? (cdr tvar))))
			 type-variables)))
  (strong-assert (list? s-value-expr))
  (hfield-set! compiler 'inside-param-def? #t)
  (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
					     t-param-logical-type #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* ((local-env (make-environment
		       symtbl type-variables))
	   (t-value-expr (translate-expr compiler local-env #f s-value-expr))
	   (t-type-variables (map cdr type-variables)))
      (let* ((tplt (make-param-logical-type-object
		    (symbol->string s-name)
		    '()
		    t-type-variables
		    t-value-expr))
	     (var
	      (bind-object! compiler symtbl s-name
			    to-decl tplt t-param-logical-type)))
	(hfield-set! compiler 'inside-param-def? #f)
	(let ((ltype-def
	       (make-hrecord <param-logical-type-def>
			     tt-none
			     #t
			     #t
			     '()

			     #f
			     #f
			     #f
			     '()

			     var
			     t-param-logical-type
			     t-value-expr
			     #t #f #f
			     t-type-variables)))
	  (list decl ltype-def))))))


(define (xlat-kw-def-param-logical-type compiler symtbl toplevel?
					expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-def-param-logical-type>))
  (assert (list? expr-tail))
  (check-toplevel toplevel?)
  (check-env symtbl)
  (if (not (= (length expr-tail) 3))
      (raise 'define-param-logical-type-syntax-error)
      (let ((s-name (car expr-tail))
	    (s-type-vars (cadr expr-tail))
	    (s-value-expr (caddr expr-tail)))
	(let* ((r-type-vars (make-type-vars compiler s-type-vars))
	       (result
		(do-translate-param-logical-type-def compiler symtbl s-name
						     r-type-vars
						     s-value-expr)))
	  result))))


(define (xlat-kw-def-param-proc-alt compiler symtbl toplevel?
				    expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-def-param-proc-alt>))
  (assert (list? expr-tail))
  (check-toplevel toplevel?)
  (if (not (= (length expr-tail) 3))
      ;; TBD: change the following exception name
      (raise 'def-param-proc-syntax-error)
      (let ((s-name (car expr-tail))
	    (s-typevars (cadr expr-tail))
	    (s-proc (caddr expr-tail))
	    ;; Do we need the following?
	    ;; Parametrized definitions should be in top level.
	    (inside-param-def-old?
	     (hfield-ref compiler 'inside-param-def?)))
	(let* ((bound-value (get-symbol symtbl s-name))
	       (rebind? (check-existing-binding? compiler bound-value))
	       (type-params (make-type-vars compiler s-typevars))
	       (r-type-params (map cdr type-params))
	       (old-fixed-tvars (compiler-get-fixed-tvars compiler)))
	  (hfield-set! compiler 'inside-param-def? #t)
	  (compiler-set-fixed-tvars! compiler
				     (append old-fixed-tvars r-type-params))
	  (if rebind?
	      (let* ((type (get-entity-type bound-value))
		     (to-old (get-entity-value bound-value))
		     (address (hfield-ref bound-value 'address))
		     (local-env (make-environment symtbl type-params))
		     (r-proc0 (translate-expr compiler local-env #f s-proc))
		     (inst-type (get-entity-type r-proc0))
		     (to-param-proc-class
		      (make-param-proc-class-object
		       "instance of :param-proc"
		       r-type-params
		       inst-type))
		     (to-new (make-param-proc-object
			      s-name
			      to-param-proc-class
			      r-proc0
			      address))
		     (var (make-object-var to-new))
		     (r-proc (make-param-proc2 r-type-params
					       to-param-proc-class
					       r-proc0 'toplevel '() to-new)))
		(set-object1! to-old to-new)
		(compiler-set-fixed-tvars! compiler old-fixed-tvars)
		(hfield-set! compiler 'inside-param-def?
			     inside-param-def-old?)
		(make-normal-var-def
		 to-param-proc-class
		 var
		 r-proc
		 #t))
	      (let* ((binder (compiler-get-binder compiler))
		     (address (compiler-alloc-loc compiler s-name #t))
		     (to-decl
		      (make-target-object
		       tc-object #t #f address
		       #f #t #f '())))
		(add-symbol! symtbl s-name to-decl)
		(let* ((local-env (make-environment symtbl type-params))
		       (r-proc0 (translate-expr compiler local-env #f s-proc))
		       (inst-type (get-entity-type r-proc0))
		       (to-param-proc-class
			(make-param-proc-class-object
			 "instance of :param-proc"
			 r-type-params
			 inst-type))
		       (to-new (make-param-proc-object
				s-name
				to-param-proc-class
				r-proc0
				address))
		       (r-proc (make-param-proc2 r-type-params
						 to-param-proc-class
						 r-proc0 'toplevel '()
						 to-new)))
		  (set-object1! to-decl to-new)
		  (let ((var (make-object-var to-decl)))
		    (compiler-set-fixed-tvars! compiler old-fixed-tvars)
		    (hfield-set! compiler 'inside-param-def?
				 inside-param-def-old?)
		    (list
		     (make-hrecord <forward-declaration>
				   tt-none
				   #t
				   #t
				   '()
				   
				   ;; pure? has probably no effect here
				   #t
				   #f
				   #f
				   '()
				   
				   var
				   to-param-proc-class
				   #f
				   #f)
		     (make-normal-var-def
		      to-param-proc-class
		      var
		      r-proc
		      #t))))))))))


(define (xlat-kw-param-proc compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-param-proc>))
  (assert (list? expr-tail))
  (if (not (>= (length expr-tail) 3))
      (raise 'param-proc-syntax-error)
      (let* ((named? (symbol? (car expr-tail)))
	     (s-name0 (if named? (car expr-tail) '()))
	     (l-rest (if named? (cdr expr-tail) expr-tail)))
	(if (not (>= (length l-rest) 3))
	    (raise 'param-proc-syntax-error)
	    (let* ((s-typevars (list-ref l-rest 0))
		   (s-header (list-ref l-rest 1))
		   (s-body (drop l-rest 2))
		   (l-prop (hashq-ref (hfield-ref compiler 'ht-procs)
				      expr-tail))
		   (s-kind (if l-prop (car l-prop) gl-s-default-proc-kind))
		   (s-name
		    (cond
		     (named? s-name0)
		     (l-prop (cadr l-prop))
		     (else '()))))
	      (if (not (= (length s-header) 3))
		  (raise 'param-proc-invalid-header)
		  (let ((s-arglist (list-ref s-header 0))
			(s-result-type (list-ref s-header 1))
			(s-attr (list-ref s-header 2)))
		    (let* ((type-params (make-type-vars compiler s-typevars))
			   (local-env (make-environment symtbl type-params)))
		      (translate-param-proc-expr compiler local-env
						 type-params
						 s-arglist s-result-type
						 s-body
						 s-attr s-kind s-name #f)
		      ))))))))


(define (xlat-kw-param-proc-aut compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-param-proc-aut>))
  (assert (list? expr-tail))
  (if (not (>= (length expr-tail) 3))
      (raise 'param-proc-aut-syntax-error)
      (let* ((named? (symbol? (car expr-tail)))
	     (s-name0 (if named? (car expr-tail) '()))
	     (l-rest (if named? (cdr expr-tail) expr-tail)))
	(if (not (>= (length l-rest) 3))
	    (raise 'param-proc-aut-syntax-error)
	    (let* ((s-typevars (list-ref l-rest 0))
		   (s-header (list-ref l-rest 1))
		   (s-body (drop l-rest 2))
		   (l-prop (hashq-ref (hfield-ref compiler 'ht-procs)
				      expr-tail))
		   (s-kind (if l-prop (car l-prop) gl-s-default-proc-kind))
		   (s-name
		    (cond
		     (named? s-name0)
		     (l-prop (cadr l-prop))
		     (else '()))))
	      (if (not (= (length s-header) 2))
		  (raise 'param-proc-aut-invalid-header)
		  (let ((s-arglist (list-ref s-header 0))
			(s-attr (list-ref s-header 1)))
		    (let* ((type-params (make-type-vars compiler
							s-typevars))
			   (local-env (make-environment symtbl
							type-params)))
		      (translate-param-proc-expr compiler local-env
						 type-params
						 s-arglist '() s-body
						 s-attr s-kind s-name #t)
		      ))))))))


(define (xlat-kw-param-proc-instance compiler symtbl toplevel?
				     expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-param-proc-instance>))
  (assert (list? expr-tail))
  (if (not (>= (length expr-tail) 1))
      (raise 'param-proc-instance-syntax-error)
      (let ((s-param-proc (car expr-tail))
	    (s-type-var-values (cdr expr-tail)))
	(let ((r-param-proc (translate-expr compiler symtbl #f s-param-proc))
	      (r-type-var-values
	       (map (lambda (s-val)
		      (translate-expr compiler symtbl #f s-val))
		    s-type-var-values)))
	  (translate-param-proc-instance
	   (compiler-get-binder compiler)
	   r-param-proc r-type-var-values
	   (not (hfield-ref compiler 'inside-param-def?)))))))


(define (xlat-kw-param-proc-dispatch compiler symtbl toplevel?
				     expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-param-proc-dispatch>))
  (assert (list? expr-tail))
  (if (not (>= (length expr-tail) 1))
      (raise 'param-proc-dispatch-syntax-error)
      (let ((s-param-proc (car expr-tail))
	    (s-argument-types (cdr expr-tail)))
	(let ((r-param-proc (translate-expr compiler symtbl #f s-param-proc))
	      (r-argument-types
	       (map (lambda (s-val)
		      (translate-expr compiler symtbl #f s-val))
		    s-argument-types)))
	  (translate-param-proc-dispatch
	   (compiler-get-binder compiler)
	   r-param-proc r-argument-types
	   (not (hfield-ref compiler 'inside-param-def?)))))))


(define (xlat-kw-param-proc-cond-appl compiler symtbl toplevel?
				      expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (hrecord-is-instance? expr-head <keyword-param-proc-cond-appl>))
  (assert (list? expr-tail))
  (if (and (not-null? expr-tail)
	   (list? expr-tail)
	   (>= (length expr-tail) 2)
	   (not-null? (cadr expr-tail))
	   (list? (cadr expr-tail)))
      (let ((comp (lambda (expr)
		    (translate-expr compiler symtbl #f expr)))
	    (binder (compiler-get-binder compiler)))
	(let* ((proc (comp (car expr-tail)))
	       (tt-proc (get-entity-type proc))
	       (l-sexpr-default-params (cadr expr-tail)))
	  (cond
	   ((not (is-t-instance? binder tt-proc tpc-param-proc))
	    (raise (list 'param-proc-cond-appl:invalid-proc expr-tail)))
	   ((not (= (tno-field-ref tt-proc 'i-nr-of-tvars)
		    (length l-sexpr-default-params)))
	    (raise (list 'param-proc-cond-appl:invalid-number-of-params
			 expr-tail)))
	   (else
	    (let ((l-default-params (map comp l-sexpr-default-params))
		  (arglist (map* comp (drop expr-tail 2))))
	      (let ((result
		     (do-translate-param-proc-appl
		      (compiler-get-binder compiler)
		      (hfield-ref compiler 'inside-param-def?)
		      proc arglist l-default-params)))
		result))))))
      (raise (list 'param-proc-cond-appl:syntax-error expr-tail))))


(define (xlat-kw-rest compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-rest>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 1)))
  (let* ((s-type (car expr-tail))
	 (r-type (translate-expr compiler symtbl #f s-type)))
    (make-rest-object r-type)))


(define (xlat-kw-splice compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-splice>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 1)))
  (let* ((s-type (car expr-tail))
	 (r-type (translate-expr compiler symtbl #f s-type)))
    (make-splice-object r-type)))


(define (xlat-kw-type-list compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-type-list>))
  ;; empty argument list not tested
  (assert (list? expr-tail))
  (let ((r-types
	 (map (lambda (s-type)
		(translate-expr compiler symtbl #f s-type))
	      expr-tail))
	(binder (compiler-get-binder compiler)))
    (construct-toplevel-type-repr binder r-types)))


(define (xlat-kw-type-loop compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-type-loop>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 3)))
  (let ((s-iter-var-name (car expr-tail))
	(s-subtype-list (cadr expr-tail))
	(s-iter-expr (caddr expr-tail)))
    (let ((comp
	   (lambda (s-expr) (translate-expr compiler symtbl #f s-expr))))
      (let* ((r-iter-var
	      (make-type-variable
	       (compiler-alloc-loc compiler s-iter-var-name #f)))
	     (local-env (make-environment
			 symtbl
			 (list (cons s-iter-var-name r-iter-var))))
	     ;; Note that the iteration variable is not defined in the list
	     ;; where it is iterated.
	     (r-subtype-list (comp s-subtype-list))
	     (r-iter-expr (translate-expr compiler local-env #f s-iter-expr))
	     (binder (compiler-get-binder compiler)))
	;; We don't store local-env if it is not needed elsewhere.
	(construct-type-loop-repr
	 binder
	 (make-type-loop-object r-iter-var r-subtype-list r-iter-expr))))))


(define (xlat-kw-type-join compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-type-join>))
  (strong-assert (and (list? expr-tail) (>= (length expr-tail) 1)))
  (let ((subexpr-list (map* (lambda (s-expr)
			      (translate-expr compiler symtbl #f s-expr))
			    expr-tail))
	(binder (compiler-get-binder compiler)))
    (construct-type-join-repr
     binder
     (make-type-join-object subexpr-list))))


(define (xlat-kw-reexport compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-reexport>))
  (strong-assert (and (list? expr-tail) (= (length expr-tail) 1)))
  (check-toplevel toplevel?)
  ;; Reexport statements are allowed only in interfaces.
  (if (not (eq? (hfield-ref compiler 'unit-type) 'interface))
      (raise 'reexport-outside-interface)
      (let* ((s-var (car expr-tail))
	     (r-var-expr (translate-expr compiler symtbl #f s-var))
	     (var
	      (cond
	       ((hrecord-is-instance? r-var-expr <variable-reference>)
		(hfield-ref r-var-expr 'variable))
	       ((is-target-object? r-var-expr)
		r-var-expr)
	       ;; TBD: change "undefined" to "invalid" (?)
	       (else (raise (list 'reexport:undefined-variable s-var)))))) 
	;; The order of reexports should not matter.
	(hfield-set! compiler 'reexports
		     (cons var (hfield-ref compiler 'reexports)))
	empty-expression)))


(define (xlat-kw-define-signature compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-define-signature>))
  (check-toplevel toplevel?)
  (if (not (and (list? expr-tail) (>= (length expr-tail) 2)))
      (raise 'invalid-signature-definition))
  (let ((name (car expr-tail))
	(s-supersgn (cadr expr-tail))
	(s-members (drop expr-tail 2)))
    (cond
     ((not (symbol? name))
      (raise 'invalid-signature-name))
     ((not (list? s-members))
      (raise 'invalid-signature-member-list))
     (else
      (let* ((r-supersgn (translate-expr compiler symtbl #f s-supersgn))
	     (binder (compiler-get-binder compiler)))
	(if (or (is-null-obj? r-supersgn)
		;; Not sure if incomplete objects work here.
		(and (is-target-object? r-supersgn)
		     (is-t-instance? binder
				     r-supersgn
				     tc-signature)))
	    (let* ((bound-value (get-symbol symtbl name))
		   (rebind? (check-existing-binding? compiler bound-value))
		   (to-decl (if rebind?
				(if (eq? (get-entity-type bound-value)
					 tc-signature)
				    (get-entity-value bound-value)
				    (raise 'type-mismatch-with-forward-def))
				'()))
		   (r-own-members
		    (map*
		     (lambda (s-member)
		       (parse-signature-member-sexpr
			compiler symtbl s-member))
		     s-members))
		   (r-inh-members (if (is-null-obj? r-supersgn)
				      '()
				      (tno-field-ref r-supersgn 'l-members)))
		   (r-members (append r-inh-members r-own-members))
		   (address (if (not-null? to-decl)
				(hfield-ref to-decl 'address)
				(compiler-alloc-loc compiler name #t)))
		   (to-new0 (make-signature-object '() r-members))
		   (to-new (make-object-with-address to-new0 address))
		   (var
		    (bind-object! compiler symtbl name to-decl to-new
				  tc-signature)))
	      ;; It is probably unnecessary to wrap the definition in a list.
	      (list
	       (make-hrecord
		<signature-definition>
		tt-none
		#t
		#t
		'()
		#f
		#f
		#f
		'()
		var
		tc-signature
		to-new0
		rebind?
		#f
		#f
		r-members)))
	    (begin
	      (dvar1-set! r-supersgn)
	      (raise 'invalid-supersignature))))))))


(define (xlat-kw-define-param-signature compiler symtbl toplevel?
					expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-define-param-signature>))
  (check-toplevel toplevel?)
  (if (not (and (list? expr-tail) (>= (length expr-tail) 3)))
      ;; TBD: Change "signature" to "param-signature"
      (raise 'invalid-signature-definition))
  (let ((s-name (car expr-tail))
	(s-type-vars (cadr expr-tail))
	(s-supersgn (caddr expr-tail))
	(s-members (drop expr-tail 3)))
    (cond
     ((not (symbol? s-name))
      (raise 'invalid-signature-name))
     ((not (list? s-members))
      (raise 'invalid-signature-member-list))
     (else
      (let* ((r-tvar-bindings (make-type-vars compiler s-type-vars))
	     (local-env (make-environment
			 symtbl r-tvar-bindings))
	     (r-supersgn (translate-expr compiler local-env #f s-supersgn))
	     (binder (compiler-get-binder compiler)))
	(if (or (is-null-obj? r-supersgn)
		;; Not sure if incomplete objects work here.
		(and (is-target-object? r-supersgn)
		     (is-t-instance? binder
				     r-supersgn
				     tc-signature)))
	    (let* ((bound-value (get-symbol symtbl s-name))
		   (rebind? (check-existing-binding? compiler bound-value))
		   (to-decl (if rebind?
				(if (eq? (get-entity-type bound-value)
					 t-param-signature)
				    (get-entity-value bound-value)
				    (raise 'type-mismatch-with-forward-def))
				'()))
		   (r-own-members
		    (map*
		     (lambda (s-member)
		       (parse-signature-member-sexpr
			compiler local-env s-member))
		     s-members))
		   (r-inh-members (if (is-null-obj? r-supersgn)
				      '()
				      (tno-field-ref r-supersgn 'l-members)))
		   (r-members (append r-inh-members r-own-members))
		   (address (if (not-null? to-decl)
				(hfield-ref to-decl 'address)
				(compiler-alloc-loc compiler s-name #t)))
		   (r-type-vars (map cdr r-tvar-bindings))
		   (to-new0 (make-param-sgn-object '() r-type-vars
						   r-members))
		   (to-new (make-object-with-address to-new0 address))
		   (var (bind-object! compiler symtbl s-name to-decl to-new
				      t-param-signature)))
	      (list
	       (make-hrecord
		<param-signature-definition>
		tt-none
		#t
		#t
		'()
		#f
		#f
		#f
		'()
		var
		t-param-signature
		to-new0
		rebind?
		#f
		#f
		r-type-vars
		r-members)))
	    (begin
	      (dvar1-set! r-supersgn)
	      (raise 'invalid-param-supersignature))))))))


(define (xlat-kw-zero compiler symtbl toplevel? expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-zero>))
  (if (= (length expr-tail) 1)
      (let* ((s-clas (car expr-tail))
	     (r-clas (translate-expr compiler symtbl #f s-clas))
	     (binder (compiler-get-binder compiler)))
	(if (or (hfield-ref compiler 'inside-param-def?)
		(is-t-instance? binder r-clas
				tc-class))
	    ;; (if (or (hfield-ref compiler 'inside-param-def?)
	    ;; 	(target-type=? (get-entity-type r-clas))
	    ;; 		       tc-class))
	    (let ((zero-expr
		   (make-hrecord <zero-expr>
				 r-clas
				 #t
				 #t
				 '()
				 #t
				 #t
				 #f
				 '()
				 r-clas)))
	      zero-expr)
	    (raise 'zero:invalid-class)))
      (raise 'zero:invalid-number-of-arguments)))


(define (symbol-or-null? x)
  (or (symbol? x) (null? x)))


(define (translate-define-prim-class compiler symtbl
				     name target-name goops?
				     superclass
				     inh? imm? ebv?
				     checked? s-zero-var
				     s-member-pred
				     s-equal-pred
				     s-equal-objects-pred
				     s-equal-contents-pred)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (strong-assert (symbol? name))
  (strong-assert (or (symbol? target-name) (null? target-name)))
  (strong-assert (boolean? goops?))
  (assert (is-target-object? superclass))
  (strong-assert (boolean? inh?))
  (strong-assert (boolean? imm?))
  (strong-assert (boolean? ebv?))
  (strong-assert (boolean? checked?))
  (strong-assert (or (is-null-sexpr? s-zero-var) (symbol? s-zero-var)))
  (cond
   ((entity-is-none1? (compiler-get-binder compiler) superclass)
    (raise 'none-as-superclass))
   ((not (is-known-object? superclass))
    (raise 'invalid-prim-class-superclass-1))
   ((not (symbol-or-null? s-member-pred))
    (raise (list 'invalid-member-predicate name)))
   ((not (and
	  (symbol-or-null? s-equal-pred)
	  (symbol-or-null? s-equal-objects-pred)
	  (symbol-or-null? s-equal-contents-pred)))
    (raise (list 'invalid-equality-predicate name)))
   ;; TBD: change eqv? to eq?.
   ((and (not goops?) (not (eqv? superclass tc-object)))
    (raise 'invalid-prim-class-superclass-2))
   ((and goops?
	 ;; TBD: change eqv? to eq?.
	 (not (eqv? superclass tc-object))
	 (not (tno-field-ref superclass 'goops?)))
    (raise 'invalid-goops-class-superclass))
   ((not (tno-field-ref superclass 'inheritable?))
    (raise 'noninheritable-superclass))
   ((and (not goops?) (null? s-member-pred))
    (raise 'no-membership-predicate))
   ;; TBD: Check that target-name is nonnull for goops classes.
   (else
    (let* ((ht (if goops? 
		   (hfield-ref compiler 'ht-goops-classes)
		   (hfield-ref compiler 'ht-prim-classes)))
	   (s-search (if goops? target-name s-member-pred))
	   (x (hashq-ref ht s-search)))
      ;; TBD: Change eqv? to eq?.
      (if (not (eqv? x #f))
	  (begin
	    (if goops?
		(raise (list 'multiple-goops-class-definitions target-name))
		(raise (list 'multiple-prim-class-definitions s-member-pred))))
	    ;; (if goops?
	    ;; 	(display-goops-warning target-name)
	    ;; 	(display-prim-warning s-member-pred))
	    ;; (let* ((bound-value (get-symbol symtbl name))
	    ;; 	   (rebind? (check-existing-binding? compiler bound-value)))
	    ;;   (if rebind?
	    ;; 	  (begin
	    ;; 	    (assert (not-null? bound-value))
	    ;; 	    (set-object1 bound-value x))
	    ;; 	  (add-symbol! symtbl name x))
	    ;;   empty-expression))
	  (let* ((bound-value (get-symbol symtbl name))
		 (rebind? (check-existing-binding? compiler bound-value))
		 (decl (if rebind?
			   empty-expression
			   (translate-forward-declaration
			    compiler symtbl name tc-class #t #f)))
		 (to (if rebind?
			 bound-value
			 (get-entity-value (hfield-ref decl 'variable))))
		 (address (hfield-ref to 'address))
		 (binder (compiler-get-binder compiler))
		 (member-target-name
		  (if (not-null? s-member-pred) s-member-pred '()))
		 (equal-target-name
		  (if (not-null? s-equal-pred)
		      s-equal-pred
		      gl-sym-default-prim-equal))
		 (equal-objects-target-name
		  (if (not-null? s-equal-objects-pred)
		      s-equal-objects-pred
		      gl-sym-default-prim-equal-objects))
		 (equal-contents-target-name
		  (if (not-null? s-equal-contents-pred)
		      s-equal-contents-pred
		      gl-sym-default-prim-equal-contents))
		 (module (get-current-module-name compiler))
		 (zero-address (if (not (is-null-sexpr? s-zero-var))
				   (alloc-target-prim-loc s-zero-var)
				   '()))
		 ;; Not sure if address should be defined here.
		 (to-new (create-custom-prim-class
			  address
			  (symbol->string name)
			  module goops? superclass
			  inh? imm? ebv?
			  zero-address))
		 (var (make-object-var to-new)))
	    (set-object1! to to-new)
	    (hashq-set! ht s-search to)
	    (let ((result
		   (make-hrecord
		    <prim-class-def>
		    tt-none
		    #t
		    #t
		    '()
		    #f
		    #f
		    #f
		    '()
		    var
		    tc-class
		    '()
		    ;; A primitive class is always forward declared.
		    #t
		    #f
		    #f
		    (symbol->string name)
		    target-name
		    goops?
		    superclass
		    inh?
		    imm?
		    ebv?
		    checked?
		    member-target-name
		    equal-target-name
		    equal-objects-target-name
		    equal-contents-target-name
		    zero-address)))
	      (if (not rebind?)
		  (list decl result)
		  ;; TBD: remove "list" from the following.
		  (list result)))))))))


(define (xlat-kw-define-prim-class compiler symtbl toplevel?
				   expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-define-prim-class>))
  (check-toplevel toplevel?)
  (if (= (length expr-tail) 9)
      (let ((name (list-ref expr-tail 0))
	    (imm? (list-ref expr-tail 1))
	    (ebv? (list-ref expr-tail 2))
	    (checked? (list-ref expr-tail 3))
	    (s-zero-var (list-ref expr-tail 4))
	    (s-member-pred (list-ref expr-tail 5))
	    (s-equal-pred (list-ref expr-tail 6))
	    (s-equal-objects-pred (list-ref expr-tail 7))
	    (s-equal-contents-pred (list-ref expr-tail 8)))
	(strong-assert (not-null? s-member-pred))
	(translate-define-prim-class compiler symtbl name '() #f tc-object
				     #f imm? ebv?
				     checked? s-zero-var
				     s-member-pred
				     s-equal-pred
				     s-equal-objects-pred
				     s-equal-contents-pred))
      (raise 'define-prim-class:syntax-error)))


(define (xlat-kw-define-goops-class compiler symtbl toplevel?
				    expr-head expr-tail)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (hrecord-is-instance? expr-head <keyword-define-goops-class>))
  (check-toplevel toplevel?)
  (if (= (length expr-tail) 10)
      (let ((name (list-ref expr-tail 0))
	    (target-name (list-ref expr-tail 1))
	    (s-superclass (list-ref expr-tail 2))
	    (inh? (list-ref expr-tail 3))
	    (imm? (list-ref expr-tail 4))
	    (ebv? (list-ref expr-tail 5))
	    (checked? (list-ref expr-tail 6))
	    (s-zero-var (list-ref expr-tail 7))
	    (s-equal-pred (list-ref expr-tail 8))
	    (s-equal-contents-pred (list-ref expr-tail 9)))
	(let ((var-superclass
	       (if (symbol? s-superclass)
		   (get-symbol symtbl s-superclass)
		   ;; Superclass may be a module reference.
		   (get-entity-value
		    (translate-expr compiler symtbl #f s-superclass)))))
	  (if (or (eq? var-superclass #f) (eq? var-superclass '()))
	      (raise 'define-goops-class:nonexistent-superclass)
	      (translate-define-prim-class compiler symtbl name
					   target-name
					   #t
					   var-superclass
					   inh? imm? ebv?
					   checked? s-zero-var
					   '()
					   s-equal-pred
					   '()
					   s-equal-contents-pred))))
      (raise 'define-goops-class:syntax-error)))


(define (check-match-type-source-clauses lst-clauses)
  (and-map? (lambda (lst-clause)
	      (and (list? lst-clause)
		   (not-null? lst-clause)
		   (or (and (list? (car lst-clause))
			    (<= (length (car lst-clause)) 2))
		       (eq? (car lst-clause) gl-match-type-else))))
	    lst-clauses))


(define (translate-match-type-clause compiler symtbl sexpr-clause)
  (let* ((sexpr-varspec (car sexpr-clause))
	 (has-var? (= (length sexpr-varspec) 2))
	 (sym-var-name (if has-var? (car sexpr-varspec) '()))
	 (sexpr-type (if has-var? (cadr sexpr-varspec) (car sexpr-varspec)))
	 (expr-type (translate-expr compiler symtbl #f sexpr-type))
	 (binder (compiler-get-binder compiler))
	 (var (if (not-null? sym-var-name)
		  (make-normal-variable0
		   (compiler-alloc-loc compiler sym-var-name #f)
		   expr-type
		   #t
		   (is-final-class? binder expr-type)
		   #t
		   #f
		   #f
		   #f
		   '()
		   '()
		   #f
		   #f)
		  '()))
	 (env-new (if (not-null? var)
		      (make-environment symtbl (list (cons sym-var-name var)))
		      symtbl))
	 (expr (wrap-compound-expression compiler env-new (cdr sexpr-clause))))
    (list var expr-type expr #f)))


;; TBD: Check that no proper clauses begin with "else".
(define (translate-match-type compiler symtbl toplevel?
			      expr-head expr-tail strong?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (hrecord-is-instance? symtbl <environment>))
  (assert (boolean? toplevel?))
  (assert (not-null? expr-tail))
  (assert (boolean? strong?))
  (strong-assert (and (list? expr-tail) (>= (length expr-tail) 1)))
  (let ((sexpr-to-match (car expr-tail))
	(lst-source-clauses (cdr expr-tail)))
    (if (check-match-type-source-clauses lst-source-clauses)
	(let* ((has-else-clause?
		(and (not-null? lst-source-clauses)
		     (eq? (car (last lst-source-clauses)) gl-match-type-else)))
	       (lst-proper-sexpr-clauses
		(if has-else-clause?
		    (drop-right lst-source-clauses 1)
		    lst-source-clauses))
	       (expr-to-match (translate-expr compiler symtbl toplevel?
					      sexpr-to-match))
	       (sexpr-else (if has-else-clause?
			       (last lst-source-clauses)
			       '()))
	       (expr-else
		(if (and has-else-clause?
			 (not-null? (cdr sexpr-else)))
		    (wrap-compound-expression compiler symtbl (cdr sexpr-else))
		    empty-expression))
	       (lst-proper-clauses
		(map (lambda (sexpr-clause)
		       (translate-match-type-clause
			compiler symtbl sexpr-clause))
		     lst-proper-sexpr-clauses))
	       (binder (compiler-get-binder compiler))
	       (type-check? (not (hfield-ref compiler 'inside-param-def?))))
	  (translate-match-type-expr binder strong?
				     expr-to-match lst-proper-clauses
				     expr-else type-check?))
	(raise 'match-type:syntax-error))))


(define (xlat-kw-match-type compiler symtbl toplevel?
			    expr-head expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-match-type>))
  (translate-match-type compiler symtbl toplevel? expr-head expr-tail #f))


(define (xlat-kw-match-type-strong compiler symtbl toplevel?
				   expr-head expr-tail)
  (assert (hrecord-is-instance? expr-head <keyword-match-type-strong>))
  (translate-match-type compiler symtbl toplevel? expr-head expr-tail #t))


(define (xlat-kw-force-pure-expr compiler symtbl toplevel?
				 expr-head expr-tail)
  (if (= (length expr-tail) 1)
      (let ((repr-component (translate-expr compiler symtbl toplevel?
					    (car expr-tail))))
	(translate-force-pure-expr repr-component))
      (raise 'force-pure-expr:syntax-error)))


(define (xlat-kw-static-type-of compiler symtbl toplevel?
				expr-head expr-tail)
  ;; Should we compute the component expression in the translated code?
  (if (= (length expr-tail) 1)
      (let* ((sexpr (car expr-tail))
	     (ent (translate-expr compiler symtbl toplevel? sexpr)))
	(if (is-entity? ent)
	    (let ((type (get-entity-type ent)))
	      (if (is-target-object? type)
		  type
		  (raise (list 'static-type-of:invalid-type sexpr))))
	    (raise (list 'static-type-of:invalid-argument sexpr))))
      (raise (list 'static-type-of:invalid-number-of-arguments expr-tail))))


(define (xlat-kw-prevent-stripping compiler symtbl toplevel?
				   expr-head expr-tail)
  (check-toplevel toplevel?)
  (cond
   ((not (= (length expr-tail) 1))
    (raise 'prevent-stripping:syntax-error))
   (else
    (let ((sym-name (car expr-tail)))
      (if (symbol? sym-name)
	  (let ((var (get-symbol symtbl sym-name)))
	    (if (and (is-entity? var)
		     (not-null? (hfield-ref var 'address)))
		(make-prevent-stripping-expr (hfield-ref var 'address))
		(raise 'prevent-stripping:variable-does-not-exist)))
	  (raise 'prevent-stripping:invalid-variable))))))


(define (xlat-kw-define-syntax compiler symtbl toplevel? expr-head expr-tail)
  (check-toplevel toplevel?)
  (if (not (= (length expr-tail) 2))
      (raise 'define-syntax-syntax-error)
      (let ((s-name (car expr-tail))
	    (x-handler (cadr expr-tail)))
	(dwl2 s-name)
	(if (not (symbol? s-name))
	    (raise 'invalid-syntax-name)
	    (let* ((address (compiler-alloc-loc compiler s-name #t))
		   (to (make-t-macro address '())))
	      (ex:expand-toplevel-sequence1
	       (list (cons 'define-syntax expr-tail)))
	      (address-env-add-binding2! (hfield-ref compiler 'env-all)
					 address to)
	      (let ((env1 (hfield-ref compiler 'env)))
		(if (symbol-exists? env1 s-name)
		    (raise (list 'duplicate-macro-definition s-name))
		    (add-symbol! env1 s-name to)))
	      (make-hrecord <expr-define-syntax>
			    tc-macro #t #t '()
			    #f #f #f '()
			    address x-handler))))))


;; TBD: Remove $'s from the exception names.
(define (xlat-kw-module-ref compiler symtbl toplevel? expr-head expr-tail)
  (if (= (length expr-tail) 2)
      (let ((l-module (car expr-tail))
	    (s-var-name (cadr expr-tail)))
	(cond
	 ((not (or (symbol? l-module)
		   (and (list? l-module) (and-map? symbol? l-module))))
	  (raise '$module-ref:invalid-module))
	 ((not (symbol? s-var-name))
	  (raise '$module-ref:invalid-variable-name))
	 (else
	  (let* ((env-all (hfield-ref compiler 'env-all))
		 (l-module1 (if (symbol? l-module) (list l-module) l-module))
		 (pred (lambda (address var)
			 (and
			  (equal? (hfield-ref address 'module) l-module1)
			  (eq? (hfield-ref address 'source-name) s-var-name))))
		 (ent (address-env-get-item-general env-all pred)))
	    (if (not (eq? ent #f))
		(if (hrecord-is-instance? ent <normal-variable>)
		    (make-var-ref-to-var ent)
		    ent)
		(begin
		  (raise (list '$module-ref:undefined-variable expr-tail))))))))
      (raise '$module-ref:invalid-number-of-arguments)))


(define (xlat-kw-assert compiler symtbl toplevel? expr-head expr-tail)
  (raise 'assert-outside-macro-expansion))


(define (xlat-kw-strong-assert compiler symtbl toplevel? expr-head expr-tail)
  (raise 'strong-assert-outside-macro-expansion))


(define (xlat-kw-do-assert compiler symtbl toplevel? expr-head expr-tail)
  (if (= (length expr-tail) 2)
      (let ((condition (car expr-tail))
	    (cond-to-print (cadr expr-tail)))
	(translate-assertion compiler symtbl condition cond-to-print #f))
      (raise '_assert:syntax-error)))


(define (xlat-kw-do-strong-assert compiler symtbl toplevel? expr-head expr-tail)
  (if (= (length expr-tail) 2)
      (let ((condition (car expr-tail))
	    (cond-to-print (cadr expr-tail)))
	(translate-assertion compiler symtbl condition cond-to-print #t))
      (raise '_strong-assert:syntax-error)))


(define (search-keyword kwclass)
  (let ((s-result '()))
    (do ((l-cur-keywords keywords (cdr l-cur-keywords)))
	((or (null? l-cur-keywords) (not-null? s-result)) s-result)
      (if (eq? kwclass (cadr (car l-cur-keywords)))
	  (set! s-result (car (car l-cur-keywords)))))))


(define (raise-illegal-keyword compiler symtbl toplevel? expr-head expr-tail)
  (let ((s-keyword (search-keyword (hrecord-type-of expr-head))))
    (raise (list 'illegal-use-of-keyword (cons 's-keyword s-keyword)))))


(set! xlat-table
      (list
       (cons <keyword-define> xlat-kw-define)
       (cons <keyword-define-variable> xlat-kw-define-variable)
       (cons <keyword-define-volatile> xlat-kw-define-volatile)
       (cons <keyword-define-class> xlat-kw-define-class)
       (cons <keyword-constructor> xlat-kw-constructor)
       (cons <keyword-cast> xlat-kw-cast)
       (cons <keyword-try-cast> xlat-kw-try-cast)
       (cons <keyword-static-cast> xlat-kw-static-cast)
       (cons <keyword-match-type> xlat-kw-match-type)
       (cons <keyword-match-type-strong> xlat-kw-match-type-strong)
       (cons <keyword-if> xlat-kw-if)
       (cons <keyword-if-object> xlat-kw-if-object)
       (cons <keyword-begin> xlat-kw-begin)
       (cons <keyword-procedure> xlat-kw-procedure)
       (cons <keyword-procedure-aut> xlat-kw-procedure-aut)
       (cons <keyword-param-proc> xlat-kw-param-proc)
       (cons <keyword-param-proc-aut> xlat-kw-param-proc-aut)
       (cons <keyword-define-gen-proc> xlat-kw-define-gen-proc)
       (cons <keyword-add-method> xlat-kw-add-method)
       (cons <keyword-add-static-method> xlat-kw-add-static-method)
       (cons <keyword-primitive-procedure> xlat-kw-prim-proc)
       (cons <keyword-unchecked-primitive-procedure>
	     xlat-kw-unchecked-prim-proc)
       (cons <keyword-param-prim-proc> xlat-kw-param-prim-proc)
       (cons <keyword-unchecked-param-prim-proc>
	     xlat-kw-unchecked-param-prim-proc)
       (cons <keyword-define-prim-class> xlat-kw-define-prim-class)
       (cons <keyword-define-goops-class> xlat-kw-define-goops-class)
       (cons <keyword-quote> xlat-kw-quote)
       (cons <keyword-let> xlat-kw-let)
       (cons <keyword-let-variables> xlat-kw-let-variables)
       (cons <keyword-let-volatile> xlat-kw-let-volatile)
       (cons <keyword-letrec> xlat-kw-letrec)
       (cons <keyword-letrec-variables> xlat-kw-letrec-variables)
       (cons <keyword-letrec-volatile> xlat-kw-letrec-volatile)
       (cons <keyword-letrec*> xlat-kw-letrec*)
       (cons <keyword-letrec*-variables> xlat-kw-letrec*-variables)
       (cons <keyword-letrec*-volatile> xlat-kw-letrec*-volatile)
       (cons <keyword-set> xlat-kw-set)
       (cons <keyword-until> xlat-kw-until)
       (cons <keyword-declare> xlat-kw-declare)
       (cons <keyword-declare-mutable> xlat-kw-declare-mutable)
       (cons <keyword-declare-volatile> xlat-kw-declare-volatile)
       (cons <keyword-declare-method> xlat-kw-declare-method)
       (cons <keyword-declare-static-method> xlat-kw-declare-static-method)
       (cons <keyword-def-param-class> xlat-kw-def-param-class)
       (cons <keyword-def-param-logical-type> xlat-kw-def-param-logical-type)
       (cons <keyword-def-param-proc-alt> xlat-kw-def-param-proc-alt)
       (cons <keyword-define-signature> xlat-kw-define-signature)
       (cons <keyword-define-param-signature> xlat-kw-define-param-signature)
       (cons <keyword-param-proc-instance> xlat-kw-param-proc-instance)
       (cons <keyword-param-proc-dispatch> xlat-kw-param-proc-dispatch)
       (cons <keyword-param-proc-cond-appl> xlat-kw-param-proc-cond-appl)
       (cons <keyword-generic-proc-dispatch> xlat-kw-generic-proc-dispatch)
       (cons <keyword-generic-proc-dispatch-without-result>
	     xlat-kw-generic-proc-dispatch-without-result)
       (cons <keyword-rest> xlat-kw-rest)
       (cons <keyword-splice> xlat-kw-splice)
       (cons <keyword-type-list> xlat-kw-type-list)
       (cons <keyword-type-loop> xlat-kw-type-loop)
       (cons <keyword-type-join> xlat-kw-type-join)
       (cons <keyword-reexport> xlat-kw-reexport)
       (cons <keyword-zero> xlat-kw-zero)
       (cons <keyword-force-pure-expr> xlat-kw-force-pure-expr)
       (cons <keyword-static-type-of> xlat-kw-static-type-of)
       (cons <keyword-prevent-stripping> xlat-kw-prevent-stripping)
       (cons <keyword-define-syntax> xlat-kw-define-syntax)
       (cons <keyword-module-ref> xlat-kw-module-ref)
       (cons <keyword-assert> xlat-kw-assert)
       (cons <keyword-strong-assert> xlat-kw-strong-assert)
       (cons <keyword-do-assert> xlat-kw-do-assert)
       (cons <keyword-do-strong-assert> xlat-kw-do-strong-assert)
       ;; The module language keywords are handled differently.
       (cons <keyword-import> raise-illegal-keyword)
       (cons <keyword-import-and-reexport> raise-illegal-keyword)
       (cons <keyword-use> raise-illegal-keyword)
       (cons <keyword-prelink-body> raise-illegal-keyword)
       (cons <keyword-define-proper-program> raise-illegal-keyword)
       (cons <keyword-define-script> raise-illegal-keyword)
       (cons <keyword-define-interface> raise-illegal-keyword)
       (cons <keyword-define-body> raise-illegal-keyword)))


(define (theme-parse-toplevel-expr compiler expr symtbl)
  (translate-expr compiler symtbl #t expr))


(define (expand-expr1 compiler expr)
  (if (and
       (list? expr)
       (not-null? expr)
       (eq? (car expr) skw-define-syntax))
      (list expr)
      (ex:expand-toplevel-sequence1 (list expr))))


(define (expand-expr2 compiler symtbl expr)
  ;; Macro bodies are not expanded when they are defined.
  ;; Macro bodies are compiled only to interface files.
  (if (and
       (list? expr)
       (not-null? expr)
       (eq? (car expr) skw-define-syntax))
      (begin (xlat-kw-define-syntax compiler symtbl #t
				    (car expr)
				    (cdr expr))
	     (if (eq? (hfield-ref compiler 'unit-type) 'interface)
		 (list expr)
		 '((quote ()))))
      (ex:expand-toplevel-sequence1 (list expr))))


(define (theme-expand-expr-list compiler symtbl exprs)
  (apply append
;;	 (map* (lambda (sexpr) (expand-expr2 compiler symtbl sexpr)) exprs)))
	 (map* (lambda (sexpr)
		 (d2wl 'prelink "expression 1:")
		 (d2wl 'prelink sexpr)
		 (let ((result
			(expand-expr2 compiler symtbl sexpr)))
		   (d2wl 'prelink "expression 2:")
		   (d2wl 'prelink result)
		   result))
	       exprs)))


(define (add-compiled-body-exprs compiler exprs)
  (cond
   ((null? exprs) '())
   ((list? exprs)
    (for-each (lambda (expr) (add-compiled-body-exprs compiler expr)) exprs))
   (else
    (hfield-set! compiler 'body
		 (append (hfield-ref compiler 'body) (list exprs))))))


(define (theme-parse-expr-list compiler symtbl exprs)
  (let ((parse-expr
	 (lambda (expr)
	   (let ((l-exprs1 (if (not (hfield-ref compiler 'no-expansion?))
			       (expand-expr1 compiler expr)
			       (list expr))))
	     ;; Error messages have to refer to unexpanded code.
	     (hfield-set! compiler 'current-toplevel-expr expr)
	     (let ((l-exprs2
		    (map* (lambda (expr2)
			    (theme-parse-toplevel-expr compiler expr2 symtbl))
			  l-exprs1)))
	       (add-compiled-body-exprs compiler l-exprs2))
	     (hfield-set! compiler 'current-toplevel-expr '())))))
    (for-each parse-expr exprs)))


(define (theme-initial-parse compiler subexprs)
  (let ((stop? #f)
	(l-body '()))
    (do ((l-cur subexprs (cdr l-cur))) ((or (null? l-cur) stop?))
      (let ((x-first (car l-cur))
	    (l-tail (cdr l-cur)))
	(if (or (null? x-first) (not (list? x-first)))
	    (begin
	      (set! l-body l-cur)
	      (set! stop? #t))
	    (let ((s-keyword (car x-first))
		  (l-modules (cdr x-first)))
	      (if (memq s-keyword
			(list skw-import skw-import-and-reexport skw-use
			      skw-prelink-body))
		  (if (and-map? is-user-module-name? l-modules)
		      (let ((l-actual-names
			     (map get-actual-module-name l-modules)))
			(cond
			 ((eq? s-keyword skw-import)
			  (hfield-set! compiler 'imports
				       (append (hfield-ref compiler 'imports)
					       l-actual-names)))
			 ((eq? s-keyword skw-import-and-reexport)
			  (hfield-set! compiler 'imports-with-reexports
				       (append
					(hfield-ref compiler
						    'imports-with-reexports)
					l-actual-names)))
			 ((eq? s-keyword skw-use)
			  (hfield-set! compiler 'l-used-modules
				       (append
					(hfield-ref compiler
						    'l-used-modules)
					l-actual-names)))
			 ((eq? s-keyword skw-prelink-body)
			  (if (not (eq? (hfield-ref compiler 'unit-type)
				   'interface))
			      (hfield-set! compiler 'l-prelinked-bodies
					   (append
					    (hfield-ref compiler
							'l-prelinked-bodies)
					    l-actual-names))
			      (begin
				(hfield-set! compiler 'current-toplevel-expr
					     x-first)
				(hfield-set! compiler 'current-expr
					     x-first)
				(raise 'prelink-in-interface))))
			 (else
			  ;; We should never arrive here.
			  (raise 'internal-error))))
		      (raise 'importing-syntax-error))
		  (begin
		    (set! l-body l-cur)
		    (set! stop? #t)))))))
    (hfield-set! compiler 'l-body-source l-body)))


(define (theme-do-parse-unit compiler subexprs unit-type)
  ;; TBD: Remove the following assertion and move the test for length.
  (strong-assert (>= (length subexprs) 2))
  (let* ((name0 (cadr subexprs))
	 (name (if (symbol? name0) (list name0) name0)))
    (if (>= (length subexprs) 2)
	(begin
	  (hfield-set! compiler 'unit-type unit-type)
	  (theme-initial-parse compiler (drop subexprs 2))
	  (let ((l-body-source (hfield-ref compiler 'l-body-source))
		(imports (hfield-ref compiler 'imports))
		(imports-with-reexports
		 (hfield-ref compiler 'imports-with-reexports))
		(l-used-modules
		 (hfield-ref compiler 'l-used-modules)))
	    (hfield-set! gl-expander 'tup-default-module name)
	    (let ((env1 (clone-environment global-builtins-symtbl))
		  (env2 (make-address-environment global-builtins-symtbl))
		  (ht-globals
		   (make-hash-table gl-i-globals-by-address-size))
		  (ht-names
		   (make-hash-table gl-i-globals-by-name-size))
		  (ht-cycles
		   (make-hash-table gl-i-cycles-size))
		  (ht-type-variables
		   (make-hash-table gl-i-tvars-size))
		  (ht-goops-classes
		   (make-hash-table gl-i-goops-classes-size))
		  (ht-prim-classes
		   (make-hash-table gl-i-prim-classes-size))
		  (ht-procs
		   (make-hash-table gl-i-procs-size)))
	      (dwl1 "Importing submodules")
	      (hfield-set! compiler 'state 'importing)
	      (hfield-set! compiler 'env env1)
	      (hfield-set! compiler 'env-all env2)
	      ;; TBD: Remove the following statement.
	      (hfield-set! compiler 'imports imports)
	      ;; TBD: Remove the following statement.
	      (hfield-set! compiler 'imports-with-reexports
			   imports-with-reexports)
	      (hfield-set! (hfield-ref compiler 'binder)
			   'ht-globals-by-address
			   ht-globals)
	      (hfield-set! compiler 'ht-globals-by-name ht-names)
	      (hfield-set! compiler 'ht-cycles ht-cycles)
	      (hfield-set! compiler 'ht-type-variables ht-type-variables)
	      (hfield-set! compiler 'ht-goops-classes ht-goops-classes)
	      (hfield-set! compiler 'ht-prim-classes ht-prim-classes)
	      (hfield-set! compiler 'ht-procs ht-procs)
	      (hfield-set! compiler 'toplevel-unit-name name)
	      (let ((alo-exports (make-alo '() eq?)))
		(hash-set! (hfield-ref gl-expander 'ht-all-exports)
			   name
			   alo-exports)
		(hfield-set! gl-expander 'alo-current-exports
			     alo-exports))
	      (if (eq? unit-type 'body)
		  (import-module compiler name '() 'toplevel-interface
				 #t #t))
	      (import-toplevel-modules compiler imports #t)
	      (import-toplevel-modules compiler imports-with-reexports #t)
	      (import-toplevel-modules compiler l-used-modules #f)
	      (hfield-set! compiler 'state '())
	      (dwl1 "Parsing the target module")
	      ;; Not sure about the following.
	      (hfield-set! compiler 'env env1)
	      (dw1 "Number of source expressions: ")
	      (dwl1 (length l-body-source))
	      (hfield-set! compiler 'state 'parsing)
	      (hfield-set! compiler 'unit-type unit-type)
	      (hfield-set! compiler 'module-name name)
	      (hfield-set! gl-expander 'tup-default-module name)
	      (update-current-env
	       name
	       (append imports imports-with-reexports l-used-modules
		       (hfield-ref compiler 'l-interface-imports)))
	      (let ((alo-old-exports
		     (hfield-ref gl-expander 'alo-current-exports))
		    (alo-new-exports
		     (hash-ref (hfield-ref gl-expander 'ht-all-exports)
			       name)))
		(assert (is-alo? alo-new-exports))
		(hfield-set! gl-expander 'alo-current-exports
			     alo-new-exports)
		(if (hfield-ref compiler 'expand-only?)
		    (hfield-set! compiler 'expanded-body
				 (theme-expand-expr-list compiler env1
							 l-body-source))
		    (theme-parse-expr-list compiler env1 l-body-source))
		;; This resetting may be unnecessary.
		(hfield-set! gl-expander 'alo-current-exports
			     alo-old-exports))
	      (hfield-set! compiler 'state '())
	      (dw1 "Number of target expressions: ")
	      (dwl1 (length (hfield-ref compiler 'body))))))
	(raise 'too-short-source-file))))


(define (get-unit-keyword unit-type)
  (case unit-type
    ((proper-program) skw-define-proper-program)
    ((script) skw-define-script)
    ((interface) skw-define-interface)
    ((body) skw-define-body)
    (else (raise 'invalid-unit-type))))


(define (theme-parse-unit compiler expr unit-type)
  (cond
   ((not (pair? expr))
    (raise 'expected-list-at-toplevel))
   ((not (= (length expr) 1))
    (raise 'module-syntax-error))
   (else
    (let ((subexprs (car expr)))
      (if (< (length subexprs) 2)
	  (raise 'module-syntax-error)
	  (if (not (eq? (car subexprs) (get-unit-keyword unit-type)))
	      (raise 'invalid-keyword-for-unit)
	      (theme-do-parse-unit compiler subexprs unit-type)))))))

