;; Construct special methods : <init> and funcaller
(module jvm_closure
   (import type_type ast_var ast_node engine_param
	   object_class     ; tclass
	   backend_lib
           jvm_extern jvm_env jvm_instr )
   (export (jvm-funcallers env::env me::symbol super::symbol)) )

;;
;; Overload funcall<i> and apply methods
;;
(define (jvm-funcallers env::env me::symbol super::symbol)
   (let ( (p (env-get-procedures env)) )
      (list (funcalli env me super 0 p)
	    (funcalli env me super 1 p)
	    (funcalli env me super 2 p)
	    (funcalli env me super 3 p)
	    (funcalli env me super 4 p)
	    (compile-apply env me super p) )))

;;
;; The "funcall"s method
;;
(define (funcalli env me super i procs)
   (let* ( (args (make-list i 'jobject))
	   (fname (string-append "funcall" (integer->string i)))
	   (f (gensym fname))
	   (ename (string-append "funcall_error" (integer->string i)))
	   (e (gensym ename))
	   (params (map (lambda (_) (gensym "A")) args)) )
      (env-declare env f `(method ,me (public) jobject ,fname ,@args))
      (env-declare env e `(method ,super (public) jobject ,fname ,@args))
      `(method ,f (this ,@params) ()
	       (aload this)
	       ,@(map (lambda (a) `(aload ,a)) params)
	       (aload this)
	       (getfield ,(jlib-declare env 'procindex))
	       ,@(compile-funi i env procs e) )))

(define (compile-funi i env funs error)
   (if (null? funs)
       `((pop)
	 (invokespecial ,error)
	 (areturn) )
       (let ( (labs (map (lambda (x) (gensym)) funs)) )
	  (define (cplabs f lab) (compile-lab-for-funcalli env i 'def lab f))
	  (define (cpcode f lab) (compile-for-funcalli env i lab f))
	  `((tableswitch def 0 ,@(map cplabs funs labs))
	    ,@(apply append (map cpcode funs labs))
        def (invokespecial ,error)
	    (areturn) ))))

(define (compile-lab-for-funcalli env i def lab slot)
   (let ( (arity (cddr slot)) (name (car slot)) )
      (if (null? arity)
	  (if (<=fx i 1) lab def)
	  (if (or (and (>=fx arity 0) (=fx arity i))
		  (and (<fx arity 0) (>= arity (- -1 i))) )
	      lab
	      def ))))

(define (compile-for-funcalli env i lab slot)
   (let ( (arity (cddr slot)) (name (car slot)) )
      (define (make_cons n)
	 (if (= n 0)
	     `((invokestatic ,name)
	       (areturn) )
	     (begin
		`((invokestatic cons)
		  ,@(make_cons (- n 1)) ))))
      (cond
	 ((null? arity)
	  (cond
	     ((=fx i 0)
	      `(,lab (pop) ;; clean
		     (getstatic ,name)
		     (areturn) ))
	     ((=fx i 1)
	      `(,lab (putstatic ,name)
		     (areturn) ))
	     (else '()) ))
	 ((>=fx arity 0)
	  (if (=fx arity i)
	      `(,lab (invokestatic ,name)
		    (areturn) )
	      '() ))
	 (else
	  (if (< arity (- -1 i))
	      '()
	      (begin
		 `(,lab (getstatic nil)
		       ,@(make_cons (+ i 1 arity)) )))))))

;;
;; The apply method
;;
(define (compile-apply env me super procs)
   (let ( (f (gensym "apply")) (e (gensym "APPLY-ERROR")) )
      (env-declare env f `(method ,me (public) jobject "apply" jobject))
      (env-declare env e `(method ,super (public) jobject "apply" jobject))
      `(method ,f (t a) ()
	       (aload t)
	       (aload a)
	       (aload t)
	       (getfield procindex)
	       ,@(compile-dispatch env procs e) )))

(define (compile-dispatch env funs error)
   (if (null? funs)
       `((pop)
	 (invokespecial ,error)
	 (areturn) )
       (let ( (labs (map (lambda (x) (gensym)) funs)) )
	  `((tableswitch def 0 ,@labs)
	    ,@(apply append
		     (map (lambda (f label)
			     `(,label ,@(compile-for-apply env f)) )
			  funs
			  labs ))
	    def
	    (invokespecial ,error)
	    (areturn) ))))

(define (compile-for-apply env slot)
   (define (push_cars n fixedarity? r)
      (if (= n 0)
	  (if fixedarity? (cons '(pop) r) r)
	  (if (and (= n 1) fixedarity?)
	      (if *jvm-purify*
		  (append '((checkcast j_pair) (getfield car)) r)
		  (cons '(getfield car) r) )
	      (append
	       `((dup)
		 ,@(if *jvm-purify* '((checkcast j_pair)) '())
		 (getfield car)
		 (swap)
		 ,@(if *jvm-purify* '((checkcast j_pair)) '())
		 (getfield cdr) )
	       (push_cars (- n 1) fixedarity? r) ))))
   (let ( (arity (cddr slot)) (name (car slot)) )
      (if (null? arity)
	  ;; We can't reach an apply from a getset
	  '((pop) (areturn))
	  (let ( (call `(invokestatic ,name)) )
	     (if (>= arity 0)
		 (push_cars arity #t `(,call (areturn)))
		 (push_cars (- -1 arity) #f `(,call (areturn))) )))))
