;; Produce instructions
(module dotnet_instr
   (import type_type ast_var ast_node
	   engine_param
	   object_class      ; tclass
	   dotnet_env )
   (export
    (env-code! env::env ins)
    (_aconst_null env::env)
    (_push env::env type n)
    (_dup env::env)
    (_pop env::env type)
    (_load env::env var::local)
    (_store env::env var::local)
    (_getstatic env::env var::symbol)
    (_getstatic2 env::env var::global)
    (_putstatic env::env var::symbol)
    (_iadd  env::env)
    (_isub  env::env)
    (_imul  env::env)
    (_idiv  env::env)
    (_irem  env::env)
    (_ineg  env::env)
    (_ior   env::env)
    (_iand  env::env)
    (_ixor  env::env)
    (_ishl  env::env)
    (_ishr  env::env)
    (_iushr env::env)
    (_ladd  env::env)
    (_lsub  env::env)
    (_lmul  env::env)
    (_ldiv  env::env)
    (_lrem  env::env)
    (_lneg  env::env)
    (_lor   env::env)
    (_land  env::env)
    (_lxor  env::env)
    (_lshl  env::env)
    (_lshr  env::env)
    (_lushr env::env)
    (_dadd  env::env)
    (_dsub  env::env)
    (_dmul  env::env)
    (_ddiv  env::env)
    (_drem  env::env)
    (_dneg  env::env)
    (_i2l env::env)
    (_i2b env::env)
    (_i2d env::env)
    (_l2i env::env)
    (_l2d env::env)
    (_d2i env::env)
    (_d2l env::env)
    (_d2f env::env)
    (_f2d env::env)
    (_label env::env lab::symbol)
    (_if op::symbol env::env lab::symbol)
    (_if_icmp op::symbol env::env lab::symbol)
    (_if_acmp op::symbol env::env lab::symbol)
    (_if_dcmp op::symbol env::env lab::symbol)
    (_switch env::env ldef::symbol num2lab)
    (_goto env::env lab::symbol)
    (_new env::env type::symbol)
    (_instanceof env::env type)
    (_checkcast env::env type)
    (_dotcheckcast env::env from to)
    (_getfield env::env ty var::symbol)
    (_putfield env::env var::symbol)
    (_newarray env::env type)
    (_aload env::env type)
    (_astore env::env type)
    (_arraylength env::env)
    (_invokestatic env::env var::symbol targs tr)
    (_invokespecial env::env var::symbol targs tr)
    (_invokespecial_init env::env var::symbol targs tr)
    (_invokevirtual env::env var::symbol targs tr)
    (_invokeinterface env::env var::symbol targs tr)
    (_return env::env type)
    (_athrow env::env)
    (_handler env::env b::symbol e::symbol pc::symbol tag::symbol)
    (_line env::env n)
    (_comment env::env name v)
    (_localvar env::env from::symbol to::symbol uname type name::symbol)
    (create-string env str)
    (simple-type type)
    (_load_name env::env name::symbol type)
    (_store_name env::env name::symbol type)) )

;;;
;;; Code
;;;
(define (push env::env type)
   (if (not (eq? type 'void))
       (env-stack-set! env (cons type (env-stack env))) ))

(define (pop env::env)
   (let ( (l (env-stack env)) )
      (if (null? l)
	  (begin
	     (pp (reverse (env-code env)))
	     (error "stack" "is empty" (reverse (env-code env))) ))
      (env-stack-set! env (cdr l))
      (car l) ))

(define (cpop env::env ty)
   (let ( (rty (pop env)) )
      (if (or (eq? ty rty) (eq? rty 'unknown))
	  ty
	  (begin
	     (pp (reverse (env-code env)))
	     (error "stack" "unexpected type in stack"
		    (list ty (cons rty (env-stack env)))) ))))

(define (simple-type type)
   (case type
      ((void) 'void)
      ((boolean byte char short int) 'int)
      ((long) 'long)
      ((float) 'float)
      ((double) 'double)
      (else 'ad) ))

(define (env-code! env::env ins)
   (with-access::env env (code)
      (set! code (cons ins code))
      #t ))

(define (env-new-label! env::env label::symbol)
   (with-access::env env (code)
      (match-case code
	 (((goto ?lab) . ?rest)
	  (if (eq? lab label)
	      (set! code rest) )))
      (set! code (cons label code))
      #t ))

;; Stack operations
(define (_aconst_null env::env)
   (env-code! env '(aconst_null))
   (push env 'ad) )

(define (_push env::env type n)
   (env-code! env
	      (case type
		 ((booolean byte char short int)
		  (case n
		     ((-1) '(iconst_m1))
		     ((0)  '(iconst_0))
		     ((1)  '(iconst_1))
		     ((2)  '(iconst_2))
		     ((3)  '(iconst_3))
		     ((4)  '(iconst_4))
		     ((5)  '(iconst_5))
		     (else
		      (cond ((and (> n -129) (< n 128)) `(bipush ,n))
			    ((and (> n -32769) (< n 32768)) `(sipush ,n))
			    (else `(ldc ,n)) ))))
		 ((long)
		  (cond ((= n 0) '(lconst_0))
			((= n 1) '(lconst_1))
			(else `(ldc2_w ,n)) ))
		 ((float)
		  (cond ((= n 0.0) '(fconst_0))
			((= n 1.0) '(fconst_1))
			((= n 2.0) '(fconst_2))
			(else `(ldc ,n)) ))
		 ((double)
		  (cond ((= n 0.0) '(dconst_0))
			((= n 1.0) '(dconst_1))
			(else `(ldc2_w ,n)) ))
		 ((string)
		  `(ldc ,n) )
		 (else (error '_push "bad type" type)) ))
   (push env (simple-type type)) )

(define (_dup env::env)
   (env-code! env '(dup))
   (let ( (ty (pop env)) )
      (push env ty)
      (push env ty) ))

(define (_pop env::env type)
   (if (not (eq? type 'void))
       (begin
	  (env-code! env
		     (if (or (eq? type 'double) (eq? type 'long))
			 '(pop2)
			 '(pop) ))
	  (cpop env (simple-type type)) )
       'ok ))

;; local variables
(define (get-real-name env name)
   (with-access::env env (maplocals)
      (let ( (slot (assq name maplocals)) )
	 (if slot
	     (cdr slot)
	     name ))))

(define (_load env::env var::local)
   (_load_name env (local-name var) (compile-type (local-type var) env)) )

(define (_load_name env::env name::symbol type)
   (let ( (name (get-real-name env name)) )
      (env-code! env
		 (case type
		    ((boolean byte char short int) `(iload ,name) )
		    ((long) `(lload ,name))
		    ((float) `(fload ,name))
		    ((double) `(dload ,name))
		    (else `(aload ,name)) ))
      (push env (simple-type type)) ))

(define (_store env::env var::local)
   (_store_name env (local-name var) (compile-type (local-type var) env)) )

(define (_store_name env::env name::symbol type)
   (let ( (name (get-real-name env name)) )
      (env-code! env
		 (case type
		    ((boolean byte char short int) `(istore ,name))
		    ((long)   `(lstore ,name))
		    ((float)  `(fstore ,name))
		    ((double) `(dstore ,name))
		    (else     `(astore ,name)) ))
      (cpop env (simple-type type)) ))

;; Global variables
(define (_getstatic env::env var::symbol)
   (env-code! env `(getstatic ,var))
   (push env 'ad) )

(define (_getstatic2 env::env var::global)
   (env-code! env `(getstatic ,(get-global-name env var)))
   (push env (simple-type (compile-type (variable-type var) env))) )

(define (_putstatic env::env var::symbol)
   (env-code! env `(putstatic ,var))
   (pop env) )

;; Arithmetics
(define (_iadd  env::env) (env-code! env '(iadd)) (cpop env 'int))
(define (_isub  env::env) (env-code! env '(isub)) (cpop env 'int))
(define (_imul  env::env) (env-code! env '(imul)) (cpop env 'int))
(define (_idiv  env::env) (env-code! env '(idiv)) (cpop env 'int))
(define (_irem  env::env) (env-code! env '(irem)) (cpop env 'int))
(define (_ineg  env::env) (env-code! env '(ineg)))
(define (_ior   env::env) (env-code! env '(ior)) (cpop env 'int))
(define (_iand  env::env) (env-code! env '(iand)) (cpop env 'int))
(define (_ixor  env::env) (env-code! env '(ixor)) (cpop env 'int))
(define (_ishl  env::env) (env-code! env '(ishl)) (cpop env 'int))
(define (_ishr  env::env) (env-code! env '(ishr)) (cpop env 'int))
(define (_iushr env::env) (env-code! env '(iushr)) (cpop env 'int))

(define (_ladd  env::env) (env-code! env '(ladd)) (cpop env 'long))
(define (_lsub  env::env) (env-code! env '(lsub)) (cpop env 'long))
(define (_lmul  env::env) (env-code! env '(lmul)) (cpop env 'long))
(define (_ldiv  env::env) (env-code! env '(ldiv)) (cpop env 'long))
(define (_lrem  env::env) (env-code! env '(lrem)) (cpop env 'long))
(define (_lneg  env::env) (env-code! env '(lneg)))
(define (_lor   env::env) (env-code! env '(lor)) (cpop env 'long) )
(define (_land  env::env) (env-code! env '(land)) (cpop env 'long))
(define (_lxor  env::env) (env-code! env '(lxor)) (cpop env 'long))
(define (_lshl  env::env) (env-code! env '(lshl)) (cpop env 'long))
(define (_lshr  env::env) (env-code! env '(lshr)) (cpop env 'long))
(define (_lushr env::env) (env-code! env '(lushr)) (cpop env 'long))

(define (_dadd  env::env) (env-code! env '(dadd)) (cpop env 'double))
(define (_dsub  env::env) (env-code! env '(dsub)) (cpop env 'double))
(define (_dmul  env::env) (env-code! env '(dmul)) (cpop env 'double))
(define (_ddiv  env::env) (env-code! env '(ddiv)) (cpop env 'double))
(define (_drem  env::env) (env-code! env '(drem)) (cpop env 'double))
(define (_dneg  env::env) (env-code! env '(dneg)))

(define (_i2l env::env) (convert env '(i2l) 'int 'long))
(define (_i2b env::env) (convert env '(i2b) 'int 'int))
(define (_i2d env::env) (convert env '(i2d) 'int 'double))
(define (_l2i env::env) (convert env '(l2i) 'long 'int))
(define (_l2d env::env) (convert env '(l2d) 'long 'double))
(define (_d2i env::env) (convert env '(d2i) 'double 'int))
(define (_d2l env::env) (convert env '(d2l) 'double 'long))
(define (_d2f env::env) (convert env '(d2f) 'double 'float))
(define (_f2d env::env) (convert env '(f2d) 'float 'double))

(define (convert env::env op tfrom tto)
   (env-code! env op)
   (cpop env tfrom)
   (push env tto) )

;; controls
(define (_label env::env lab::symbol)
   (env-new-label! env lab) )

(define (_if op::symbol env::env lab::symbol)
   (env-code! env
	      (case op
		 ((eq) `(ifeq ,lab))
		 ((ne) `(ifne ,lab))
		 ((ge) `(ifge ,lab))
		 ((le) `(ifle ,lab))
		 ((gt) `(ifgt ,lab))
		 ((lt) `(iflt ,lab))
		  (else (error 'if "unknown operation" op)) ))
   (cpop env 'int) )

(define (_if_icmp op::symbol env::env lab::symbol)
   (env-code! env
	      (case op
		 ((eq) `(if_icmpeq ,lab))
		 ((ne) `(if_icmpne ,lab))
		 ((ge) `(if_icmpge ,lab))
		 ((le) `(if_icmple ,lab))
		 ((gt) `(if_icmpgt ,lab))
		 ((lt) `(if_icmplt ,lab))
		  (else (error 'if_icmp "unknown operation" op)) ))
   (cpop env 'int)
   (cpop env 'int) )

(define (_if_acmp op::symbol env::env lab::symbol)
   (env-code! env
	      (case op
		 ((eq) `(if_acmpeq ,lab))
		 ((ne) `(if_acmpne ,lab))
		  (else (error 'if_acmp "unknown operation" op)) ))
   (cpop env 'ad)
   (cpop env 'ad) )

(define (_if_dcmp op::symbol env::env lab::symbol)
   (env-code! env
	      (case op
		 ((eq) `(if_dcmpeq ,lab))
		 ((ne) `(if_dcmpne ,lab))
		 ((ge) `(if_dcmpge ,lab))
		 ((le) `(if_dcmple ,lab))
		 ((gt) `(if_dcmpgt ,lab))
		 ((lt) `(if_dcmplt ,lab))
		  (else (error 'if_dcmp "unknown operation" op)) ))
   (cpop env 'double)
   (cpop env 'double) )

(define (_goto env::env lab::symbol)
   (env-code! env `(goto ,lab)) )

(define (_switch env::env ldef::symbol num2lab)
   (cond
      ((null? num2lab)
       (_pop env 'int)
       (_goto env ldef) )
      ((null? (cdr num2lab))
       (_push env 'int (caar num2lab))
       (_if_icmp 'ne env ldef)
       (_goto env (cdar num2lab)) )
      (else
       (set! num2lab (sort num2lab (lambda (x y) (<fx (car x) (car y)))))
       (let* ( (nums (map car num2lab))
	       (min (car nums))
	       (max (car (last-pair nums)))
	       (n (length nums)) )
	  (env-code! env `(lookupswitch ,ldef ,@num2lab))
	  (cpop env 'int) ))))

(define (flat al ldef)
   (define (walk al i r)
      (cond
	 ((null? al) (reverse! r))
	 ((=fx i (caar al)) (walk (cdr al) (+fx i 1) (cons (cdar al) r)))
	 ((>fx i (caar al)) (walk (cdr al) i r))
	 (else (walk al (+fx i 1) (cons ldef r))) ))
   (let ( (r (walk al (caar al) '())) )
      r ))

;; Instances
(define (_new env::env type::symbol)
   (env-code! env `(new ,type))
   (push env 'ad) )

(define (_instanceof env::env type)
   (env-code! env `(instanceof ,type))
   (cpop env 'ad)
   (push env 'int) )

(define (_dotcheckcast env::env from to)
   (let ( (b '(void boolean byte char short int long float double)) )
      (let ( (tf (compile-type from env)) (tt (compile-type to env)) )
	 (if (and (not (memq tf b))
		  (not (memq tt b))
		  (not (eq? tf tt)) )
	     (env-code! env `(checkcast ,tt)) ))))

(define (_checkcast env::env type)
   (if (not (memq type '(void boolean byte char short int long
			      float double jobject )))
       (env-code! env `(checkcast ,type)) ))

(define (_getfield env::env ty var::symbol)
   (env-code! env `(getfield ,var))
   (cpop env 'ad)
   (push env (simple-type ty)) )

(define (_putfield env::env var::symbol)
   (env-code! env `(putfield ,var))
   (pop env)
   (cpop env 'ad) )

;; Arrays
(define (_newarray env::env type)
   (env-code! env
	      (case type
		 ((boolean byte char short int long float double)
		  `(newarray ,type))
		 (else `(anewarray ,type)) ))
   (cpop env 'int)
   (push env 'ad) )

(define (_aload env::env type)
   (env-code! env
	      (case type
		 ((boolean byte) '(baload))
		 ((char) '(caload))
		 ((short) '(saload))
		 ((int) '(iaload))
		 ((long) '(laload))
		 ((float) '(faload))
		 ((double) '(daload))
		 (else '(aaload)) ))
   (cpop env 'int)
   (cpop env 'ad)
   (push env (simple-type type)) )

(define (_astore env::env type)
   (env-code! env
	      (case type
		 ((boolean byte) '(bastore))
		 ((char) '(castore))
		 ((short) '(sastore))
		 ((int) '(iastore))
		 ((long) '(lastore))
		 ((float) '(fastore))
		 ((double) '(dastore))
		 (else '(aastore)) ))
   (pop env)
   (cpop env 'int)
   (cpop env 'ad) )

(define (_arraylength env::env)
   (env-code! env '(arraylength))
   (cpop env 'ad)
   (push env 'int) )

;; Calls
(define (_invokestatic env::env var::symbol targs tr)
   (env-code! env `(invokestatic ,var))
   (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
   (push env (simple-type tr)) )

(define (_invokespecial env::env var::symbol targs tr)
   (env-code! env `(invokespecial ,var))
   (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
   (push env (simple-type tr)) )

(define *simple-push-instructions* '
   (iconst_m1 iconst_0 iconst_1 iconst_2 iconst_3 iconst_4 iconst_5
    bipush sipush ldc lconst_0 lconst_1 ldc2_w fconst_0 fconst_1 fconst_2
    dconst_0 dconst_1 ldc2_w aconst_null aload iload lload dload fload
    getstatic ))

(define (_invokespecial_init env::env var::symbol targs tr)
   (with-access::env env (code)
      (let ( (args '()) (ptr code) )
	 (for-each
	  (lambda (t)
	     (if (and (pair? (car ptr)) (eq? (caar ptr) 'checkcast))
		 (begin (set! args (cons (car ptr) args))
			(set! ptr (cdr ptr)) ))
	     (if (and (pair? (car ptr))
		      (memq (caar ptr) *simple-push-instructions*) )
		 (begin (set! args (cons (car ptr) args))
			(set! ptr (cdr ptr)) )))
	  (cdr targs) )
	 (if (and (pair? (car ptr)) (eq? (caar ptr) 'checkcast))
	     (set! ptr (cdr ptr)) )
	 (match-case ptr
	    (((aload ?x) (astore ?x) (new ?t) . ?rest)
	     (set! code `((astore ,x)
			  (invokespecial ,var)
			  ,@(reverse args)
			  (dup)
			  (new ,t)
			  ,@rest )))
	    (((aload ?x) (astore ?x) (localvar ?from ?- ?- ?- ?x) ?from
			 (new ?t) . ?rest)
	     (set! code `((astore ,x)
			  (invokespecial ,var)
			  ,@(reverse args)
			  (dup)
			  (new ,t)
			  ,@rest )))
	    (else
	     (print "fail to reach the new instruction for <init> " code)
	     (print "type " targs)
	     (env-code! env `(invokespecial ,var)) ))
	 (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
	 (push env (simple-type tr)) )))

(define (_invokespecial_init.old env::env var::symbol targs tr)
   (with-access::env env (code)
      (let ( (args '()) (ptr code) )
	 (for-each
	  (lambda (t)
	     (if (and (pair? (car ptr)) (eq? (caar ptr) 'checkcast))
		 (begin (set! args (cons (car ptr) args))
			(set! ptr (cdr ptr)) ))
	     (if (and (pair? (car ptr))
		      (memq (caar ptr) '(aload iload lload dload fload)) )
		 (begin (set! args (cons (car ptr) args))
			(set! ptr (cdr ptr)) )))
	  (cdr targs) )
	 (if (and (pair? (car ptr)) (eq? (caar ptr) 'checkcast))
	     (set! ptr (cdr ptr)) )
	 (match-case ptr
	    (((aload ?x) (astore ?x) (new ?t) . ?rest)
	     (set! code `((astore ,x)
			  (invokespecial ,var)
			  ,@(reverse args)
			  (dup)
			  (new ,t)
			  ,@rest )))
	    (((aload ?x) (astore ?x) (localvar ?from ?- ?- ?- ?x) ?from
			 (new ?t) . ?rest)
	     (set! code `((astore ,x)
			  (invokespecial ,var)
			  ,@(reverse args)
			  (dup)
			  (new ,t)
			  ,@rest )))
	    (else
	     (print "fail to reach the new instruction for <init> " code)
	     (print "type " targs)
	     (env-code! env `(invokespecial ,var)) ))
	 (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
	 (push env (simple-type tr)) )))

(define (_invokevirtual env::env var::symbol targs tr)
   (env-code! env `(invokevirtual ,var))
   (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
   (push env (simple-type tr)) )

(define (_invokeinterface env::env var::symbol targs tr)
   (env-code! env `(invokeinterface ,var))
   (for-each (lambda (a) (cpop env (simple-type a))) (reverse targs))
   (push env (simple-type tr)) )

(define (_return env::env type)
   (env-code! env
	      (case type
		 ((boolean byte char short int) '(ireturn))
		 ((long) '(lreturn))
		 ((float) '(freturn))
		 ((double) '(dreturn))
		 (else '(areturn)) ))
   (cpop env (simple-type type)) )

;; Exceptions
(define (_athrow env::env)
   (env-code! env '(athrow))
   (cpop env 'ad)
   (push env 'unknown) )

(define (_handler env::env b::symbol e::symbol pc::symbol tag::symbol)
   (env-code! env `(handler ,b ,e ,pc ,tag)) )

;; Misc
(define (_comment env name v)
   (env-code! env `(comment ,name ,v)) )

(define *last-line* -1)
(define (_line env n)
   (if (=fx n *last-line*)
       'ok
       (begin (env-code! env `(line ,n))
	      (set! *last-line* n) )))

(define (_localvar env::env from::symbol to::symbol uname type name::symbol)
   (let ( (name (get-real-name env name)) )
      (env-code! env `(localvar ,from ,to ,uname ,type ,name)) ))

(define (create-string env str)
   (_push env 'string str)
   (_invokevirtual env (jlib-declare env 'getbytes) '(ad) 'ad) )

