(module saw_jvm_compile
   (include "Tvector/tvector.sch")
   (import engine_param
	   module_module
	   type_type
	   type_cache
	   type_env
	   ast_node
	   ast_var
	   ast_env
	   object_class
	   object_slots
	   cnst_node
	   cnst_alloc
	   tvector_tvector
	   tools_error
	   read_jvm
	   backend_backend
	   backend_jvm
	   backend_lib
	   backend_cplib
	   saw_extratype
	   saw_defs
	   saw_node2rtl
	   saw_woodcutter
	   saw_expr
	   saw_jvm_names
	   saw_jvm_out
	   saw_jvm_funcall
	   saw_jvm_code)
   (export (saw_jvm-compile ::jvm)) )

;;
;; Main function
;;
(define (saw_jvm-compile me::jvm)
   (names-initialization me)
   (for-each (lambda (c) (compile-class me c)) (get-declared-classes))
   (compile-module me) )
   
;;
;; Assembly of a class
;;
(define (compile-class me c)
   (open-class me c (get-its-super c))
   (for-each (lambda (f) (compile-slot me f)) (get-declared-fields c))
   (constructor me)
   (close-class me c) ) 

;;
;; Assembly of a module
;;
(define (compile-module me)
   (open-module me)
   (for-each (lambda (v) (compile-global me v))
	     (get-declared-global-variables *module*) )
   (when (>fx (get-cnst-offset) 0) (compile-global me (get-cnst-table)))
   (if (global? *main*) (module-main me))
   (constructor me)
   (module-funcall/apply me)
   (module-init me)
   (module-functions me)
   (close-module me) )

;;
;; the Main function
;;
(define (module-main me)
   (open-lib-method me 'main)
   (declare-locals me '(argv) '())
   (when *jvm-catch*
      (code! me '(handler from catch catch throwable))
      (code! me 'from) )
   (code! me '(aload argv))
   (code! me '(invokestatic listargv))
   (call-global me (find-global 'bigloo_main *module*))
   (code! me '(pop))
   (code! me '(return))
   (when *jvm-catch*
      (code! me 'catch)
      (code! me '(invokestatic internalerror))
      (code! me '(return)) )
   (close-method me) )

;;
;; Instance constructors
;;
(define (constructor me)
   (open-lib-method me 'init)
   (declare-locals me '(this) '())
   (code! me '(aload this))
   (code! me '(invokespecial super-init))
   (code! me '(return))
   (close-method me) )

;;
;; Module constructor
;;
(define (module-init me)
   (open-lib-method me 'clinit)
   (declare-locals me '() '())
   ;; For the dam!
   (code! me `(ldc ,(symbol->string *module*)))
   (code! me '(putstatic myname))
   ;; the constants table
   (let ( (size (get-cnst-offset)) )
      (when (>fx size 0)
	 (push-int me size)
	 (code! me '(anewarray obj))
	 (code! me `(putstatic ,(declare-global me (get-cnst-table)))) ))
   ;; CARE do we have to put #unspecified on some global variables
   (for-each (lambda (v) (module-init-cnst me v (global-value v)))
	     (get-global-variables-to-be-initialized *module*) )
   (code! me '(return))
   (close-method me) )

(define (module-init-cnst me var val)
   (with-access::scnst val (class node)
      (case class
	 ((sstring)
	  (push-string me node)
	  (code! me '(invokevirtual getbytes)) )
	 ((sreal)
	  (push-num me node 'double)
	  (code! me '(invokestatic double_to_real)) )
	 ((sfun)
	  (code! me '(new me))
	  (code! me '(dup))
	  (code! me '(invokespecial init))
	  (code! me '(dup))
	  (push-int me (indexed-index var))
	  (code! me '(putfield procindex))
	  (code! me '(dup))
	  (push-int me (get-node-atom-value (cadr (app-args node))))
	  (code! me '(putfield procarity)) )
	 ((sgfun)
	  (code! me '(new me))
	  (code! me '(dup))
	  (code! me '(invokespecial init))
	  (code! me '(dup))
	  (push-int me (indexed-index var))
	  (code! me '(putfield procindex))
	  (code! me '(dup))
	  (push-int me (get-node-atom-value (cadr (app-args node))))
	  (code! me '(putfield procarity))
	  (code! me '(dup))
	  (push-int me 3)
	  (code! me '(anewarray obj))
	  (code! me '(putfield procenv)) )
	 ((stvector)
	  (let* ( (vec   (a-tvector-vector node))
		  (type (tvec-item-type (a-tvector-type node)))
		  (id (type-name type))
		  (n (vector-length vec)) )
	     (push-int me n)
	     (code! me `(newarray ,(type-name type)))
	     (let init ( (i 0) )
		(if (not (=fx i n))
		    (begin
		       (code! me '(dup))
		       (push-int me i)
		       (push-num me (vector-ref vec i) id)
		       (code! me (case (type-name type)
				    ((boolean byte) '(bastore))
				    ((char) '(castore))
				    ((short) '(sastore))
				    ((int) '(iastore))
				    ((long) '(lastore))
				    ((float) '(fastore))
				    ((double) '(dastore)) ))
		       (init (+fx i 1)) )))))
	 (else
	  (internal-error "emit-cnst" "Unknown cnst class" class)) )
      (code! me `(putstatic ,(declare-global me var))) ))

;;
;; Just for Dam!
;;
(define (module-dlopen me)
   (open-lib-method me 'dlopen)
   (declare-locals me '() '())
   (code! me '(iconst_0))
   (code! me '(aconst_null))
   (call-global me (find-global 'module-initialization *module*))
   (code! me '(pop))
   (code! me '(return))
   (close-method me) )

;;
;; Real code
;;
(define (module-functions me)
   (for-each (lambda (v) (module-function me v)) (jvm-functions me)) )

(define (module-function me v)
   (with-access::global v (value)
      (let ( (code (global->blocks me v))
	     (params  (map local->reg (sfun-args value))) )
	 (open-global-method me v)
	 (build-tree me params code)
	 (module-code me params code)
	 (close-method me) )))
