(module jvm_env
   (import type_type type_typeof ast_var ast_node engine_param
	   module_module     ; *module*
	   object_class      ; tclass
	   tvector_tvector   ; tvect
	   foreign_jtype     ; jarray
	   tools_shape       ; shape
	   jvm_extern )
   (export
    (class env
       (declarations (default '()))
       (declaredtype (default '()))
       (declaredclass (default '()))
       (declaredmodule (default '()))
       (current-module (default '()))
       (declaredfields (default '()))
       (declaredglobal (default '()))
       (libdeclared (default '()))
       (procedures (default '()))
       (clinit-code (default '()))
       (current-method (default '()))
       (vcount (default 0))
       (locals (default '()))
       (freelocals (default '()))
       (maplocals (default '()))
       (stack (default '()))
       (code (default '())) )
   
   *longislong*
   (compile-type v env::env)
   (env-declare env::env name::symbol decl)
   (env-declare-current-module env::env)
   (env-declare-module env::env module::symbol)
   (env-declare-class env class::tclass)
   (env-declare-init env class)
   (env-declare-type env type::symbol)
   (env-declare-field env fname::bstring ftype otype::symbol)
   (get-global-name env::env var::global)
   (env-declare-local env::env var::local)
   (env-declare-new-local env::env var::local)
   (env-free-local env::env type)
   (env-set-name! env::env var::local name::symbol)
   (env-new-procedure env::env arity name::symbol)
   (env-new-getset env::env name::symbol)
   (env-get-procedures env::env)
   (jlib-declare env::env name::symbol)
   (env-alloc-local env::env type)
   (compile-type-nowidening v env::env)))

(define *longislong* #f)

;;;
;;; Compiling a type
;;;
(define **basic-type**
   '((bool . boolean)
     (char . byte)
     (uchar . int)
     (ucs2 . char)
     (void . void)
     (int . int)
     (short . short)     ;; MANUEL SERRANO (7 Apr 2003)
     (elong . long)      ;; MANUEL SERRANO (6 oct 2002)
     (llong . long)
     (float . float)
     (double . double)
     (magic . jobject)
     (obj . jobject)
     (pair-nil . jobject)
     (vector . (vector jobject))
     (bstring . (vector byte))
     (ucs2string . (vector char))
     (string . (vector byte))
     ))

(define (compile-type v env::env)
   (let ((actual-type (if (wide-class? v)
			  (tclass-its-super v)
			  v)))
      (compile-type-nowidening actual-type env)))

(define (compile-type-nowidening v env::env)
   (cond
      ((assq v **basic-type**) => cdr)
      ((eq? v 'long) (if *longislong* 'long 'int))
      ((eq? v 'ulong) (if *longislong* 'long 'int))
      ((eq? v 'jstring) 'jstring)
      ((eq? v 'output-port) (compile-type 'output_port env))
      ((eq? v 'input-port) (compile-type 'input_port env))
      ((eq? v 'binary-port) (compile-type 'binary_port env))
      ((eq? v 'procedure-el) (compile-type 'procedure env))
      ((eq? v 'procedure-el1) (compile-type 'procedure env))
      ((eq? v 'cnst*) '(vector jobject))
      ((eq? v 'void*) 'jobject)
      ((eq? v 'epair)
       (jlib-declare env 'j_extended_pair) )
      ((symbol? v)
       (env-declare-type env v) )
      ((node? v)
       (compile-type (typeof v) env) )
      ((variable? v)
       (let ( (tt (manu-tu-fixes-global-tvector v)) )
	  (if tt
	      (begin
		 ;(print "GOTCHA " (compile-type tt env)
		 ;	" <- " (compile-type (variable-type v) env) )
		 `(vector ,(compile-type tt env)) )
	      (compile-type (variable-type v) env) )))
      ((tclass? v)
       (env-declare-class env v) )
      ((tvec? v)
       `(vector ,(compile-type (tvec-item-type v) env)) )
      ((jarray? v)
       `(vector ,(compile-type (jarray-item-type v) env)) )
      ((type? v)
       (compile-type (type-id v) env) )
      ((pair? v) v)
      (else (error "compile-type" "unknown value type" v)) ))

;;;
;;; Declaration by hand
;;;
(define (env-declare env::env name::symbol decl)
   (with-access::env env (declarations)
      (set! declarations (cons (list name decl) declarations)) ))
   
;;;
;;; Modules
;;;
(define (env-declare-current-module env::env)
   ;; called once in compile.scm
   (let ( (r (env-declare-module env *module*)) )
      (env-current-module-set! env r)
      r ))
   
(define (env-declare-module env::env module::symbol)
   ;; called in init.scm to have the owner of a static field/method
   (with-access::env env (declarations declaredmodule)
      (let ( (slot (assq module declaredmodule)) )
	 (if slot
	     (cdr slot)
	     (let ( (name (symbol-append 'c_ module)) )
		(set! declarations
		      (cons `(,name (class (super public)
				       ,(qualified-module-name module) ))
			    declarations ))
		(set! declaredmodule (cons (cons module name) declaredmodule))
		name )))))

;;;
;;; Classes
;;;
(define (env-declare-class env class::tclass)
   ;; called by compile-type, compiler-new
   (with-access::env env (declarations declaredclass)
      (let ( (slot (assq class declaredclass)) )
	 (if slot
	     (cdr slot)
	     (let ( (name (symbol-append 'k_ (tclass-id class))) )
		(set! declarations
		      (cons `(,name (class (super public)
				       ,(qualified-class-name class) ))
			    declarations ))
		(set! declaredclass (cons (cons class name) declaredclass))
		name )))))

(define (env-declare-init env type)
   (let* ( (name (symbol-append 'init_ type)) )
      (with-access::env env (declarations)
	 (let ( (slot (assq name declarations)) )
	    (if (not slot)
		(set! declarations
		      (cons `(,name (method ,type () void "<init>"))
			    declarations )))
	    name ))))

;;;
;;; Types
;;;
(define (env-declare-type env type::symbol)
   ;; called by compile-type with symbolic types (i.e. 'pair)
   ;;        by global-cfun-declaration with jvm-type-name field of a global
   (with-access::env env (declarations declaredtype)
      (let ( (slot (assq type declaredtype)) )
	 (if slot
	     (cdr slot)
	     (let ( (name (symbol-append 't_ type)) )
		(set! declarations
		      (cons `(,name (class (super public)
				       ,(packaged-type-name type) ))
			    declarations ))
		(set! declaredtype (cons (cons type name) declaredtype))
		name )))))

;;;
;;; Fields
;;;
(define (env-declare-field env fname::bstring ftype otype::symbol)
   ;; called in compile.scm to export fields of a class being compiled
   ;;        in compiler.scm for get/putfield
   (with-access::env env (declaredfields)
      (let ( (slot (assq otype declaredfields)) )
	 (if slot
	     (let ( (reslot (assoc fname (cdr slot))) )
		;; CARE fname is string => assoc
		(if reslot
		    (cdr reslot)
		    (env-declare-field! env fname ftype otype) ))
	     (env-declare-field! env fname ftype otype) ))))

(define (env-declare-field! env fname::bstring ftype otype::symbol)
   ;; CARE Strange all fields are public ?!
   (with-access::env env (declarations declaredfields)
      (let ( (name (symbol-append 'f_ otype '_ (string->symbol fname))) )
	 (set! declarations
	       (cons `(,name (field ,otype (public) ,ftype ,fname))
		      declarations ))
	 (let ( (slot (assq otype declaredfields)) )
	    (if slot
		(set-cdr! slot (cons (cons fname name) (cdr slot)))
		(set! declaredfields (cons (list otype (cons fname name))
					   declaredfields ))))
	 name )))

;;;
;;; Global variables
;;;
(define (get-global-name env::env var::global)
   ;; Declaration is done in init.scm
   (let ( (slot (assq var (env-declaredglobal env))) )
      (if slot
	  (cdr slot)
	  (error 'compiler "global variable not declared" (shape var)) )))

;;;
;;; Local variables
;;;
(define (env-declare-new-local env::env var::local)
   (env-set-name! env var 'L)
   (let ( (name (local-name var)) (type (compile-type var env)) )
      (with-access::env env (locals)
	 (if (memq type '(double long))
	     (set! locals (cons* '_ name locals))
	     (set! locals (cons name locals)) ))
      var ))

(define (env-declare-local env::env var::local)
   (env-set-name! env var 'L)
   (alloc-in-free env (local-name var) (compile-type var env))
   var )

(define (env-alloc-local env::env type)
   (let ( (name (gensym "save")) )
      (alloc-in-free env name type)
      name ))

(define (alloc-in-free env::env name::symbol type)
   (if (memq type '(double long))
       ;; Since its hard to discover consecutive free regs no sweet reg
       ;; allocation for double word...
       (with-access::env env (locals)
	  (set! locals (cons* '_ name locals)) )
       (with-access::env env (locals freelocals maplocals)
	  (if (null? freelocals)
	      (begin
		 (set! locals (cons name locals))
		 (set! maplocals (cons (cons name name) maplocals)) )
	      (let ( (reg (car freelocals)) )
		 (set! maplocals (cons (cons name reg) maplocals))
		 (set! freelocals (cdr freelocals)) )))))

(define (env-free-local env::env type)
   (if (memq type '(double long))
       #unspecified
       (with-access::env env (freelocals maplocals)
	  (set! freelocals (cons (cdar maplocals) freelocals))
	  (set! maplocals (cdr maplocals)) )))

(define (env-set-name! env::env var::local name::symbol)
   (with-access::env env (vcount)
      (local-name-set! var
		       (string->symbol
			(string-append (symbol->string name)
				       (number->string vcount) )))
      (set! vcount (+ vcount 1)) ))

;;;
;;; Procedures
;;;
(define (env-new-procedure env::env arity name::symbol)
   (with-access::env env (procedures)
      (cond
	 ((assq name procedures) => cadr)
	 (else
	  (let ( (n (length procedures)) )
	     ;; CARE saving <n> seems useless
	     (set! procedures (cons (cons* name n arity) procedures))
	     n )))))

(define (env-new-getset env::env name::symbol)
   (with-access::env env (procedures)
      (cond
	 ((assq name procedures) => cadr)
	 (else
	  (let ( (n (length procedures)) )
	     ;; CARE not very clean
	     (set! procedures (cons (cons* name n '()) procedures))
	     n )))))


(define (env-get-procedures env::env)
   (reverse (env-procedures env)) )

;;;
;;; All external Java needed by the compiler
;;;
(define **jlib-common** `(
   (jobject (class () "java.lang.Object"))
   (jstring (class () "java.lang.String"))
   (jrunexcept (class () "java.lang.RuntimeException"))
   (jthrowable (class () "java.lang.Throwable"))
   (math (class () "java.lang.Math"))
   (j_foreign (class () ,*jvm-foreign-class-name*))
   (j_nil (class () "bigloo.nil"))
   (j_bbool (class () "bigloo.bbool"))
   (j_bchar (class () "bigloo.bchar"))
   (bchar_value (field j_bchar () byte "value"))
   (j_bucs2 (class () "bigloo.bucs2"))
   (bucs2_value (field j_bucs2 () char "value"))
   (init_bucs2 (method j_bucs2 () void "<init>" char))
   (j_elong (class () "bigloo.belong"))
   (make_elong (method j_elong (static) j_elong "make_elong" jstring))
   (j_llong (class () "bigloo.bllong"))
   (make_llong (method j_llong (static) j_llong "make_llong" jstring))
   (j_bint (class () "bigloo.bint"))
   (j_real (class () "bigloo.real"))
   (real_value (field j_real () double "value"))
   (init_real (method j_real () void "<init>" double))
   (j_cnst (class () "bigloo.cnst"))
   (cnst_value (field j_cnst () int "value"))
   (j_eof (class () "bigloo.eof"))
   (j_optional (class () "bigloo.optional"))
   (j_rest (class () "bigloo.rest"))
   (j_key (class () "bigloo.key"))
   (key_string (field j_keyword () (vector byte) "string"))
   (j_unspecified (class () "bigloo.unspecified"))
   (j_procedure (class () "bigloo.procedure"))
   (procindex (field j_procedure () int "index"))
   (procarity (field j_procedure () int "arity"))
   (procenv (field j_procedure () (vector jobject) "env"))
   (funcall0 (method j_procedure () jobject "funcall0"))
   (funcall1 (method j_procedure () jobject "funcall1" jobject))
   (funcall2 (method j_procedure () jobject "funcall2" jobject jobject))
   (funcall3 (method j_procedure () jobject "funcall3" jobject jobject
		     jobject ))
   (funcall4 (method j_procedure () jobject "funcall4" jobject jobject
		     jobject jobject ))
   (apply (method j_procedure () jobject "apply" jobject))
   (j_keyword (class () "bigloo.keyword"))
   (j_bexception (class () "bigloo.bexception"))
   (j_symbol (class () "bigloo.symbol"))
   (symbol_string (field j_symbol () (vector byte) "string"))
   (j_exit (class () "bigloo.exit"))
   (j_cell (class () "bigloo.cell"))
   (init_cell (method j_cell () void "<init>" jobject))
   (ccar (field j_cell () jobject "car"))
   (j_pair (class () "bigloo.pair"))
   (init_pair (method j_pair () void "<init>"))
   (car (field j_pair () jobject "car"))
   (cdr (field j_pair () jobject "cdr"))
   (cons (method j_pair () j_pair "cons" jobject jobject))
   (j_extended_pair (class () "bigloo.extended_pair"))
   (init_extended_pair (method j_extended_pair () void "<init>"))
   (cer (field j_extended_pair () jobject "cer"))
   (j_struct (class () "bigloo.struct"))
   (struct_key (field j_struct () jobject "key"))
   (struct_values (field j_struct () (vector jobject) "values"))
   (j_object (class () "bigloo.object"))
   (widening (field j_object () jobject "widening"))
   (header (field j_object () int "header"))
   (j_input (class () "bigloo.input_port"))
   (io_name (field j_input () jstring "name"))
   (io_filepos (field j_input () int "filepos"))
   (io_bufsiz (field j_input () int "bufsiz"))
   (io_other_eof (field j_input () boolean "other_eof"))
   (io_start (field j_input () int "matchstart"))
   (io_stop (field j_input () int "matchstop"))
   (io_forward (field j_input () int "forward"))
   (io_lastchar (field j_input () byte "lastchar"))
   (io_abufsiz (field j_input () int "abufsiz"))
   (io_buffer (field j_input () (vector byte) "buffer"))
   (nil (field j_nil (static) j_nil "nil"))
   (eof (field j_eof (static) j_eof "eof"))
   (optional (field j_optional (static) j_optional "optional"))
   (rest (field j_rest (static) j_rest "rest"))
   (key (field j_key (static) j_key "key"))
   (unspecified (field j_unspecified (static) j_unspecified "unspecified"))
   (bchar_allocated (field j_bchar (static) (vector j_bchar) "allocated"))
   (faux (field j_bbool (static) j_bbool "faux"))
   (vrai (field j_bbool (static) j_bbool "vrai"))
   (print (method j_foreign (static) void "print" jstring))
   (eqbint (method j_foreign (static) boolean "eqbint" jobject jobject))
   (setexit (method j_foreign (static) jobject "setexit"))
   (jumpexit (method j_foreign (static) jobject "jumpexit" jobject jobject))
   (fail (method j_foreign (static) jrunexcept "fail" jobject jobject jobject))
   (internalerror (method j_foreign (static) void "internalerror" jthrowable))
   (debug_handler
    (method j_foreign (static) jobject "debug_handler" j_bexception j_exit) )
   (double_to_real (method j_foreign (static) j_real "DOUBLE_TO_REAL" double))
   (listargv (method j_foreign (static) jobject "listargv" (vector jstring)))
   (getbytes (method jstring () (vector byte) "getBytes"))
   (concat (method jstring () jstring "concat" jstring))
   (floor (method math (static) double "floor" double))
   (ceil (method math (static) double "ceil" double))
   (exp (method math (static) double "exp" double))
   (log (method math (static) double "log" double))
   (sin (method math (static) double "sin" double))
   (cos (method math (static) double "cos" double))
   (tan (method math (static) double "tan" double))
   (asin (method math (static) double "asin" double))
   (acos (method math (static) double "acos" double))
   (atan (method math (static) double "atan" double))
   (atan2 (method math (static) double "atan2" double double))
   (sqrt (method math (static) double "sqrt" double))
   (pow (method math (static) double "pow" double double))

   ))

(define **jlib32**
   (append '((bint_value (field j_bint () int "value"))
	     (ptr_alg (method j_foreign (static) int "ptr_alg")) )
	   **jlib-common** ))

(define **jlib64**
   (append '((bint_value (field j_bint () long "value"))
	     (ptr_alg (method j_foreign (static) long "ptr_alg")) )
	   **jlib-common** ))

(define (jlib-declare env::env name::symbol)
   (with-access::env env (libdeclared declarations)
      (if (memq name libdeclared)
	  name
	  (let ( (slot (assq name (if *longislong* **jlib64** **jlib32**))) )
	     (if (not slot)
		 (error 'jlib "unknown entry point" name)
		 (begin
		    (jlib-rec-decl env (cadr slot))
		    (set! libdeclared (cons name libdeclared))
		    (set! declarations (cons slot declarations))
		    name ))))))

(define (jlib-rec-decl env::env decl)
   (match-case decl
      ((class ?- ?-)
       'ok )
      ((field ?class ?- ?type ?-)
       (jlib-declare env class)
       (jlib-declare-type env type) )
      ((method ?class ?- ?tret ?- . ?targs)
       (jlib-declare env class)
       (jlib-declare-type env tret)
       (for-each (lambda (t) (jlib-declare-type env t)) targs) )
      (else (error 'jlib "bad declaration" decl)) ))

(define (jlib-declare-type env t)
   (cond
      ((memq t '(void boolean char byte short int long float double))
       'ok )
      ((pair? t)
       (jlib-declare-type env (cadr t)) )
      (else
       (jlib-declare env t) )))

