;; General functions to compile specific AST nodes. Beside the environment,
;; these functions may accept a "compiler" as argument. Such "compiler"s
;; are used to compile sub-nodes in specific ways (generic function) like:
;;   compile-expr      == push the value on the stack
;;   compile-effect    == compile only for side effect
;;   compile-predicate == compile as a predicate with corresponding labels.

(module jvm_compiler
   (import type_type type_typeof ast_var ast_node engine_param
	   object_class      ; tclass
	   foreign_jtype     ; jarray
	   jvm_lisp
	   jvm_extern jvm_env jvm_instr jvm_inline
	   jvm_tail jvm_expr jvm_effect jvm_predicate 
	   tools_shape)
   (export (compiler-body e::node env::env) 
	   (compiler-atom e env::env)
	   (compiler-var e::var env::env)
	   (compiler-let e::let-var env::env compiler)
	   (compiler-setq e::setq env::env)
	   (compiler-sequence e::sequence env::env compiler)
	   (compiler-if e::conditional env::env compiler)
	   (compiler-select e::select env::env compiler)
	   (compiler-labels e::let-fun env::env comp)
	   (compiler-app e::app env::env)
	   (compiler-apply e::app-ly env::env)
	   (compiler-funcall e::funcall env::env)
	   (compiler-pragma e::pragma env::env)
	   (compiler-getfield e::getfield env::env)
	   (compiler-setfield e::setfield env::env)
	   (compiler-new e::new env::env)
	   (compiler-valloc e::valloc env::env)
	   (compiler-vref e::vref env::env)
	   (compiler-vset e::vset! env::env)
	   (compiler-vlength e::vlength env::env)
	   (compiler-isa e::isa env::env)
	   (compiler-cast e::cast env::env comp)
	   (compiler-setexit e::set-ex-it env::env comp)
	   (compiler-jump-exit e::jump-ex-it env::env)
	   (compiler-fail e::fail env::env)
	   (compiler-make-box e::make-box env::env)
	   (compiler-box-ref e::box-ref env::env)
	   (compiler-box-set! e::box-set! env::env) ))

(define (compiler-body e::node env::env)
   (set! *labdone* '())
   (set! *lab2labels* '())
   (set! *labels2saved* '())
   (_label env 'begin)
   (compile-tail e env) )

;; #line
(define (out-line e env)
   (let ( (n (get-line-number e)) )
      ; (_COMMENT env "type" (list (compile-type (node-type e) env) e))
      (if n
	  (_line env n)
	  'ok )))

;; type
(define (check_type env e ty)
   (let ( (rty (compile-type (typeof e) env)) )
      (if (pair? ty)
	  (if (not (memq rty ty))
	      (tprint (shape e) " bad type " rty " must in " ty) )
	  (if (not (eq? rty ty))
	      (tprint (shape e) " bad type " rty " must be " ty) ))))

(define (check_type_vector env e ty)
   (let ( (rty (compile-type (typeof e) env)) )
      (if (not (and (pair? rty) (eq? (car rty) 'vector)))
	  (tprint e " bad type " rty " must be " `(vector ,ty)) )
      (let ( (ety (cadr rty)) )
	 (if (not (eq? ety ty))
	     (tprint e " bad type " rty " must be " `(vector ,ty)) ))))

(define (same-type env down up)
   (let ( (tdown (compile-type down env)) (tup (compile-type up env)) )
      (if (not (equal? tdown tup))
	  (begin '(tprint up " wrong type " (list tdown '-> tup))
		 (set-type down (get-type up)) ))))

(define (same-type? env down up)
   (let ( (tdown (compile-type down env)) (tup (compile-type up env)) )
      (if (not (equal? tdown tup))
	  (tprint up " may wrong type " (list tdown '-> tup)) )))

(define (get-type e)
   (cond ((node? e) (typeof e))
	 ((variable? e) (variable-type e))
	 (else (error "type" "unknown node" e)) ))

(define (set-type e::obj ty)
   (cond ((node? e) '(node-type-set! e ty))
	 ((variable? e) (variable-type-set! e ty))
	 (else (error "set-type" "unknown node" e)) ))

;;
(define (compiler-atom e env::env)
   (out-line e env)
   (with-access::atom e (value)
      (cond
	 ((number? value)
	  (check_type env e '(boolean int long float double))
	  (_push env (compile-type (typeof e) env) value) )
	 ((null? value)
	  (check_type env e '(jobject t_nil))
	  (_getstatic env (jlib-declare env 'nil)) )
	 ((boolean? value)
	  (check_type env e 'boolean)
	  (_push env 'int (if value 1 0)) )
	 ((char? value)
	  (check_type env e 'int)
	  (_push env 'int (char->integer value)) )
	 ((string? value)
	  ;; CARE do the creation at clinit time
	  (check_type_vector env e 'byte)
	  (create-string env value) )
	 ((eof-object? value)
	  (check_type env e '(jobject t_eof))
	  (_getstatic env (jlib-declare env 'eof)) )
	 ((eq? value '#!optional)
	  (check_type env e '(jobject t_optional))
	  (_getstatic env (jlib-declare env 'optional)) )
	 ((eq? value '#!rest)
	  (check_type env e '(jobject t_rest))
	  (_getstatic env (jlib-declare env 'rest)) )
	 ((eq? value '#!key)
	  (check_type env e '(jobject t_key))
	  (_getstatic env (jlib-declare env 'key)) )
	 ((eq? value #unspecified)
	  (check_type env e '(jobject t_unspecified))
	  (_getstatic env (jlib-declare env 'unspecified)) )
	 ((ucs2? value)
	  (check_type env e '(jobject bucs2))
	  ;; CARE do the creation at clinit time
	  (_new env (jlib-declare env 'j_bucs2))
	  (_dup env)
	  (_push env 'int (ucs2->integer value))
	  (if *jvm-purify*
	      (_invokespecial env (jlib-declare env 'init_bucs2) '(ad char) 'void)
	      (_putfield env (jlib-declare env 'bucs2_value)) ))
	 ((elong? value)
	  (check_type env e '(jobject t_belong))
	  ;; CARE do the creation at clinit time
	  (_push env 'string (elong->string value))
	  (_invokestatic env (jlib-declare env 'make_elong) '(ad) 'ad) )
	 ((llong? value)
	  (check_type env e '(jobject t_bllong))
	  ;; CARE do the creation at clinit time
	  (_push env 'string (llong->string value))
	  (_invokestatic env (jlib-declare env 'make_llong) '(ad) 'ad) )
	 (else (error "compile" "bad atom value" value) ))))

;;
(define (compiler-var e::var env::env)
   (out-line e env)
   (let ( (var (var-variable e)) )
      (cond
	 ((global? var)
	  (let ( (value (global-value var)) )
	     (if (sfun? value)
		 (compile-procedure-entry var (sfun-arity value) env)
		 (_getstatic2 env var) )))
	 (else (_load env var)) )))

(define (compile-procedure-entry var::global arity env::env)
   (let ( (x (if (>= arity 0) (- arity 1) (+ arity 1))) )
      (let ( (index (env-new-procedure env x (get-global-name env var))) )
	 (_push env 'int index) )))

;;
(define (compiler-let e::let-var env::env compiler)
   (out-line e env)
   (with-access::let-var e (bindings body)
      (let ( (debug? (debug-for-declare-var? env)) )
	 (let ( (elab (if debug? (gensym "T") '???)) )
	    (for-each (lambda (b)
			 (let ( (var (car b)) (val (cdr b)) )
			    (compile-expr val env)
			    (same-type env val var)
			    (env-declare-local env var)
			    (debug-declare-var env var elab)
			    (_store env var) ))
		      bindings )
	    (compiler body env)
	    (if debug? (_label env elab))
	    (same-type env body e)
	    (for-each
	     (lambda (b) (env-free-local env (compile-type (car b) env)))
	     bindings) ))))

;;
(define (compiler-setq e::setq env::env)
   (out-line e env)
   (with-access::setq e (var value)
      (compile-expr value env)
      (same-type env value var)
      (let ( (variable (var-variable var)) )
	 (if (global? variable)
	     (begin
		(if *jvm-purify* (_checkcast env (compile-type variable env)))
		(_putstatic env (get-global-name env variable)) )
	     (_store env variable) ))))

;;
(define (compiler-sequence e::sequence env::env compiler)
   (out-line e env)
   (with-access::sequence e (nodes)
      (define (walk l next)
	 (if (null? next)
	     (begin
		(compiler (car l) env)
		(same-type env (car l) e) )
	     (begin (compile-effect (car l) env)
		    (walk next (cdr next)) )))
      (walk nodes (cdr nodes)) ))

;;
(define (compiler-if e::conditional env::env compiler)
   (out-line e env)
   (with-access::conditional e (test true false)
      (let ( (ltrue (gensym "L")) (lfalse (gensym "L")) (lcont (gensym "L")) )
	 (compile-predicate test ltrue lfalse env)
	 ; CARE I can't correct it
	 ; (check_type env test 'boolean)
	 (let ( (stack (env-stack env)) )
	    (_label env ltrue)
	    (compiler true env)
	    (same-type env true e)
	    (let ( (rstack (env-stack env)) )
	       (_goto env lcont)
	       (env-stack-set! env stack)
	       (_label env lfalse)
	       (compiler false env)
	       (same-type env false e)
	       (let ( (rrstack (env-stack env)) )
		  (if (and (not (null? rrstack)) (eq? (car rrstack) 'unknown))
		      (env-stack-set! env rstack) )
		  (_label env lcont) ))))))

;;
(define (compiler-select e::select env::env compiler)
   (out-line e env)
   (define (int? n) (or (fixnum? n) (char? n)))
   (with-access::select e (test clauses item-type)
      ; (tprint "SELECT STACK " (length (env-stack env)))
      (compile-expr test env)
      (check_type env test 'int)
      (if (every? (lambda (c) (or (eq? (car c) 'else)
				  (every? int? (car c)) ))
		  clauses )
	  (select-int env (compile-type item-type env) clauses compiler e)
	  (error "select" "not yet" (compile-type item-type env)) )))

(define (select-int env item-type clauses comp e)
   (define (num n)
      (cond ((fixnum? n) n)
	    ((char? n) (char->integer n))
	    (else (error "select" "bad item" n)) ))
   (if (eq? item-type 'long) (_l2i env))
   (let ( (ldef (gensym "L")) (lcont (gensym "L")) (d #f)
			      (num2lab '()) (lab2node '()) )
      (for-each
       (lambda (c)
	  (if (eq? (car c) 'else)
	      (set! d (cdr c))
	      (let ( (lab (gensym "L")) )
		 (for-each
		  (lambda (n) (set! num2lab (cons (cons (num n) lab) num2lab)))
		  (car c) )
		 (set! lab2node (cons (cons lab (cdr c)) lab2node)) )))
       clauses )
      (_switch env ldef num2lab)
      (let ( (stack (env-stack env)) )
	 (for-each (lambda (slot)
		      (_label env (car slot))
		      (env-stack-set! env stack)
		      (comp (cdr slot) env)
		      (same-type env (cdr slot) e)
		      (_goto env lcont) )
		   lab2node )
	 (_label env ldef)
	 (if d (begin (env-stack-set! env stack)
		      (comp d env)
		      (same-type env d e) ))
	 (_label env lcont) )))

;;
(define (compiler-labels e::let-fun env::env comp)
   (out-line e env)
   (with-access::let-fun e (locals body)
      (for-each
       (lambda (v)
	  (env-set-name! env v 'entry_labels)
	  (set! *lab2labels* (cons (cons v e) *lab2labels*)) )
       locals )
      (set! *labels2saved* (cons (cons e '()) *labels2saved*))
      (comp body env) ))

(define *labdone* '())
(define *lab2labels* '())
(define *labels2saved* '())

(define (compile-label-call.20dec02 local args env)
   ;; Called when an app node have a local variable as function
   (let ( (stk (env-stack env)) (regs '()) )
      (if (not (null? stk))
	  ;; ** To avoid bad SUN's JIT compilation **
	  ;; We known that we are at ONE loop entries
	  (let ( (main (cdr (assq local *lab2labels*))) )
	     (let ( (slot (assq main *labels2saved*)) )
		(if (null? (cdr slot))
		    ;; We are the first to do an entry loop.
		    (let ( (vars (map (lambda (ty) (env-alloc-local env ty))
				      stk )) )
		       (set-cdr! slot vars) ))
		;; We have the names of registers
		(set! regs (cdr slot))
		(for-each (lambda (v ty) (_store_name env v ty))
			  regs
			  stk ))))
      ;; Prepare arguments
      (for-each (lambda (e) (compile-expr e env)) args)
      ;; Do the call.
      (if (memq local *labdone*)
	  ;; Already generated : do a simple branch.
	  (_goto env (local-name local))
	  ;; Generate a label : args are on the stack
	  (with-access::local local (value)
	     (with-access::sfun value (args body)
		(set! *labdone* (cons local *labdone*))
		(let* ( (debug? (debug-for-declare-var? env))
			(blab (if debug? (gensym "F") '???))
			(elab (if debug? (gensym "T") '???)) )
		   (_label env (local-name local))
		   ;; Move args in parameters
		   (for-each
		    (lambda (arg)
		       (env-declare-new-local env arg)
		       (debug-declare-var-from env arg blab elab)
		       (_store env arg) )
		    (reverse args) )
		   ;; Compile body
		   (if debug? (_label env blab))
		   (if (null? stk)
		       (compile-tail body env)
		       (compile-expr body env) )
		   (if debug? (_label env elab))
		   ;; ** To avoid bad SUN's JIT compilation.
		   (if (not (null? stk))
		       (let ( (tr (car (env-stack env))) )
			  ;; Save the result.
			  (_store_name env 'reg1 tr)
			  ;; Restore the stack.
			  (for-each (lambda (v ty) (_load_name env v ty))
				    (reverse regs)
				    (reverse stk) )
			  ;; Restore the result.
			  (_load_name env 'reg1 tr) ))))))
      ;; What ever we done we have this stack..
      (with-access::local local (value)
	 (with-access::sfun value (args body)
	    (let ( (type (simple-type (compile-type (local-type local) env))) )
	       (env-stack-set! env (cons type stk)) )))))

(define (compile-label-call local args env)
   ;; Called when an app node have a local variable as function
   (for-each (lambda (e) (compile-expr e env)) args)
   (if (memq local *labdone*)
       ;; somebody else produced a continuation
       ;; cross your fingers that it was the same
       (with-access::local local (value)
	  (with-access::sfun value (args body)
	     (for-each (lambda (arg) (_store env arg)) (reverse args))
	     (let ( (stk (env-stack env)) )
		;; Dieu que ce code pue!!
		(if (null? stk)
		    (_goto env (local-name local))
		    (_goto env (symbol-append 'from_body (local-name local))) )
		(env-stack-set! env (cons 'unknown (env-stack env))) )))
       (with-access::local local (value)
	  (with-access::sfun value (args body)
	     (set! *labdone* (cons local *labdone*))
	     (let* ( (debug? (debug-for-declare-var? env))
		     (blab (if debug? (gensym "F") '???))
		     (elab (if debug? (gensym "T") '???)) )
		(if debug? (_label env blab))
		(for-each
		 (lambda (arg)
		    (env-declare-new-local env arg)
		    (debug-declare-var-from env arg blab elab)
		    (_store env arg) )
		 (reverse args) )
		(let* ( (stk (env-stack env))
			(vars (map (lambda (ty) (env-alloc-local env ty))
				   stk )) )
		   (_label env (symbol-append 'from_body (local-name local)))
		   (for-each (lambda (v ty) (_store_name env v ty))
			     vars
			     stk )
		   (_label env (local-name local))
		   ;; Continuation magically will follow <body>
		   (if (null? stk)
		       (compile-tail body env)
		       (compile-expr body env) )
		   (if debug? (_label env elab))
		   (if (not (null? stk))
		       (let ( (tr (car (env-stack env))) )
			  ; (tprint "LABELS STACK " (length stk))
			  (_store_name env 'reg1 tr)
			  (for-each (lambda (v ty) (_load_name env v ty))
				    (reverse vars)
				    (reverse stk) )
			  (_load_name env 'reg1 tr) ))
		   (for-each (lambda (ty) (env-free-local env ty)) stk) ))))))

;;
(define (compiler-app e::app env::env)
   (out-line e env)
   (with-access::app e (fun args)
      (let ( (v (var-variable fun)) )
	 (cond ((local? v)
		(compile-label-call v args env) )
	       ((special-call? v args env) 'done)
	       ((special-inline-call? v args env))
	       (else
		(let ( (types (type-args v env)) )
		   (for-each (lambda (e ty)
				(compile-expr e env)
				(if *jvm-purify* (_checkcast env ty)) )
			     args
			     types )
		   (or (inline-call? v env)
		       (how-to-call env v types) )))))))

(define (type-args v env)
   (with-access::global v (value)
      (map (lambda (x) (compile-type x env))
	   (if (sfun? value)
	       (sfun-args value)
	       (cfun-args-type value) )) ))

(define (how-to-call env var ta)
   (let ( (fun (variable-value var))
	  (target (get-global-name env var))
	  (tr (compile-type (global-type var) env)) )
      (cond
	 ((not (cfun? fun)) (_invokestatic env target ta tr))
	 ((string=? (variable-name var) "<init>")
	  (_invokespecial_init env target ta tr))
	 (else
	  (let ( (modifiers (cfun-method fun)) )
	     (cond
		((memq 'static modifiers) (_invokestatic env target ta tr))
		((memq 'abstract modifiers) (_invokeinterface env target ta tr))
		((memq 'final modifiers) (_invokespecial env target ta tr))
		((memq 'native modifiers) (_invokespecial env target ta tr))
		(else (_invokevirtual env target ta tr)) ))))))
	    
(define (special-call? var args env)
   ;; CARE Check modulename as foreign ?!?!
   (with-access::global var (id)
      (cond
	 ((or (eq? id 'make-fx-procedure)
	      (eq? id 'make-va-procedure) )
	  ;; INDEX::int, ARITY::int, SIZE::int
	  (_new env (env-current-module env))
	  (if *jvm-purify*
	      (begin (_dup env)
		     (_invokespecial env 'init0 '(ad) 'void) ))
	  (_dup env)
	  (compile-expr (car args) env)
	  (_putfield env (jlib-declare env 'procindex))
	  (_dup env)
	  (compile-expr (cadr args) env)
	  (_putfield env (jlib-declare env 'procarity))
	  (_dup env)
	  (compile-expr (caddr args) env)
	  (_newarray env (jlib-declare env 'jobject))
	  (_putfield env (jlib-declare env 'procenv))
	  #t )
	 ((eq? id 'make-l-procedure)
	  ;; index::int, size::int
	  (_new env (env-current-module env))
	  (if *jvm-purify*
	      (begin (_dup env)
		     (_invokespecial env 'init0 '(ad) 'void) ))
	  (_dup env)
	  (compile-expr (car args) env)
	  (_putfield env (jlib-declare env 'procindex))
	  (_dup env)
	  (compile-expr (cadr args) env)
	  (_newarray env (jlib-declare env 'jobject))
	  (_putfield env (jlib-declare env 'procenv))
	  #t )
	 ((eq? id 'cnst-table-ref)
	  ;; int -> obj
	  (_getstatic env 'constants)
	  (compile-expr (car args) env)
	  (_aload env 'jobject) )
	 ((eq? id 'cnst-table-set!)
	  ;; int obj -> obj
	  (_getstatic env 'constants)
	  (compile-expr (car args) env)
	  (compile-expr (cadr args) env)
	  (_astore env 'jobject)
	  (_getstatic env (jlib-declare env 'unspecified)) )
	 ((eq? id '__evmeaning_address)
	  ;; (__evmeaning_address global)
	  (if (not (var? (car args)))
	      (error "Jvm/EVMEANING_ADDRESS" "not a variable" (car args))
	      (let ( (v (var-variable (car args))) )
		 (if (global? v)
		     (let ( (i (env-new-getset env (get-global-name env v))) )
			(_new env (env-current-module env))
			(if *jvm-purify*
			    (begin (_dup env)
				   (_invokespecial env 'init0 '(ad) 'void) ))
			(_dup env)
			(_push env 'int i)
			(_putfield env (jlib-declare env 'procindex))
			#t )
		     (error "Jvm/EVMEANING_ADDRESS" "not a global" v) ))))
	 (else #f) )))

;;
(define (compiler-apply e::app-ly env::env)
   (out-line e env)
   (with-access::app-ly e (fun arg)
      (compile-expr fun env)
      (if *jvm-purify* (_checkcast env 'j_procedure))
      (compile-expr arg env)
      (_invokevirtual env (jlib-declare env 'apply) '(ad ad) 'ad) ))

;;
(define (compiler-funcall e::funcall env::env)
   (out-line e env)
   ;; CARE called twice somewhere
   (with-access::funcall e (fun args)
      ;; OUPS sometime arg1 != fun but fun is a GLOBAL fun !!!!!
      (if (and (var? fun)
	       (global? (var-variable fun))
	       (sfun? (global-value (var-variable fun))) )
	  (let ( (v (var-variable fun)) )
	     (for-each (lambda (e) (compile-expr e env))
		       (reverse! (cdr (reverse args))) )
	     (_invokestatic env (get-global-name env v)
			    (type-args v env)
			    (compile-type (global-type v) env) ))
	  (begin
	     (compile-expr fun env)
	     (if *jvm-purify* (_checkcast env 'j_procedure))
	     ;; forget arg1 which is fun and the last argument which is __eoa__
	     (let ( (args (reverse! (cdr (reverse (cdr args))))) )
		(for-each (lambda (e) (compile-expr e env)) args)
		(case (length args)
		   ((0) (_invokevirtual env (jlib-declare env 'funcall0)
					'(ad) 'ad) )
		   ((1) (_invokevirtual env (jlib-declare env 'funcall1)
					'(ad ad) 'ad) )
		   ((2) (_invokevirtual env (jlib-declare env 'funcall2)
					'(ad ad ad) 'ad) )
		   ((3) (_invokevirtual env (jlib-declare env 'funcall3)
					'(ad ad ad ad) 'ad) )
		   ((4) (_invokevirtual env (jlib-declare env 'funcall4)
					'(ad ad ad ad ad) 'ad) )
		   (else
		    (_getstatic env (jlib-declare env 'nil))
		    (jlib-declare env 'cons)
		    (for-each
		     (lambda (a) (_invokestatic env 'cons '(ad ad) 'ad))
		     args )
		    (_invokevirtual env (jlib-declare env 'apply)
				    '(ad ad) 'ad ))))))))

;;
(define (compiler-pragma e::pragma env::env)
   (out-line e env)
   (with-access::pragma e (format expr*)
      (cond
	 ((equal? format "PTR_ALIGNMENT")  ;; vital.scm
	  (_invokestatic env (jlib-declare env 'ptr_alg) '()
			 (if *longislong* 'long 'int) ))
	 (else
	  (error "pragma" "ya pas en jvm" (cons format expr*)) ))))

;;
(define (compiler-getfield e::getfield env::env)
   (out-line e env)
   (with-access::getfield e (expr* fname ftype otype)
      (compile-expr (car expr*) env)
      (if *jvm-purify* (_checkcast env (compile-type-nowidening otype env)))
      (_getfield env
		 (compile-type ftype env)
		 (env-declare-field env
				    fname
				    (compile-type ftype env)
				    (compile-type-nowidening otype env) ))))

;;
(define (compiler-setfield e::setfield env::env)
   (out-line e env)
   (with-access::setfield e (expr* fname ftype otype)
      (compile-expr (car expr*) env)
      (if *jvm-purify* (_checkcast env (compile-type-nowidening otype env)))
      (compile-expr (cadr expr*) env)
      (if *jvm-purify* (_checkcast env (compile-type ftype env)))
      (_putfield env (env-declare-field env fname
					(compile-type ftype env)
					(compile-type-nowidening otype env) ))))

;;
(define (compiler-new e::new env::env)
   (out-line e env)
   (let ( (type (compile-type-nowidening (typeof e) env)) (expr* (new-expr* e)) )
      (_new env type)
      ;; CARE Seems to be ok now
      (if (and *jvm-purify* (not (jclass? (typeof e))))
	  (begin
	     (_dup env)
	     (_invokespecial env (env-declare-init env type) '(ad) 'void) ))))

;;
(define (compiler-valloc e::valloc env::env)
   (out-line e env)
   (with-access::valloc e (expr* ftype)
      (compile-expr (car expr*) env)
      (_newarray env (compile-type ftype env)) ))

;;
(define (compiler-vref e::vref env::env)
   (out-line e env)
   (with-access::vref e (expr* ftype)
      (let ( (type (compile-type ftype env)) )
	 (compile-expr (car expr*) env)
	 (if *jvm-purify* (_checkcast env `(vector ,type)))
	 (compile-expr (cadr expr*) env)
	 (_aload env type) )))

;;
(define (compiler-vset e::vset! env::env)
   (out-line e env)
   (with-access::vset! e (expr* ftype)
      (let ( (type (compile-type ftype env)) )
	 (compile-expr (car expr*) env)
	 (if *jvm-purify* (_checkcast env `(vector ,type)))
	 (compile-expr (cadr expr*) env)
	 (compile-expr (caddr expr*) env)
	 (if *jvm-purify* (_checkcast env type))
	 (_astore env type) )))

;;
(define (compiler-vlength e::vlength env::env)
   (out-line e env)
   (with-access::vlength e (expr* vtype)
      (compile-expr (car expr*) env)
      (if *jvm-purify* (_checkcast env (compile-type vtype env)))
      (_arraylength env) ))

;;
(define (compiler-isa e::isa env::env)
   (out-line e env)
   (with-access::isa  e (expr* class)
      (compile-expr (car expr*) env)
      (_instanceof env (compile-type class env)) ))

;;
(define (compiler-cast e::cast env::env comp)
   (out-line e env)
   (with-access::cast e (arg)
      (comp arg env) ))

;;
(define (compiler-setexit e::set-ex-it env::env comp)
   (out-line e env)
   (with-access::set-ex-it e (var body)
      (let ( (local (var-variable var)) )
	 (_invokestatic env (jlib-declare env 'setexit) '() 'ad)
	 (_store env (env-declare-new-local env local))
	 (let ( (beg (gensym "HB"))
		(end (gensym "HE"))
		(lab (gensym "HD"))
		(cont (gensym "L")) )
	    (_handler env beg end lab (jlib-declare env 'j_bexception))
	    (_label env beg)
	    (comp body env)
	    (_label env end)
	    (let ( (stack (env-stack env)) )
	       (_goto env cont)
	       (_label env lab)
	       (env-stack-set! env '(ad))
	       (_load env (var-variable var))
	       ;; CARE !! bad signature of setexit
	       (if *jvm-purify* (_checkcast env (jlib-declare env 'j_exit)))
	       (_invokestatic env (jlib-declare env 'debug_handler)
			      '(ad ad) 'ad )
	       ;; CARE not clean
	       (env-stack-set! env stack)
	       (_label env cont) )))))

;;
(define (compiler-jump-exit e::jump-ex-it env::env)
   (out-line e env)
   (with-access::jump-ex-it e (exit value)
      (compile-expr exit env)
      (compile-expr value env)
      (_invokestatic env (jlib-declare env 'jumpexit) '(ad ad) 'ad) ))

;;
(define (compiler-fail e::fail env::env)
   (out-line e env)
   (with-access::fail e (proc msg obj)
      (compile-expr proc env)
      (compile-expr msg env)
      (compile-expr obj env)
      (_invokestatic env (jlib-declare env 'fail) '(ad ad ad) 'ad)
      (_athrow env) ))

;;
(define (compiler-make-box e::make-box env::env)
   (out-line e env)
   (with-access::make-box e (value)
      (_new env (compile-type 'cell env))
      (_dup env)
      (compile-expr value env)
      (if *jvm-purify*
	  (_invokespecial env (jlib-declare env 'init_cell) '(ad ad) 'void)
	  (_putfield env (jlib-declare env 'ccar)) )))

;;
(define (compiler-box-ref e::box-ref env::env)
   (out-line e env)
   (with-access::box-ref e (var)
      (_load env (var-variable var))
      (if *jvm-purify* (_checkcast env 'j_cell))
      (_getfield env 'jobject (jlib-declare env 'ccar)) ))

;;
(define (compiler-box-set! e::box-set! env::env)
   (out-line e env)
   (_load env (var-variable (box-set!-var e)))
   (if *jvm-purify* (_checkcast env 'j_cell))
   (compile-expr (box-set!-value e) env)
   (_putfield env (jlib-declare env 'ccar)) )
