(module dotnet_inline
   (import type_type ast_var ast_node engine_param
	   object_class      ; tclass but why?
	   dotnet_env dotnet_instr dotnet_expr dotnet_effect )
   (export special-inline-call? inline-call? inline-pred?) )

(define **sinline** #f)
(define **inline** #f)
(define **inlinepred** #f)

;;
;; General functions
;;
(define (false-and-true-at env f::symbol)
   (let ( (cont (gensym "L")) (stack (env-stack env)) )
      (_push env 'int 0)
      (_goto env cont)
      (_label env f)
      (env-stack-set! env stack)
      (_push env 'int 1)
      (_label env cont) ))

(define (if_acmp-return-boolean-for env op)
   (let ( (lab (gensym "L")) )
      (_if_acmp op env lab)
      (false-and-true-at env lab) ))

(define (if_icmp-return-boolean env op)
   ;; CARE test if we need & 0xFF
   (let ( (lab (gensym "L")) )
      (_if_icmp op env lab)
      (false-and-true-at env lab) ))

(define (lcomp-if-return-boolean env op)
   (let ( (lab (gensym "L")) )
      (_if_icmp op env lab)
      (false-and-true-at env lab) ))

(define (dcomp-if-return-boolean env op)
   (let ( (lab (gensym "L")) )
      (_if_dcmp op env lab)
      (false-and-true-at env lab) ))

(define (ifcompare op ltrue lfalse env)
   (_if op env lfalse)
   (_goto env ltrue) )

(define (acompare op ltrue lfalse env)
   (_if_acmp op env lfalse)
   (_goto env ltrue) )

(define (icompare op ltrue lfalse env)
   (_if_icmp op env lfalse)
   (_goto env ltrue) )

(define (lcompare op ltrue lfalse env)
   (_if_icmp op env lfalse)
   (_goto env ltrue) )

(define (dcompare op ltrue lfalse env)
   (_if_dcmp op env lfalse)
   (_goto env ltrue) )

(define (bint-value env)
   (_getfield env (if *longislong* 'long 'int) (jlib-declare env 'bint_value)))

;;
;; Special function inlining : arguments are not compiled
;;
(define *special-inline* (make-hashtable))

(define-macro (def-special-inline proto . body)
   `(hashtable-put! *special-inline*
		    ,(car proto)
		    (lambda ,(cdr proto) ,@body)))

(define (special-inline-call? v::global args env::env)
   (with-access::global v (name module)
      (if (and **sinline**
	       (number? *optim-jvm-inlining*)
	       (>= *optim-jvm-inlining* 1)
	       (number? *optim-jvm-constructor-inlining*)
	       (>= *optim-jvm-constructor-inlining* 1)
	       (eq? module 'foreign))
	  (let ( (entry (hashtable-get *special-inline* name)) )
	     (if entry
		 (begin
		    (entry v args env)
		    #t )
		 #f ))
	  #f )))

;;
;; function inlining : arguments are already compiled in the stack
;;
(define *inline* (make-hashtable))

(define-macro (def-inline proto . body)
   `(hashtable-put! *inline* ,(car proto) (lambda ,(cdr proto) ,@body)))

(define (inline-call? v env)
   (with-access::global v (name module)
      (if (and **inline**
	       (number? *optim-jvm-inlining*)
	       (>= *optim-jvm-inlining* 1)
	       (eq? module 'foreign))
	  (let ( (entry (hashtable-get *inline* name)) )
	     (if entry
		 (begin
		    (entry env)
		    #t )
		 #f ))
	  #f )))

;;
;; predicate inlining : arguments are already compiled in the stack
;;
(define *inlinepred* (make-hashtable))

(define-macro (def-inlinepred proto . body)
   `(hashtable-put! *inlinepred*
		    ,(car proto)
		    (lambda ,(cdr proto) ,@body)))

(define (inline-pred? v args ltrue lfalse env)
   (with-access::global v (name module)
      (if (and **inlinepred**
	       (number? *optim-jvm-inlining*)
	       (>= *optim-jvm-inlining* 1)
	       (eq? module 'foreign))
	  (let ( (entry (hashtable-get *inlinepred* name)) )
	     (if entry
		 (begin
		    (for-each (lambda (e) (compile-expr e env)) args)
		    (entry ltrue lfalse env)
		    #t )
		 #f ))
	  #f )))

;;
;; BOOLEAN
;;
(def-inline ("BOOLEANP" env)
   (let ( (l1 (gensym "L")) (l2 (gensym "L")) (cont (gensym "L")) )
      (_dup env)
      (_getstatic env (jlib-declare env 'faux))
      (_if_acmp 'eq env l1)
      (let ( (stack (env-stack env)) )
	 (_getstatic env (jlib-declare env 'vrai))
	 (_if_acmp 'eq env l2)
	 (_push env 'int 0)
	 (_goto env cont)
	 (env-stack-set! env stack)
	 (_label env l1)
	 (_pop env 'object)
	 (_label env l2)
	 (_push env 'int 1)
	 (_label env cont) )))

(def-inlinepred ("BOOLEANP" ltrue lfalse env)
   (let ( (lpop (gensym "L")) )
      (_dup env)
      (_getstatic env (jlib-declare env 'faux))
      (_if_acmp 'eq env lpop)
      (let ( (stack (env-stack env)) )
	 (_getstatic env (jlib-declare env 'vrai))
	 (_if_acmp 'ne env lfalse)
	 (_goto env ltrue)
	 (env-stack-set! env stack)
	 (_label env lpop)
	 (_pop env 'object)
	 (_goto env ltrue) )))

(def-inline ("CBOOL" env)
   (_getstatic env (jlib-declare env 'faux))
   (if_acmp-return-boolean-for env 'ne) )

(def-inlinepred ("CBOOL" ltrue lfalse env)
   (_getstatic env (jlib-declare env 'faux))
   (acompare 'eq ltrue lfalse env) )

(def-inline ("BBOOL" env)
   (let ( (lab (gensym "L")) (cont (gensym "L")) )
      (_if 'eq env lab)
      (let ( (stack (env-stack env)) )
	 (_getstatic env (jlib-declare env 'vrai))
	 (_goto env cont)
	 (env-stack-set! env stack)
	 (_label env lab)
	 (_getstatic env (jlib-declare env 'faux))
	 (_label env cont) )))

(def-inline ("BOXED_EQ" env)
   (if_acmp-return-boolean-for env 'eq) )

(def-inlinepred ("BOXED_EQ" ltrue lfalse env)
   (acompare 'ne ltrue lfalse env) )

(def-inline ("EQ" env)
   (let ( (lt (gensym "L")) (lf (gensym "L")) (lr (gensym "L")) )
      (if (not *optim-jvm-fasteq*)
	  (begin (_store_name env 'reg2 'jobject)
		 (_store_name env 'reg1 'jobject)
		 (_load_name env 'reg1 'jobject)
		 (_load_name env 'reg2 'jobject) ))
      (_if_acmp 'eq env lt)
      (let ( (stack (env-stack env)) )
	 (if (not *optim-jvm-fasteq*)
	     (begin (_load_name env 'reg1 'jobject)
		    (_instanceof env (jlib-declare env 'j_bint))
		    (_if 'eq env lf)
		    (_load_name env 'reg2 'jobject)
		    (_instanceof env 'j_bint)
		    (_if 'eq env lf)
		    (_load_name env 'reg1 'jobject)
		    (bint-value env)
		    (_load_name env 'reg2 'jobject)
		    (bint-value env)
		    (_if_icmp 'eq env lt) ))
	 (_label env lf)
	 (_push env 'int 0)
	 (_goto env lr)
	 (env-stack-set! env stack)
	 (_label env lt)
	 (_push env 'int 1)
	 (_label env lr) )))

(def-inlinepred ("EQ" ltrue lfalse env)
   (if *optim-jvm-fasteq*
       (_if_acmp 'ne env lfalse)
       (begin
	  (_store_name env 'reg2 'jobject)
	  (_store_name env 'reg1 'jobject)
	  (_load_name env 'reg1 'jobject)
	  (_load_name env 'reg2 'jobject)
	  (_if_acmp 'eq env ltrue)
	  (_load_name env 'reg1 'jobject)
	  (_instanceof env (jlib-declare env 'j_bint))
	  (_if 'eq env lfalse)
	  (_load_name env 'reg2 'jobject)
	  (_instanceof env 'j_bint)
	  (_if 'eq env lfalse)
	  (_load_name env 'reg1 'jobject)
	  (bint-value env)
	  (_load_name env 'reg2 'jobject)
	  (bint-value env)
	  (_if_icmp 'ne env lfalse) ))
   (_goto env ltrue) )

;;
;; CHARACTER
;;
(def-inline ("CHARP" env)
   (_instanceof env (jlib-declare env 'j_bchar)) )

(def-special-inline ("BCHAR" v args env)
   (_getstatic env (jlib-declare env 'bchar_allocated))
   (compile-expr (car args) env)
   (_push env 'int 255)
   (_iand env)
   (_aload env 'jobject) )

(def-inline ("CCHAR" env)
   (_getfield env 'int (jlib-declare env 'bchar_value)) )

(def-inline ("BCHAR_TO_UCHAR" env)
   (_getfield env 'int (jlib-declare env 'bchar_value)) )

(def-inline ("CHAR_TO_UCHAR" env)
   ;; CARE test if we need & 0xFF
   (_push env 'int 255)
   (_iand env) )

(def-inline ("UCHAR_TO_CHAR" env)
   (_i2b env) )

(def-inline ("CHAR_EQ" env) (if_icmp-return-boolean env 'eq))
(def-inline ("CHAR_LT" env) (if_icmp-return-boolean env 'lt))
(def-inline ("CHAR_GT" env) (if_icmp-return-boolean env 'gt))
(def-inline ("CHAR_LE" env) (if_icmp-return-boolean env 'le))
(def-inline ("CHAR_GE" env) (if_icmp-return-boolean env 'ge))

(def-inlinepred ("CHAR_EQ" lt lf env) (icompare 'ne lt lf env))
(def-inlinepred ("CHAR_LT" lt lf env) (icompare 'ge lt lf env))
(def-inlinepred ("CHAR_GT" lt lf env) (icompare 'le lt lf env))
(def-inlinepred ("CHAR_LE" lt lf env) (icompare 'gt lt lf env))
(def-inlinepred ("CHAR_GE" lt lf env) (icompare 'lt lt lf env))

(def-inline ("CHAR_OR" env)
   (_ior env) )

(def-inline ("CHAR_AND" env)
   (_iand env) )

(def-inline ("CHAR_NOT" env)
   (_push env 'int -1)
   (_ixor env)
   (_i2b env) )

(def-inline("toupper" env)
   (let ( (cont (gensym "L")) )
      (_dup env)
      (_push env 'int 97)
      (_if_icmp 'lt env cont)
      (_dup env)
      (_push env 'int 122)
      (_if_icmp 'gt env cont)
      (_push env 'int 32)
      (_isub env)
      (_label env cont) ))

(def-inline("tolower" env)
   (let ( (cont (gensym "L")) )
      (_dup env)
      (_push env 'int 65)
      (_if_icmp 'lt env cont)
      (_dup env)
      (_push env 'int 90)
      (_if_icmp 'gt env cont)
      (_push env 'int 32)
      (_iadd env)
      (_label env cont) ))

;;
;; INTEGER
;;
(def-inline ("INTEGERP" env)
   (_instanceof env (jlib-declare env 'j_bint)) )

(def-inline ("ELONGP" env)
   (_instanceof env (jlib-declare env 'j_elong)) )

(def-inline ("LLONGP" env)
   (_instanceof env (jlib-declare env 'j_llong)) )

(def-inline ("CHAR_TO_INT" env)
   (_push env 'int 255)
   (_iand env)
   (if *longislong* (_i2l env)) )

(def-inline ("INT_TO_CHAR" env)
   (if *longislong* (_l2i env)) )

(def-inline ("BINT_TO_LONG" env)
   (bint-value env) )

(def-inline ("BINT_TO_ULONG" env)
   (bint-value env) )

(def-inline ("INT_TO_LONG" env)
   (if *longislong* (_i2l env)) )

(def-inline ("LONG_TO_INT" env)
   (if *longislong* (_l2i env)) )

;; public static BLLONG LLONG_TO_BLLONG(long n)
;; public static BELONG LONG_TO_BELONG(int n)
;; public static BLLONG LONG_TO_BLLONG(int n)
;; public static BINT BINT(long v)
;; public static BINT BINT(int v)

(def-inline ("CINT" env)
   (bint-value env)
   (if *longislong* (_l2i env)) )

(def-inline ("EQ_FX" env) (lcomp-if-return-boolean env 'eq))
(def-inline ("LT_FX" env) (lcomp-if-return-boolean env 'lt))
(def-inline ("LE_FX" env) (lcomp-if-return-boolean env 'le))
(def-inline ("GT_FX" env) (lcomp-if-return-boolean env 'gt))
(def-inline ("GE_FX" env) (lcomp-if-return-boolean env 'ge))

(def-inlinepred ("EQ_FX" lt lf env) (lcompare 'ne lt lf env))
(def-inlinepred ("LT_FX" lt lf env) (lcompare 'ge lt lf env))
(def-inlinepred ("LE_FX" lt lf env) (lcompare 'gt lt lf env))
(def-inlinepred ("GT_FX" lt lf env) (lcompare 'le lt lf env))
(def-inlinepred ("GE_FX" lt lf env) (lcompare 'lt lt lf env))

(def-inline ("EVENP_FX" env)
   (let ( (lab (gensym "L")) )
      (if *longislong* (_l2i env))
      (_push env 'int 1)
      (_iand env)
      (_if 'eq env lab)
      (false-and-true-at env lab) ))

(def-inlinepred ("EVENP_FX" ltrue lfalse env)
   (if *longislong* (_l2i env))
   (_push env 'int 1)
   (_iand env)
   (ifcompare 'ne ltrue lfalse env) )

(def-inline ("ODD_FX" env)
   (let ( (lab (gensym "L")) )
      (if *longislong* (_l2i env))
      (_push env 'int 1)
      (_iand env)
      (_if 'ne env lab)
      (false-and-true-at env lab) ))

(def-inlinepred ("ODD_FX" ltrue lfalse env)
   (if *longislong* (_l2i env))
   (_push env 'int 1)
   (_iand env)
   (ifcompare 'eq ltrue lfalse env) )

(def-inline ("PLUS_FX"      env) (if *longislong* (_ladd  env) (_iadd  env)))
(def-inline ("MINUS_FX"     env) (if *longislong* (_lsub  env) (_isub  env)))
(def-inline ("MUL_FX"       env) (if *longislong* (_lmul  env) (_imul  env)))
(def-inline ("DIV_FX"       env) (if *longislong* (_ldiv  env) (_idiv  env)))
(def-inline ("NEG_FX"       env) (if *longislong* (_lneg  env) (_ineg  env)))
(def-inline ("QUOTIENT_FX"  env) (if *longislong* (_ldiv  env) (_idiv  env)))
(def-inline ("REMAINDER_FX" env) (if *longislong* (_lrem  env) (_irem  env)))
(def-inline ("BITOR"        env) (if *longislong* (_lor   env) (_ior   env)))
(def-inline ("BITAND"       env) (if *longislong* (_land  env) (_iand  env)))
(def-inline ("BITXOR"       env) (if *longislong* (_lxor  env) (_ixor  env)))
(def-inline ("BITRSH"       env) (if *longislong* (_lshr  env) (_ishr  env)))
(def-inline ("BITURSH"      env) (if *longislong* (_lushr env) (_iushr env)))
(def-inline ("BITLSH"       env) (if *longislong* (_lshl  env) (_ishl  env)))

(def-inline ("BITNOT" env)
   (if *longislong*
       (begin (_push env 'long 1)
	      (_lneg env)
	      (_lxor env) )
       (begin (_push env 'int 1)
	      (_ineg env)
	      (_ixor env) )))

;;
;; FLOAT
;;
(def-inline ("REALP" env)
   (_instanceof env (jlib-declare env 'j_real)) )

(def-inline ("REAL_TO_DOUBLE" env)
   (_getfield env 'double (jlib-declare env 'real_value)) )

(def-inline ("REAL_TO_FLOAT" env)
   (_getfield env 'double (jlib-declare env 'real_value))
   (_d2f env) )

(def-special-inline ("DOUBLE_TO_REAL" v args env)
   (_new env (jlib-declare env 'j_real))
   (_dup env)
   (compile-expr (car args) env)
   (if *jvm-purify*
       (_invokespecial env (jlib-declare env 'init_real) '(ad double) 'void)
       (_putfield env (jlib-declare env 'real_value)) ))

(def-special-inline ("FLOAT_TO_REAL" v args env)
   (_new env (jlib-declare env 'j_real))
   (_dup env)
   (compile-expr (car args) env)
   (_f2d env)
   (if *jvm-purify*
       (_invokespecial env (jlib-declare env 'init_real) '(ad double) 'void)
       (_putfield env (jlib-declare env 'real_value)) ))

(def-inline ("DOUBLE_TO_FLOAT" env)
   (_d2f env) )

(def-inline ("FLOAT_TO_DOUBLE" env)
   (_f2d env) )

(def-inline ("FIXNUM_TO_FLONUM" env)
   (if *longislong* (_l2d env) (_i2d env)) )

(def-inline ("FLONUM_TO_FIXNUM" env)
   (if *longislong* (_d2l env) (_d2i env)) )

(def-inline ("EQ_FL" env) (dcomp-if-return-boolean env 'eq))
(def-inline ("LT_FL" env) (dcomp-if-return-boolean env 'lt))
(def-inline ("LE_FL" env) (dcomp-if-return-boolean env 'le))
(def-inline ("GT_FL" env) (dcomp-if-return-boolean env 'gt))
(def-inline ("GE_FL" env) (dcomp-if-return-boolean env 'ge))

(def-inlinepred ("EQ_FL" lt lf env) (dcompare 'ne lt lf env))
(def-inlinepred ("LT_FL" lt lf env) (dcompare 'ge lt lf env))
(def-inlinepred ("LE_FL" lt lf env) (dcompare 'gt lt lf env))
(def-inlinepred ("GT_FL" lt lf env) (dcompare 'le lt lf env))
(def-inlinepred ("GE_FL" lt lf env) (dcompare 'lt lt lf env))

(def-inline ("PLUS_FL"  env) (_dadd env))
(def-inline ("MINUS_FL" env) (_dsub env))
(def-inline ("MUL_FL"   env) (_dmul env))
(def-inline ("DIV_FL"   env) (_ddiv env))
(def-inline ("NEG_FL"   env) (_dneg env))
(def-inline ("fmod"     env) (_drem env))

(def-inline ("floor" env) (dop1 env 'floor))
(def-inline ("ceil"  env) (dop1 env 'ceil))
(def-inline ("exp"   env) (dop1 env 'exp))
(def-inline ("log"   env) (dop1 env 'log))
(def-inline ("sin"   env) (dop1 env 'sin))
(def-inline ("cos"   env) (dop1 env 'cos))
(def-inline ("tan"   env) (dop1 env 'tan))
(def-inline ("asin"  env) (dop1 env 'asin))
(def-inline ("acos"  env) (dop1 env 'acos))
(def-inline ("atan"  env) (dop1 env 'atan))
(def-inline ("atan2" env) (dop2 env 'atan2))
(def-inline ("sqrt"  env) (dop1 env 'sqrt))
(def-inline ("pow"   env) (dop2 env 'pow))

(define (dop1 env name)
   (_invokestatic env (jlib-declare env name) '(double) 'double) )

(define (dop2 env name)
   (_invokestatic env (jlib-declare env name) '(double double) 'double) )

;;
;; CONSTANTS
;;
(def-inline ("EOF_OBJECTP" env)
   (_instanceof env (jlib-declare env 'j_eof)) )

(def-inline ("NULLP" env)
   (_getstatic env (jlib-declare env 'nil))
   (if_acmp-return-boolean-for env 'eq) )

(def-inlinepred ("NULLP" ltrue lfalse env)
   (_getstatic env (jlib-declare env 'nil))
   (acompare 'ne ltrue lfalse env) )

(def-inline ("CCNST" env)
   (if *jvm-purify* (_checkcast env 'j_cnst))
   (_getfield env 'int (jlib-declare env 'cnst_value))
   (if *longislong* (_i2l env)) )

;; public static CNST BCNST(int v)
;; public static boolean CNSTP(Object o)

(def-special-inline ("POINTERP" v args env)
   (compile-effect (car args) env)
   (_push env 'int 1) )

(def-special-inline ("OPAQUEP" v args env)
   (compile-effect (car args) env)
   (_push env 'int 0) )

(def-inline ("BGL_OBJECTP" env)
   (_instanceof env (jlib-declare env 'j_object)) )

;;
;; Unicode characters
;;

;; Delayed until write corrected and C ucs2->integer fixed

;;
;; Unicode strings
;;

;; Also delayed

;;
;; PROCESS
;;

;; Delayed

;;
;; STRING
;;
(def-inline ("STRINGP" env)
   (_instanceof env '(vector byte)) )

(def-inline ("string_to_bstring" env)
   #t )

(def-inline ("BSTRING_TO_STRING" env)
   #t )

(def-inline ("STRING_REF" env)
   (_aload env 'byte)
   (_push env 'int 255)
   (_iand env) )

(def-inline ("STRING_SET" env)
   (_astore env 'byte)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("STRING_LENGTH" env)
   (_arraylength env) )

(def-inline ("make_string_sans_fill" env)
   (_newarray env 'byte) )

;;
;; KEYWORD
;;
(def-inline ("KEYWORDP" env)
   (_instanceof env (jlib-declare env 'j_keyword)) )

(def-inline ("KEYWORD_TO_STRING" env)
   (_getfield env 'ad (jlib-declare env 'key_string)) )

;;public static KEYWORD string_to_keyword(byte[] s) {
;;	return(KEYWORD.make_keyword(s));
;;    }

;;
;; SYMBOL
;;
(def-inline ("SYMBOLP" env)
   (_instanceof env (jlib-declare env 'j_symbol)) )

(def-inline ("SYMBOL_TO_STRING" env)
   (if *jvm-purify* (_checkcast env 'j_symbol))
   (_getfield env 'ad (jlib-declare env 'symbol_string)) )

;;
;; CELL
;;
(def-inline ("CELLP" env)
   (_instanceof env (jlib-declare env 'j_cell)) )

(def-special-inline ("MAKE_CELL" v args env)
   (_new env 'j_cell)
   (_dup env)
   (compile-expr (car args) env)
   (if *jvm-purify*
       (_invokespecial env (jlib-declare env 'init_cell) '(ad ad) 'void)
       (_putfield env (jlib-declare env 'ccar)) ))

(def-inline ("CELL_SET" env)
   (_putfield env (jlib-declare env 'ccar))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("CELL_REF" env)
   (_getfield env 'jobject (jlib-declare env 'ccar)) )

(def-special-inline ("_EVMEANING_ADDRESS" v args env)
   (_new env 'j_cell)
   (_dup env)
   (compile-expr (car args) env)
   (if *jvm-purify*
       (_invokespecial env (jlib-declare env 'init_cell) '(ad) 'void)
       (_putfield env (jlib-declare env 'ccar)) ))

(def-inline ("_EVMEANING_ADDRESS_REF" env)
   (_getfield env 'jobject (jlib-declare env 'ccar)) )

(def-inline ("_EVMEANING_ADDRESS_SET" env)
   (_putfield env (jlib-declare env 'ccar))
   (_getstatic env (jlib-declare env 'unspecified)) )

;;
;; FOREIGN
;;
;; Delayed

;;
;; CUSTOM
;;
;; Delayed

;;
;; PAIR
;;
(def-inline ("PAIRP" env)
   (_instanceof env (jlib-declare env 'j_pair)) )

(def-special-inline ("MAKE_PAIR" v args env)
   (_new env 'j_pair)   ;; j_pair auto declared by (jlib-declare env 'car)
   (if *jvm-purify*
       (begin (_dup env)
	      (_invokespecial env (jlib-declare env 'init_pair) '(ad) 'void) ))
   (_dup env)
   (compile-expr (car args) env)
   (_putfield env (jlib-declare env 'car))
   (_dup env)
   (compile-expr (cadr args) env)
   (_putfield env (jlib-declare env 'cdr)) )

(def-inline ("CAR" env)
   (_getfield env 'jobject (jlib-declare env 'car)) )

(def-inline ("CDR" env)
   (_getfield env 'jobject (jlib-declare env 'cdr)) )

(def-inline ("SET_CAR" env)
   (_putfield env (jlib-declare env 'car))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("SET_CDR" env)
   (_putfield env (jlib-declare env 'cdr))
   (_getstatic env (jlib-declare env 'unspecified)) )

;;
;; EXTENDED PAIR
;;
(def-inline ("EXTENDED_PAIRP" env)
   (_instanceof env (jlib-declare env 'j_extended_pair)) )

(def-special-inline ("MAKE_EXTENDED_PAIR" v args env)
   (_new env 'j_extended_pair)
   (if *jvm-purify*
       (begin (_dup env)
	      (_invokespecial env (jlib-declare env 'init_extended_pair) '(ad) 'void) ))
   (_dup env)
   (compile-expr (car args) env)
   (_putfield env (jlib-declare env 'car))
   (_dup env)
   (compile-expr (cadr args) env)
   (_putfield env (jlib-declare env 'cdr))
   (_dup env)
   (compile-expr (caddr args) env)
   (_putfield env (jlib-declare env 'cer)) )

(def-inline ("CER" env)
   (if *jvm-purify* (_checkcast env 'j_extended_pair))
   (_getfield env 'jobject (jlib-declare env 'cer)) )

(def-inline ("SET_CER" env)
   ;; MANUEL SERRANO: ATTENTION BERNARD, J'AI DECOMMENTE CE CODE !!!!!!!!!!
;   ;; CARE must be special for purify
;;;;;; I will put back when correct prototype in foreign.java
   (_putfield env (jlib-declare env 'cer))
   (_getstatic env (jlib-declare env 'unspecified)) )

;;
;; VECTOR
;;
(def-inline ("VECTORP" env)
   (_instanceof env '(vector jobject)) )

(def-inline ("VECTOR_LENGTH" env)
   (_arraylength env) )

(def-inline ("VECTOR_REF" env)
   (_aload env 'jobject) )

(def-inline ("VECTOR_SET" env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("BOUND_CHECK" env)
   (if_icmp-return-boolean env 'lt) )

(def-inlinepred ("BOUND_CHECK" lt lf env)
   (icompare 'ge lt lf env) )

(def-inline ("VECTOR_TAG_SET" env)
   (_pop env 'int)
   (_pop env '(vector jobject))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("VECTOR_TAG" env)
   (_pop env '(vector jobject))
   (_push env 'int 0) )

(def-inline ("create_vector" env)
   (_newarray env 'jobject) )

;;
;; TVECTOR
;;

;;
;; STRUCT
;;
(def-inline ("STRUCTP" env)
   (_instanceof env (jlib-declare env 'j_struct)) )

(def-inline ("STRUCT_KEY" env)
   (_getfield env 'jobject (jlib-declare env 'struct_key)) )

(def-inline ("STRUCT_KEY_SET" env)
   (_putfield env (jlib-declare env 'struct_key))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("STRUCT_LENGTH" env)
   (_getfield env 'jobject (jlib-declare env 'struct_values))
   (_arraylength env) )

(def-special-inline ("STRUCT_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_struct))
   (_getfield env 'jobject (jlib-declare env 'struct_values))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("STRUCT_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_struct))
   (_getfield env 'jobject (jlib-declare env 'struct_values))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("UNSAFE_STRUCT_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_struct))
   (_getfield env 'jobject (jlib-declare env 'struct_values))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("UNSAFE_STRUCT_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_struct))
   (_getfield env 'jobject (jlib-declare env 'struct_values))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

;; public static STRUCT create_struct(SYMBOL key, int size)
;; public static STRUCT make_struct(SYMBOL key, int size, Object o)

;;
;; OBJECT
;;
(def-inline ("BGL_OBJECT_WIDENING_SET" env)
   (_putfield env (jlib-declare env 'widening))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("BGL_OBJECT_WIDENING" env)
   (_getfield env 'jobject (jlib-declare env 'widening)) )

(def-inline ("BGL_OBJECT_CLASS_NUM" env)
   (_getfield env 'int (jlib-declare env 'header)) )

(def-inline ("BGL_OBJECT_CLASS_NUM_SET" env)
   (_putfield env (jlib-declare env 'header))
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-inline ("BGL_HEAP_DEBUG_MARK_OBJ" env)
   #t )

;;
;; PROCEDURE
;;
(def-inline ("PROCEDUREP" env)
   (_instanceof env (jlib-declare env 'j_procedure)) )

(def-inline ("PROCEDURE_ARITY" env)
   (_getfield env 'int (jlib-declare env 'procarity)) )

(def-special-inline ("PROCEDURE_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("PROCEDURE_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("PROCEDURE_EL_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("PROCEDURE_EL_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("PROCEDURE_1_EL_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("PROCEDURE_1_EL_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("PROCEDURE_L_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (compile-expr (caddr args) env)
   (_astore env 'jobject)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("PROCEDURE_L_REF" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_getfield env 'jobject (jlib-declare env 'procenv))
   (compile-expr (cadr args) env)
   (_aload env 'jobject) )

(def-special-inline ("PUSH_BEFORE" v args env)
   (_getstatic env (jlib-declare env 'unspecified)) )

(def-special-inline ("POP_BEFORE" v args env)
   (_getstatic env (jlib-declare env 'unspecified)) )

;;
;; EXCEPTION
;;

;;
;; EVAL
;;
(def-inline ("__EVMEANING_ADDRESS_REF" env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (_invokevirtual env (jlib-declare env 'funcall0) '(ad) 'ad) )

(def-special-inline ("__EVMEANING_ADDRESS_SET" v args env)
   (compile-expr (car args) env)
   (if *jvm-purify* (_checkcast env 'j_procedure))
   (compile-expr (cadr args) env)
   (_invokevirtual env (jlib-declare env 'funcall1) '(ad ad) 'ad) )

;;
;; FILE/SYSTEM/OS
;; 

;;
;; SOCKET
;;

;;
;; INPUT
;;
(def-inline ("CLOSED_RGC_BUFFER" env)
   (if *jvm-purify* (_checkcast env 'j_input))
   (_getfield env 'boolean (jlib-declare env 'io_other_eof)) )

(def-inline ("INPUT_PORT_FILEPOS" env)
   (_getfield env 'int (jlib-declare env 'io_filepos)))

(def-inline ("INPUT_PORT_NAME" env)
   (_getfield env 'jstring (jlib-declare env 'io_name))
   (_invokevirtual env (jlib-declare env 'getbytes) '(ad) 'ad) )

;(def-inline ("RGC_BUFFER_POSITION" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_forward))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_start))
;   (_ISUB env) )

;(def-inline ("RGC_BUFFER_GET_CHAR" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env '(vector byte) (jlib-declare env 'io_buffer))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_forward))
;   (_DUP env)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_SWAP env)
;   (_PUSH env 'int 1)
;   (_IADD env)
;   (_PUTFIELD env (jlib-declare env 'io_forward))
;   (_ALOAD env 'byte)
;   (_PUSH env 'int 255)
;   (_IAND env) )

;(def-inline ("RGC_START_MATCH" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_stop))
;   (_STORE_NAME env 'reg2 'int)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg2 'int)
;   (_PUTFIELD env (jlib-declare env 'io_start))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg2 'int)
;   (_PUTFIELD env (jlib-declare env 'io_forward))
;   (_LOAD_NAME env 'reg2 'int) )

;(def-inline ("RGC_STOP_MATCH" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_forward))
;   (_STORE_NAME env 'reg2 'int)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg2 'int)
;   (_PUTFIELD env (jlib-declare env 'io_stop))
;   (_LOAD_NAME env 'reg2 'int) )

;(def-inline ("RGC_SET_FILEPOS" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_filepos))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_stop))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_start))
;   (_ISUB env)
;   (_STORE_NAME env 'reg2 'int)
;   (_LOAD_NAME env 'reg2 'int)
;   (_I2L env)
;   (_LADD env)
;   (_PUTFIELD env (jlib-declare env 'io_filepos))
;   (_LOAD_NAME env 'reg2 'int) )

;(def-inline ("RGC_BUFFER_LENGTH" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_stop))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_start))
;   (_ISUB env) )

;(def-inline ("RGC_BUFFER_EMPTY" env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_forward))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_abufsiz))
;   (if_icmp-return-boolean env 'EQ) )

;(def-inlinepred ("RGC_BUFFER_EMPTY" lt lf env)
;   (_STORE_NAME env 'reg1 'j_input)
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_forward))
;   (_LOAD_NAME env 'reg1 'j_input)
;   (_GETFIELD env 'int (jlib-declare env 'io_abufsiz))
;   (icompare 'NE lt lf env) )
