(module jvm_compile
   (import type_type ast_var ast_node engine_param
	   object_class     ; tclass
	   object_slots     ; slot
	   ast_env          ; find-global
	   module_module    ; *module*
	   jvm_extern jvm_env jvm_instr jvm_expr jvm_compiler
	   jvm_init jvm_constr jvm_closure
	   jvm_prelude jvm_peephole jvm_compress jvm_lisp
	   )
   (export (jvm-compile globals))
   )

(define (jvm-compile globals)
      (compile globals) )

   
;;
;; AST to assembler
;;
(define (compile globals)
   (let ( (m (compile-module globals)) )
      (cons m (map compile-class (get-classes-to-be-compiled))) ))

;;;
;;; Compiling a classe
;;;
(define (compile-class class)
   (let* ( (env (instantiate::env))
	   (_ (jlib-declare env 'jobject))
           (me (compile-type-nowidening class env))
           (super (if (wide-class? class)
		      'jobject
		      (compile-type (tclass-its-super class) env)))
	   (fields (compile-class-fields env class me)) )
      ;; first element is used only by jdump to got the classfile name...
     `((class ,(tclass-id-mangling class))
       ,me ,super ()
        (declare
	   ,@(reverse (env-declarations env))
	   (init0 (method ,me (public) void "<init>"))
	   (sinit0 (method ,super (public) void "<init>")) )
	(fields ,@fields)
	(method init0 (t) ()
		(aload t)
		(invokespecial sinit0)
		(return) ))))


(define (compile-class-fields env class owner)
   (let ( (r '()) )
      (for-each (lambda (slot)
		   (let ( (type (compile-type (get-slot-type slot) env)) )
		      (if (and (not (slot-virtual? slot))
			       (eq? class (slot-class-owner slot)) )
			  (let ( (name (slot-name slot)) )
			     (set! r (cons 
				      (env-declare-field env name type owner)
				      r ))))))
		(tclass-slots class) )
      r ))

(define (get-slot-type slot)
   (or (slot-indexed slot) (slot-type slot)) )

;;;
;;; Compiling a module
;;;
(define (compile-module globals)
   (let* ( (env (compile-init globals))
	   (me (env-current-module env))
	   (super (jlib-declare env 'j_procedure))
	   (main (compile-main env))
	   (dlopen (compile-dlopen env))
	   (funs (map (lambda (v) (compile-globalfun v env)) globals))
	   (constructors (jvm-constructors env me super))
	   (funcallers (jvm-funcallers env me super)) )
      (jlib-declare env 'jstring)
      `(module ,me ,super ()
	       (declare
		,@(reverse (env-declarations env))
		(__the_module_name__ (field ,me (public static)
					    jstring "__the_module_name__" ))
		(constants (field ,me (public static)
				  (vector jobject) "constants") ))
	       (fields constants __the_module_name__ ,@(compile-fields env))
	       (sourcefile ,(get-sourcefile))
	       (sde ,(get-sourcefile) ,(car *src-files*))
	       ,@constructors
	       ,@funcallers
	       ,@main
	       ,@dlopen
	       ,@funs )))

(define (compile-main env)
   (if (global? *main*)
       (let ( (name (gensym "main")) )
	  (jlib-declare env 'listargv)
	  (env-declare env name
	     `(method ,(env-current-module env)
		      (public static) void "main" (vector jstring)) )
	  (if *jvm-catch*
	      `((method ,name (argv) ()
			(handler from to catch ,(jlib-declare env 'jthrowable))
			from
			(aload argv)
			(invokestatic listargv)
			(invokestatic ,(get-global-name
					env
					(find-global 'bigloo_main *module*) ))
			(pop)
			to
			(return)
			catch
			(invokestatic ,(jlib-declare env 'internalerror))
			(return)
			))
	      `((method ,name (argv) ()
			(aload argv)
			(invokestatic listargv)
			(invokestatic ,(get-global-name
					env
					(find-global 'bigloo_main *module*) ))
			(pop)
			(return)))))
       '() ))

(define (compile-dlopen env)
   (let ( (name (gensym "BGL_DYNAMIC_LOAD_INIT")) )
      (env-declare env name
	 `(method ,(env-current-module env)
		  (public static) void "BGL_DYNAMIC_LOAD_INIT") )
      `((method ,name () ()
		(iconst_0)
		(aconst_null)
		(invokestatic ,(get-global-name
		      env
		      (find-global 'module-initialization *module*) ))
		(pop)
		(return)))))
   
(define (compile-fields env)
   (let ( (r '()) (me (env-current-module env)) )
      (for-each
       (lambda (slot)
	  (let ( (val (cadr slot)) )
	     (if (and (eq? (car val) 'field)
		      (eq? (cadr val) me) )
		 (set! r (cons (car slot) r)) )))
       (env-declarations env) )
      r ))

;;
;; Compiling a method
;;

(define (compile-globalfun var env)
   (let ( (m (compile-globalfun1 var env)) )
      (jvm_peephole m)
      m ))

(define (compile-globalfun1 var env)
   (with-access::global var (type module import value)
      (with-access::sfun value (args body)
	 (env-current-method-set! env var)
	 (env-vcount-set! env 0)
	 (env-code-set! env '())
	 (env-locals-set! env '())
	 (env-freelocals-set! env '())
	 (env-maplocals-set! env '())
	 (env-stack-set! env '())
	 (for-each
	  (lambda (a)
	     (env-set-name! env a 'P)
	     ;; 'begin' is set in compiler-body
	     (debug-declare-var-from env a 'begin 'end) )
	  args )
	 (set! body (compile-compress body))
	 (compile-prelude body)
	 (compiler-body body env)
	 (_label env 'end)
	 (let ( (rtype (compile-type type env)) )
	    (if *jvm-purify* (_checkcast env rtype))
	    (_return env rtype) )
	 (if (not (null? (env-stack env)))
	     (begin
		(pp (reverse (env-code env)))
		(error "stack" "is not empty" (env-stack env)) ))
	 ; (pp `(defun ,(global-id var) ,(map local-name args)
	 ; 	 ,(compile-lisp body) ))
	 ; (print "** " (get-global-name env var))
	 `(method ,(get-global-name env var)
		  ,(compile-formals args env)
		  (reg1 reg2 ,@(reverse! (env-locals env)))
		  ,@(reverse! (env-code env)) ))))

(define (compile-formals l env)
   (if (null? l)
       l
       (let ( (v (car l)) (rest (compile-formals (cdr l) env)) )
	  (let ( (type (compile-type v env))  (name (local-name v)) )
	     (if (memq type '(double long))
		 (cons* name '_ rest)
		 (cons name rest) )))))

