;; Je mets ici tous les points d'entree qui ne me semble pas etre
;; dependants de structures specifiques a la JVM...
(module jvm_extern
   (include "Tvector/tvector.sch")
   (include "Ast/unit.sch")
   (include "Tools/location.sch")
   (import type_type ast_var ast_node
	   type_env
	   tools_shape
	   type_cache
	   object_class
	   object_slots
	   engine_param
	   ast_env
	   module_module
	   module_class
	   module_java
	   tvector_tvector
	   tvector_cnst
	   cnst_alloc
	   read_jvm
	   tools_error
	   backend_c_prototype
	   jvm_env jvm_instr
	   backend_cplib)
   (export (get-sourcefile)
	   (get-line-number node::node)
	   (debug-for-declare-var? env::env)
	   (debug-declare-var env::env var::local to::symbol)
	   (debug-declare-var-from env::env var::local from::symbol to::symbol)
	   (qualified-module-name module::symbol)
	   (get-classes-to-be-compiled)
	   (qualified-class-name class::tclass)
	   (tclass-id-mangling::symbol ::tclass)
	   (packaged-type-name type::symbol)
	   (global-to-be-declared global::global) 
	   (real-field-name global::global)
	   (real-sfun-name global::global)
	   (real-cfun-name global::global)
	   (manu-tu-fixes-global-tvector v)))

;;
(define (manu-tu-fixes-global-tvector v)
   (if (global? v)
       (let ( (value (global-value v)) )
	  (if (scnst? value)
	      (if (eq? (scnst-class value) 'stvector)
		  (tvec-item-type
		   (a-tvector-type
		    (scnst-node value)))
		  #f )
	      #f ))
       #f ))

;;;
;;; General
;;;
(define (get-sourcefile)
   (basename (car *src-files*)) )

(define (get-line-number node::node)
   (let ( (loc (node-loc node)) )
      (if (and *jvm-debug* (location? loc))
	  (location-lnum loc)
	  #f )))

(define (debug-for-declare-var? env::env)
   *jvm-debug* )

(define (debug-declare-var env::env var::local to::symbol)
   (if (and (debug-for-declare-var? env) (local-user? var))
       (let ( (from (gensym "F")) )
	  (_label env from)
	  (debug-declare-var-from env var from to) )))

(define (debug-declare-var-from env::env var::local from::symbol to::symbol)
   (if (and (debug-for-declare-var? env) (local-user? var))
       (let ( (type (compile-type var env))
	      (user-name (mangle (symbol->string (local-id var))))
	      (name (local-name var)) )
	  (_localvar env from to user-name type name) )))

;;;
;;; Modules
;;;
(define (qualified-module-name module::symbol)
   (module->qualified-type module))

;;;
;;; Classes
;;;
(define (get-classes-to-be-compiled)
   ;; Called only once in "compile"
   (let ( (r '()) )
      (for-each
       (lambda (class)
	  (if (not (eq? class (get-object-type)))
	      (with-access::tclass class (holder)
		 (if (not (eq? (global-import holder) 'import))
		     (set! r (cons class r))))))
       (get-class-list) )
      r ))

(define (qualified-class-name class::tclass)
   (if (not (tclass? class))
       (internal-error "qualified-class-name:not a tclass"
		       (shape class)
		       (find-runtime-type class)))
   ;; Called only by env-declare-class
   (on-package (super-package class) (tclass-id-mangling class)) )

(define (on-package pkgc name)
   (let* ((sname (symbol->string name))
	  (bsname (mangle sname)))
      (if (string=? pkgc "")
	  bsname
	  (string-append pkgc "." bsname))))

(define (mangle sname . mod)
   (if (bigloo-need-mangling? sname)
       (if (pair? mod)
	   (bigloo-module-mangle sname (car mod))
	   (bigloo-mangle sname))
       sname))

(define (super-package super)
   ;; CARE don't understand.. super can be only a tclass object
   (cond
      ((tclass? super)
       (with-access::tclass super (its-super id)
	  (if (or (eq? super its-super) (not (tclass? its-super)))
	      "bigloo"
	      ;; MANUEL SERRANO, 7 apr 2001
	      (let ((holder (tclass-holder super)))
		 (add-qualified-type! (global-module holder)
				      (global-jvm-type-name holder)
				      id)
		 (class-package (global-module holder))))))
      ((jclass? super)
       '(jclass-package super)
       (print "where do you got a jclass?")
       "jclass" )
      (else
       (error "super-package" "Illegal super class" super))))
   
(define (class-package name)
   (let* ((s (module->qualified-type name))
	  (pref (prefix s)))
      (if (string=? pref s)
	  ""
	  pref)))
      
;;;
;;; Global variables
;;;
(define (real-field-name global::global)
   (with-access::global global (module name id)
      ;; CARE: Manuel Serrano: J'ai introduis ici l'utilisation de name
      ;; autrement les clauses export de Java ne marchent pas.
      ;; CARE: BPS ben maintenant c'est ton probleme...
      (if (eq? module 'foreign)
	  (patch global)
	  (if (string? name)
	      name
	      (mangle (symbol->string id)) ))))

(define (real-sfun-name global::global)
   (with-access::global global (module name id)
      (if (eq? module 'foreign)
	  (patch global)
	  (if (string? name)
	      name
	      ;; Je met le mangling pour les <anonym ..>
	      (mangle (symbol->string id)) ))))

(define (real-cfun-name global::global)
   (with-access::global global (module name id)
      name ))
;	    ,(if (eq? module 'foreign) (patch global) name)

(define (patch global)
   (with-access::global global (id name)
      ;; CARE
      (cond ((eq? id 'bigloo-exit-env) "BIGLOO_EXIT_ENV")
	    ((eq? id '%exit-env) "BIGLOO_EXIT_ENV")
	    (else name) )))

;;;
;;; Classes
;;;
(define (tclass-id-mangling class::tclass)
   ;; CARE Only needed to got the classfile name in compile-class
   (if (eq? class (get-object-type))
       'object
       (with-access::tclass class (id holder)
	  (let ((mod (global-module holder)))
	     (string->symbol (class-id->type-name id mod))))))

;;;
;;; Types
;;;
(define (packaged-type-name type::symbol)
   (if (eq? type 'foreign)
       *jvm-foreign-class-name*
       (let ((java-class (find-java-class type)))
	  (if (string? java-class)
	      java-class
	      (string-append "bigloo." (symbol->string type)) ))))


(define (global-to-be-declared global::global) ;; global -> boolean
   (with-access::global global (id module removable occurrence value import)
      (if (and (not (eq? import 'eval))
	       (or (require-prototype? global)
		   (and (or (eq? id 'bigloo-exit)
			    (eq? id '%exit) )
			(cfun? value) )))
	  #t
	  (begin
	     (if (and (eq? module *module*) (not (eq? id '__cnsts_table)))
		 '(print "OCCURRENCE0 " id) )
	     #f ))))

(define (global-to-be-declared.old global::global) ;; global -> boolean
   (with-access::global global (id module removable occurrence value import)
      (if (and (not (eq? import 'eval))
	       (or (> occurrence 0)
		   (scnst? value)
		   (eq? removable 'never)
		   (eq? module *module*)
		   (and (or (eq? id 'bigloo-exit)
			    (eq? id '%exit) )
			(cfun? value) )))
	  #t
	  (begin
	     (if (and (eq? module *module*) (not (eq? id '__cnsts_table)))
		 (print "OCCURRENCE0 " id) )
	     #f ))))
