(module jvm_init
   (include "Tvector/tvector.sch")  ; a-tvector-vector
   (import type_type ast_var ast_node
	   object_class    ; tclass
	   type_env        ; sub-type?
	   type_cache      ; *obj*
	   ast_env         ; for-each-global!
	   module_module   ; *module*
	   tvector_tvector ; tvect
	   cnst_alloc      ; get-cnst-offset
	   cnst_node       ; get-node-atom-value
	   jvm_extern jvm_env jvm_instr
	   )
   (export compile-init) )

(define (compile-init globals)
   (let ( (env (instantiate::env)) )
      (env-declare-current-module env)
      (jlib-declare env 'jobject)
      (jlib-declare env 'jstring)
      (jlib-declare env 'j_foreign)
      (jlib-declare env 'nil)
      (jlib-declare env 'cons)
      (jlib-declare env 'procindex)
      (jlib-declare env 'car)
      (jlib-declare env 'cdr)
      (for-each-global! (lambda (global) (env-declare-global env global)))
      (for-each-global! (lambda (global) (analyse-init env global)))
      (env-clinit-code-set! env (env-code env))
      env ))

;;
;; Declaration of a global
;;
(define (env-declare-global env global)
   (if (global-to-be-declared global)
       (with-access::env env (declarations declaredglobal)
	  (if (assq global declaredglobal)
	      (error 'compiler "global variable reclaration" global) )
	  (with-access::global global (id module)
	     (let ( (name (symbol-append 'g_ module '_ id)) )
		(set! declarations
		      (cons `(,name ,(global-declaration env global))
			    declarations ))
		(set! declaredglobal
		      (cons (cons global name) declaredglobal) ))))
       'ok ))

(define (global-declaration env global)
   (let ( (value (global-value global)) )
      (cond
	 ((or (svar? value) (cvar? value) (scnst? value))
	  (global-var-declaration env global) )
	 ((sfun? value)
	  (global-sfun-declaration env global) )
	 ((cfun? value)
	  (global-cfun-declaration env global) )
	 (else (error "global-declaration" "bad value" value)) )))

;; Global variable
(define (global-var-declaration env global)
   (with-access::global global (module import type name id)
      `(field
	,(env-declare-module env module)
	,(declare-field-modifiers import)
	;; CARE give global for tvector
	,(compile-type global env)
	,(real-field-name global) )))

(define (declare-field-modifiers decl)
   (case decl
      ((import foreign) '(static))
      ((static) '(private static))
      ((export) '(public static))
      (else (print "declare-modifiers" " : unknown declaration : " decl)
	    '() )))

;; Global sfun
(define (global-sfun-declaration env global)
   (with-access::global global (module import type name id value)
      `(method
	,(env-declare-module env module)
	,(case import
	    ((import foreign) '(static))
	    ((static) '(private static))
	    ((export) '(public static))
	    (else (error "declaration" "unknown modifier" import)) )
	,(compile-type type env)
	,(real-sfun-name global)
	,@(map (lambda (x) (compile-type x env)) (sfun-args value)) )))

;; Global cfun
(define (global-cfun-declaration env global)
   (with-access::global global (value module type name)
      (let ( (modifiers (cfun-method value))
	     (args (map (lambda (x) (compile-type x env))
			(cfun-args-type value) )) )
	 `(method
	   ,(cond
	       ((memq 'static modifiers) (env-declare-module env module))
	       (else (car args)) )
	    ,(if (eq? modifiers 'plain) '(public) modifiers)
	    ,(compile-type type env)
	    ,(real-cfun-name global)
	    ,@(cond
		((memq 'static modifiers) args)
		(else (cdr args)) )))))

;;
;; Initialization of a global
;;
(define (analyse-init env global)
   (with-access::global global (module type id value removable occurrence)
      (cond
	 ((not (eq? module *module*)) 'ok)
	 ((eq? id '__cnsts_table)
	  (let ( (n (get-cnst-offset)) )
	     (if (> n 0)
		 (begin
		    (_push env 'int n)
		    (_newarray env 'jobject)
		    (_putstatic env 'constants) ))))
	 ((not (global-to-be-declared global)) 'ok)
	 ((svar? value)
	  (if (and (or (> occurrence 0) (eq? removable 'never))
		   (sub-type? type *obj*) )
	      (begin
		 ;(_GETSTATIC env (jlib-declare env 'unspecified))
		 ; CARE !!
		 (_aconst_null env)
		 (_putstatic env (get-global-name env global)) )))
	 ((or (sfun? value)
	      (cfun? value)
	      (cvar? value))
	  'ok )
	 ((scnst? value)
	  (with-access::scnst value (class node)
	     (case class
		((sstring)
		 (emit-cnst-string env node global))
		((sreal)
		 (emit-cnst-real env node global))
		((sfun)
		 (emit-cnst-sfun env node global))
		((sgfun)
		 (emit-cnst-sgfun env node global))
		((stvector)
		 (emit-cnst-stvector env node global))
		(else (error "analyse-init" "Unknown cnst class" class)) )
	     (_putstatic env (get-global-name env global)) ))
	 (else (error "analyse-init" "unknown value type" value)) )))

(define (emit-cnst-string env str global)
   ;; CARE ?  (str (string-for-read ostr))
   (create-string env str) )

(define (emit-cnst-real env real global)
   (_push env 'double real)
   (_invokestatic env (jlib-declare env 'double_to_real) '(double) 'ad) )

(define (emit-cnst-sfun env fun global)
   (let* ((actuals (app-args fun))
	  (entry   (car actuals))
	  (arity   (get-node-atom-value (cadr actuals)))
	  (name    (variable-name (var-variable entry))))
      (_new env (env-current-module env))
      (_dup env)
      (_push env 'int (env-new-procedure
		       env
		       arity
		       (get-global-name env (var-variable entry) )))
      (_push env 'int arity)
      ;; CARE name declared in special.scm
      (_invokespecial env 'init2 '(int int) 'void) ))

(define (emit-cnst-sgfun env fun global)
   (let* ((actuals (app-args fun))
	  (entry   (car actuals))
	  (arity   (atom-value (cadr actuals)))
	  (name    (variable-name (var-variable entry))))
      (_new env (env-current-module env))
      (_dup env)
      (_push env 'int (env-new-procedure
		       env
		       arity
		       (get-global-name env (var-variable entry) )))
      (_push env 'int arity)
      (_push env 'int 3)
      ;; CARE name declared in special.scm
      (_invokespecial env 'init3 '(int int int) 'void) ))

(define (emit-cnst-stvector env tvec global)
   (let* ( (vec   (a-tvector-vector tvec))
	   (itype (tvec-item-type (a-tvector-type tvec)))
	   (type (compile-type itype env))
	   (n (vector-length vec)) )
      (_push env 'int n)
      (_newarray env type)
      (stvector-init env vec type 0 n) ))

(define (stvector-init env v type i n)
   (if (=fx i n)
       'ok
       (begin
	  (_dup env)
	  (_push env 'int i)
	  (_push env type (vector-ref v i))
	  (_astore env type)
	  (stvector-init env v type (+fx i 1) n) )))
