(module dotnet_as
   (export (dotnet-as ::obj ::output-port)))

(define (dotnet-as l outchan::output-port)
   (as l outchan) )

(define (as l out)
   (match-case l
      ((?key (and ?this (? symbol?))
	     (and ?extend (? symbol?))
	     (and ?implements ((? symbol?) ...))
	     (declare . ?decls) . ?infos )
       (let ( (cthis (classname decls this)) )
	  (let ( (pkgc (package cthis)) )
	     (if (not (string=? pkgc ""))
		 (fprint out ".namespace '" pkgc "' {") )
	     ;; CARE attr and interfaces
	     (fprint out ".class public auto ansi '" (simpleclassname  cthis) "'"
		     " extends " (classname decls extend) " {")
	     (scan-infos out decls infos)
	     (fprint out "}")
	     (if (not (string=? pkgc "")) (fprint out "}")) )))
      (else (error "dotnet" "bad module definition" l)) ))

(define (lastpos s c)
   ;; LIB
   (define (walk i)
      (if (or (=fx i -1) (char=? (string-ref s i) c))
	  i
	  (walk (-fx i 1)) ))
   (walk (-fx (string-length s) 1)) )

(define (package s)
   (let ( (i (lastpos s #\.)) )
      (if (=fx i -1)
	  ""
	  (substring s 0 i) )))

(define (simpleclassname s)
   (let ( (i (lastpos s #\.)) )
      (if (=fx i -1)
	  s
	  (substring s (+fx i 1) (string-length s)) )))


(define (scan-infos out decls infos)
   (cond
      ((null? infos) decls)
      ((eq? (caar infos) 'fields)
       (for-each (lambda (f) (field out decls f)) (cdar infos))
       (scan-infos out decls (cdr infos)) )
      ((eq? (caar infos) 'sourcefile)
       (scan-infos out decls (cdr infos)) )
      (else
       (for-each (lambda (m) (method out decls m)) infos) )))

(define (decl_method f decls)
   (let ( (decl (assq f decls)) )
      (match-case decl
	 ((?key (method ?this ?attr ?type ?name . ?targs))
	  (cdadr decl) )
	 (else (error "dotnet" "bad method definition of" f)) )))

(define (decl_field f decls)
   (let ( (decl (assq f decls)) )
      (match-case decl
	 ((?key (field ?this ?attr ?type ?name))
	  (cdadr decl) )
	 (else (error "dotnet" "bad field definition of" f)) )))

(define (field out decls f)
   (match-case (decl_field f decls)
      ((?this ?attr ?type ?name)
       (display ".field" out)
       (for-each (lambda (a) (display " " out) (attribute out a)) attr)
       (fprint out " " (typename decls type) " '" name "'") )))

(define (attribute out a)
   (display a out) )

(define basic-type
   `((void    . "void")
     (boolean . "bool")
     (char    . "char")
     (byte    . "unsigned int8")
     (short   . "int16")
     (int     . "int32")
     (long    . "int64")
     (float   . "float32")
     (double  . "float64") ))

(define (classname decls name)
   (let ( (decl (assq name decls)) )
      (match-case decl
	 ((?key (class ?attr ?name))
	  (cname name) )
	 (else #f) )))

(define (cname name)
   (cond
      ((string=? name "java.lang.RuntimeException")
       "System.Exception" )
      ((string=? name "java.lang.Throwable")
       "System.Exception" )
      ((substring=? "java.lang." name 10)
       (string-append "System." (substring name 10 (string-length name))) )
      ((string=? name "bigloo.struct")
       "bigloo.bstruct" )
      ((string=? name "bigloo.object")
       "bigloo.bobject" )
      (else name) ))

(define (typename decls type)
   (match-case type
      ((vector ?etype)
       (string-append (typename decls etype) "[]") )
      (else
       (cond
	  ((assq type basic-type) => cdr)
	  ((classname decls type) => (lambda (x) (string-append "class '" x "'")))
	  (else (error "dotnet" "bad type" type)) ))))

(define (*display out . l)
   (for-each (lambda (a) (display a out)) l) )

(define (mname name)
   (cond
      ((string=? name "<init>") ".ctor")
      ((string=? name "<clinit>") ".cctor")
      (else (string-append "'" name "'")) ))

(define (mheader out decls name)
   (display ".method" out)
   (mattr out decls name)
   (mproto1 out decls name)
   (display " cil managed " out) )

(define (mattr out decls name)
   (match-case (decl_method name decls)
      ((?this ?attr ?type ?name . ?targs)
       (for-each (lambda (a) (display " " out) (attribute out a)) attr)
       (if (not (memq 'static attr))
	   (if (string=? name  "<init>")
	       (*display out " hidebysig specialname rtspecialname instance")
	       (*display out " virtual hidebysig instance") ))
       (if (string=? name  "<clinit>")
	   (*display out " hidebysig specialname rtspecialname") )
       'ok )))

(define (nbargs decls name)
   (match-case (decl_method name decls)
      ((?this ?attr ?type ?name . ?targs)
       (length targs) )))

(define (nbret decls name)
   (match-case (decl_method name decls)
      ((?this ?attr ?type ?name . ?targs)
	  (if (eq? type 'void)
	      0
	      1 ))))

(define (mproto1 out decls name)
   (match-case (decl_method name decls)
      ((?owner ?attr ?type ?name . ?targs)
       (*display out " " (typename decls type) " " (mname name) "(")
       (if (not (null? targs))
	   (begin (display (typename decls (car targs)) out)
		  (for-each
		   (lambda (t) (*display out ", " (typename decls t)))
		   (cdr targs) )))
       (display ")" out) )))

(define (mproto2 out decls name)
   (match-case (decl_method name decls)
      ((?owner ?attr ?type ?name . ?targs)
       (*display out " " (typename decls type)
		 " '" (classname decls owner)
		 "'::" (mname name) "(")
       (if (not (null? targs))
	   (begin (display (typename decls (car targs)) out)
		  (for-each
		   (lambda (t) (*display out ", " (typename decls t)))
		   (cdr targs) )))
       (display ")" out) )))

(define *new* '())
(define *lpc* 0)

(define (method out decls m)
   (peep m)
   (match-case m
      ((method ?gname ?params ?locals . ?code)
       (mheader out decls gname)
       (fprint out "{")
       (match-case (decl_method gname decls)
	  ((?this ?attr ?type ?name . ?targs)
	   (if (string=? name "Main")
	       (fprint out "\t.entrypoint") )))
       (set! *new* '())
       (set! *lpc* 0)
       (if (hassw code)
	   (set! locals (cons '(swreg . int) locals)) )
       (outlocals out decls locals)
       (fprint out "\t.maxstack\t" (maxstack out decls code))
       (for-each (lambda (i) (instr out decls params locals i)) code)
       (fprint out "}") )
      (else (error "dotnet" "bad method definition" m)) ))

(define (hassw code)
   (cond ((null? code) #f)
	 ((not (pair? (car code)))
	  (hassw (cdr code)) )
	 ((eq? (caar code) 'lookupswitch) #t)
	 (else (hassw (cdr code))) ))
	  

(define (outlocals out decls locals)
   (if (null? locals)
       '()
       (begin
	  (*display out "\t.locals\t(")
	  (*display out (typename decls (cdar locals)))
	  (for-each
	   (lambda (s)
	      (*display out ", " (typename decls (cdr s))) )
	   (cdr locals) )
	  (fprint out ")") )))

(define (outfield out decls f)
   (cond
      ((eq? f 'unspecified)
       (fprint out "class 'bigloo.unspecified' 'bigloo.unspecified'::'_unspecified'") )
      ((eq? f 'nil)
       (fprint out "class 'bigloo.nil' 'bigloo.nil'::'_nil'") )
      ((eq? f 'eof)
       (fprint out "class 'bigloo.eof' 'bigloo.eof'::'_eof'") )
      ((eq? f 'rest)
       (fprint out "class 'bigloo.rest' 'bigloo.rest'::'_rest'") )
      ((eq? f 'key)
       (fprint out "class 'bigloo.key' 'bigloo.key'::'_key'") )
      ((eq? f 'optional)
       (fprint out "class 'bigloo.optional' 'bigloo.optional'::'_optional'") )
      (else (_outfield out decls f)) ))

(define (_outfield out decls f)
   (match-case (decl_field f decls)
      ((?owner ?attr ?type ?name)
       (fprint out (typename decls type) " '"
	       (classname decls owner) "'::'" name "'") )))

(define (index x l)
   (define (walk l r)
      (cond
	 ((null? l) -1)
	 ((eq? (car l) '_) (walk (cdr l) r))
	 ((eq? (car l) x) r)
	 ((and (pair? (car l)) (eq? (caar l) x)) r)
	 (else (walk (cdr l) (+fx 1 r))) ))
   (walk l 0) )

(define (index2 x l)
   (define (walk l r)
      (cond
	 ((null? l) -1)
	 ((eq? (caar l) x) r)
	 (else (walk (cdr l) (+fx 1 r))) ))
   (walk l 0) )

(define (var v params locals)
   (define (res p n)
      (let ( (s (integer->string n)) )
	 (cond ((<= n 3) (string-append p "." s))
	       ((<= n 255) (string-append p ".s " s))
	       (else (string-append p " " s)) )))
   (let ( (n (index v params)) )
      (if (= n -1)
	  (let ( (m (index2 v locals)) )
	     (if (= m -1)
		 (error "dotnet" "unknown var" v)
		 (res "loc" m) ))
	  (res "arg" n) )))

(define (stvar v params locals)
   (let ( (n (index v params)) )
      (if (= n -1)
	  (var v '() locals)
	  (string-append "arg " (integer->string n)) )))

(define (strout out s)
   (let ( (n (string-length s)) )
      (define (w n) (write-char (integer->char n) out))
      (define (walk i)
	 (if (= i n)
	     'ok
	     (let ( (c (string-ref s i)) )
		(let ( (cn (char->integer c)) )
		   (cond
		      ((char=? c #\")
		       (*display out "\\\"") )
		      ((char=? c #\\)
		       (*display out "\\\\") )
		      ((= cn 0)
		       (w #xC0)
		       (w #x80) )
		      ((< cn #x80)
		       (write-char c out) )
		      ((< cn #x800)
		       (w (bit-or #xC0 (bit-rsh cn 6)))
		       (w (bit-or #x80 (bit-and cn #x3F))) )
		      (else
		       (w (bit-or #xE0 (bit-rsh cn 12)))
		       (w (bit-or #x80 (bit-and (bit-rsh cn 6) #x3F)))
		       (w (bit-or #x80 (bit-and cn #x3F))) ))
		   (walk (+fx i 1)) ))))
      (walk 0) )) 

(define (instr out decls params locals i)
  (set! *lpc* (+fx 1 *lpc*))
  (match-case i
              ((nop) (fprint out "\tnop"))
              ((aconst_null) (fprint out "\tldnull"))
              ((aaload) (fprint out "\tldelem.ref"))
              ((aastore) (fprint out "\tstelem.ref"))
              ((aload ?v) (fprint out "\tld" (var v params locals)))
              ((anewarray ?type) (fprint out "\tnewarr\t" (typename decls type)))
              ((areturn) (fprint out "\tret"))
              ((arraylength) (fprint out "\tldlen"))
              ((astore ?v)
               (let ( (slot (assq v locals)) )
                 (if (and slot (not (eq? (cdr slot) 'jobject)))
                     (fprint out "\tcastclass\t" (typename decls (cdr slot)))
                     (let ( (slot2 (assq v params)) )
                       (if (and slot2 (not (eq? (cdr slot2) 'jobject)))
                           (fprint out "\tcastclass\t" (typename decls (cdr slot2))) ))))
               (fprint out "\tst" (stvar v params locals)) )
              ((athrow) (fprint out "\tthrow"))
              ((rethrow) (fprint out "\trethrow"))
              ((baload) (fprint out "\tldelem.i1"))
              ((bastore) (fprint out "\tstelem.i1"))
              ((bipush ?v) (fprint out "\tldc.i4 " v))
              ((checkcast ?type) (fprint out "\tcastclass\t" (typename decls type)))
              ((daload) (fprint out "\tldelem.r8"))
              ((dastore) (fprint out "\tstelem.r8"))
              ((dconst_0) (fprint out "\tldc.r8 0.0"))
              ((dconst_1) (fprint out "\tldc.r8 1.0"))
              ((dload ?v) (fprint out "\tld" (var v params locals)))
              ((dreturn) (fprint out "\tret"))
              ((dstore ?v) (fprint out "\tst" (stvar v params locals)))
              ((dup)
               (if (= *lpc* 1)
                   'ok
                   (fprint out "\tdup") ))
              ((fload ?v) (fprint out "\tld" (var v params locals)))
              ((freturn) (fprint out "\tret"))
              ((fstore ?v) (fprint out "\tst" (stvar v params locals)))
              ((getfield ?f)
               (*display out "\tldfld\t")
               (outfield out decls f) )
              ((getstatic ?f)
               (*display out "\tldsfld\t")
               (outfield out decls f) )
              ((goto ?lab) (fprint out "\tbr\t" lab))
              (else (match-case i
                                ((iaload) (fprint out "\tldelem.i4"))
                                ((iand) (fprint out "\tand"))
                                ((iastore) (fprint out "\tstelem.i4"))
                                ((iadd) (fprint out "\tadd"))
                                ((ladd) (fprint out "\tadd"))
                                ((dadd) (fprint out "\tadd"))
                                ((iconst_0) (fprint out "\tldc.i4.0"))
                                ((iconst_1) (fprint out "\tldc.i4.1"))
                                ((iconst_2) (fprint out "\tldc.i4.2"))
                                ((iconst_3) (fprint out "\tldc.i4.3"))
                                ((iconst_4) (fprint out "\tldc.i4.4"))
                                ((iconst_5) (fprint out "\tldc.i4.5"))
                                ((iconst_m1) (fprint out "\tldc.i4.m1"))
                                ((idiv) (fprint out "\tdiv"))
                                ((ldiv) (fprint out "\tdiv"))
                                ((ddiv) (fprint out "\tdiv"))
                                ((if_acmpeq ?lab) (fprint out "\tbeq\t" lab))
                                ((if_acmpne ?lab) (fprint out "\tbne.un\t" lab))
                                ((if_icmpeq ?lab) (fprint out "\tbeq\t" lab))
                                ((if_icmpge ?lab) (fprint out "\tbge\t" lab))
                                ((if_icmpgt ?lab) (fprint out "\tbgt\t" lab))
                                ((if_icmple ?lab) (fprint out "\tble\t" lab))
                                ((if_icmplt ?lab) (fprint out "\tblt\t" lab))
                                ((if_icmpne ?lab) (fprint out "\tbne.un\t" lab))
                                ((if_dcmpeq ?lab) (fprint out "\tbeq\t" lab))
                                ((if_dcmpge ?lab) (fprint out "\tbge\t" lab))
                                ((if_dcmpgt ?lab) (fprint out "\tbgt\t" lab))
                                ((if_dcmple ?lab) (fprint out "\tble\t" lab))
                                ((if_dcmplt ?lab) (fprint out "\tblt\t" lab))
                                ((if_dcmpne ?lab) (fprint out "\tbne.un\t" lab))
                                ((ifeq ?l) (fprint out "\tbrfalse\t" l))
                                ((ifne ?l) (fprint out "\tbrtrue\t" l))
                                ((iflt ?l) (fprint out "\tblt\t" l))
                                ((ifle ?l) (fprint out "\tble\t" l))
                                ((ifgt ?l) (fprint out "\tbgt\t" l))
                                ((ifge ?l) (fprint out "\tbge\t" l))
                                ((iload ?v) (fprint out "\tld" (var v params locals)))
                                ((imul) (fprint out "\tmul"))
                                ((lmul) (fprint out "\tmul"))
                                ((dmul) (fprint out "\tmul"))
                                ((ineg) (fprint out "\tneg"))
                                ((lneg) (fprint out "\tneg"))
                                ((dneg) (fprint out "\tneg"))
                                ((invokeinterface ?v)
                                 (*display out "\t\callvirt\tinstance")
                                 (mproto2 out decls v)
                                 (fprint out) )
                                ((invokespecial ?v)
                                 (if (eq? *new* '())
                                     (*display out "\t\call")
                                     (begin (*display out "\tnewobj")
                                            (set! *new* (cdr *new*)) ))
                                 (*display out "\tinstance")
                                 (mproto2 out decls v)
                                 (fprint out) )
                                ((invokestatic ?v)
                                 (*display out "\t\call\t")
                                 (mproto2 out decls v)
                                 (fprint out) )
                                ((invokevirtual ?v)
                                 (cond
                                   ((eq? v 'getbytes)
                                    (fprint out "\t\call\tunsigned int8[] 'bigloo.foreign'::getbytes"
                                            "(class System.String)"))
                                   (else
                                    (*display out "\t\callvirt\tinstance")
                                    (mproto2 out decls v)
                                    (fprint out) )))
                                ((instanceof ?type)
                                 (fprint out "\tisinst\t" (typename decls type))
                                 (let ( (l1 (gensym "I")) (l2 (gensym "I")) )
                                   (fprint out "\tbrfalse\t" l1)
                                   (fprint out "\tldc.i4.1")
                                   (fprint out "\tbr\t" l2)
                                   (fprint out l1 ":\tldc.i4.0")
                                   (fprint out l2 ":") ))
                                ((ior) (fprint out "\tor"))
                                ((irem) (fprint out "\trem"))
                                ((lrem) (fprint out "\trem"))
                                ((drem) (fprint out "\trem"))
                                ((ireturn) (fprint out "\tret"))
                                ((istore ?v) (fprint out "\tst" (stvar v params locals)))
                                ((isub) (fprint out "\tsub"))
                                ((lsub) (fprint out "\tsub"))
                                ((dsub) (fprint out "\tsub"))
                                ((ishl) (fprint out "\tshl"))
                                ((ishr) (fprint out "\tshr"))
                                ((iushr) (fprint out "\tshr.un"))
                                ((ixor) (fprint out "\txor"))
                                (else (match-case i
                                                  ((i2b) (fprint out "\tconv.i1"))
                                                  ((i2d) (fprint out "\tconv.r8"))
                                                  ((l2i) (fprint out "\tconv.i4"))
                                                  ((d2i) (fprint out "\tconv.i4"))
                                                  ((d2f) (fprint out "\tconv.r4"))
                                                  ((f2d) (fprint out "\tconv.r8"))
                                                  ((f2d) (fprint out "\tconv.r4"))
                                                  ((ldc ?v)
                                                   (cond
                                                     ((fixnum? v)
                                                      (fprint out "\tldc.i4 " v) )
                                                     ((flonum? v)
                                                      (fprint out "\tldc.r4 " v) )
                                                     ((string? v)
                                                      (*display out "\tldstr\t\"")
                                                      (strout out v)
                                                      (fprint out "\"") )
                                                     (else (error "dotnet" "bad arg for ldc" v)) ))
                                                  ((ldc2_w ?v)
                                                   (cond
                                                     ((fixnum? v)
                                                      (fprint out "\tldc.i8 " v) )
                                                     ((flonum? v)
                                                      (fprint out "\tldc.r8 " v) )
                                                     (else (error "dotnet" "bad arg for ldc2" v)) ))
                                                  ((line ?n)
                                                   'ok )
                                                  ((lload ?v) (fprint out "\tld" (var v params locals)))
                                                  ((localvar . ?l)
                                                   'ok )
                                                  ((lookupswitch ?def . ?slots)
                                                   (fprint out "\tst" (stvar 'swreg params locals))
                                                   (for-each
                                                    (lambda (s)
                                                      (fprint out "\tld" (var 'swreg params locals))
                                                      (fprint out "\tldc.i4\t" (car s))
                                                      (fprint out "\tbeq\t" (cdr s)) )
                                                    slots )
                                                   (fprint out "\tbr\t" def) )
                                                  ((lreturn) (fprint out "\tret"))
                                                  ((lstore ?v) (fprint out "\tst" (stvar v params locals)))
                                                  ((new ?type)
                                                   (set! *new* (cons type *new*))
                                                   (set! *lpc* 0) )
                                                  ((newarray ?type) (fprint out "\tnewarr\t" (typename decls type)))
                                                  ((pop) (fprint out "\tpop\t"))
                                                  ((putfield ?f)
                                                   (*display out "\tstfld\t")
                                                   (outfield out decls f) )
                                                  ((putstatic ?f)
                                                   (*display out "\tstsfld\t")
                                                   (outfield out decls f) )
                                                  ((tableswitch ?def ?beg . ?table)
                                                   (if (not (= beg 0))
                                                       (begin (fprint out "\tldc.i4.s\t" beg)
                                                              (fprint out "\tsub") ))
                                                   (*display out "\tswitch\t(")
                                                   (*display out (car table))
                                                   (for-each (lambda (t) (*display out ", " t)) (cdr table))
                                                   (fprint out ")")
                                                   (fprint out "\tbr\t" def) )
                                                  ((return) (fprint out "\tret"))
                                                  ((sipush ?v) (fprint out "\tldc.i4 " v))
                                                  ((swap)
                                                   (fprint out "\tst" (var 'sw1 params locals))
                                                   (fprint out "\tst" (var 'sw2 params locals))
                                                   (fprint out "\tld" (var 'sw1 params locals))
                                                   (fprint out "\tld" (var 'sw2 params locals)) )
                                                  ((try)
                                                   (fprint out "\t.try {") )
                                                  ((leave ?ad)
                                                   (fprint out "\tleave\t" ad " }") )
                                                  ((catch ?exc)
                                                   (fprint out "\tcatch '" (classname decls exc) "' {") )
                                                  ((handler . ?-)
                                                   'ok )
                                                  (else
                                                   (if (not (pair? i))
                                                       (fprint out i ":")
                                                       (error "dotnet" "unimplement instruction" i) ))))))))

(define (maxstack out decls code)
   (let ( (done '()) (max 0) )
      (define (walk l cur)
	 (if (not (pair? l))
	     (error 'maxstack "end of code reached" code) )
	 (let ( (i (car l)) )
	    (cond
	       ((not (pair? i))
		(if (memq i done)
		    'ok
		    (begin (set! done (cons i done))
			   ; (fprint out "//\t" i "\t" cur ":" max)
			   (walk (cdr l) cur) )))
	       (else
		(let ( (d (diffstack decls i))
		       (ex (extra i)) )
		   (if (>fx (+fx cur ex) max)
		       (set! max (+fx cur ex)) )
		   (let ( (ncur (+fx cur d)) )
		      (if (>fx ncur max)
			  (set! max ncur) )
		      (if (next? i)
			  (walk (cdr l) ncur) )
		      (for-each
		       (lambda (lab) (walk (memq lab code) ncur))
		       (follow i) )))))))
      (walk code '0)
      max ))
			  
(define (next? i)
   (if (memq (car i) '(areturn athrow freturn dreturn ireturn return lreturn
			       rethrow goto lookupswitch tableswitch leave ))
       #f
       #t ))

(define (follow i)
   (match-case i
      ((goto ?lab) (cons lab '()))
      ((if_acmpeq ?lab) (cons lab '()))
      ((if_acmpne ?lab) (cons lab '()))
      ((if_icmpeq ?lab) (cons lab '()))
      ((if_icmpge ?lab) (cons lab '()))
      ((if_icmpgt ?lab) (cons lab '()))
      ((if_icmple ?lab) (cons lab '()))
      ((if_icmplt ?lab) (cons lab '()))
      ((if_icmpne ?lab) (cons lab '()))
      ((if_dcmpeq ?lab) (cons lab '()))
      ((if_dcmpge ?lab) (cons lab '()))
      ((if_dcmpgt ?lab) (cons lab '()))
      ((if_dcmple ?lab) (cons lab '()))
      ((if_dcmplt ?lab) (cons lab '()))
      ((if_dcmpne ?lab) (cons lab '()))
      ((ifeq ?l) (cons l '()))
      ((ifne ?l) (cons l '()))
      ((iflt ?l) (cons l '()))
      ((ifle ?l) (cons l '()))
      ((ifgt ?l) (cons l '()))
      ((ifge ?l) (cons l '()))
      ((lookupswitch ?def . ?slots)
       (cons def (map cdr slots)) )
      ((tableswitch ?def ?beg . ?table)
       (cons def table) )
      ((leave ?lab) (cons lab '()))
      (else '()) ))

(define (extra i)
   (if (memq (car i) '(lookupswitch))
       1
       0 ))

(define (diffstack decls i)
   (cond
      ((memq (car i) '(nop anewarray arraylength checkcast getfield
			   goto ineg lneg dneg instanceof newarray return swap
                           i2b i2d l2i d2i d2f f2d d2f
			   line localvar handler try leave catch ))
       '0 )
      ((memq (car i) '(aconst_null aload bipush dconst_0 dconst_1 dload dup
				   fload getstatic iconst_0 iconst_1 iconst_2
				   iconst_3 iconst_4 iconst_5 iconst_m1
				   iload ldc ldc2_w lload new sipush ))
       '1 )
      ((memq (car i) '(aaload iaload areturn astore athrow baload dreturn
			      daload dstore
			      rethrow
			      freturn fstore iand idiv ldir ddiv ior
			      iadd ladd dadd isub lsub dsub imul lmul dmul
			      ifeq ifne iflt ifle ifgt ifge
			      irem drem
                              ireturn istore ishl ishr iushr ixor
			      lookupswitch lreturn lstore pop putstatic
			      tableswitch))
       '-1 )
      ((memq (car i) '(if_acmpeq if_acmpne
                       if_icmpeq if_icmpge if_icmpgt if_icmple if_icmplt if_icmpne
                       if_dcmpeq if_dcmpge if_dcmpgt if_dcmple if_dcmplt if_dcmpne
                       putfield ))
       -2 )
      ((memq (car i) '(aastore iastore bastore dastore))
       -3 )
      ((memq (car i) '(invokespecial invokeinterface invokestatic invokevirtual))
       (let ( (f (car i)) (m (cadr i)) )
	  (let ( (na (nbargs decls m)) (nr (nbret decls m)) )
	     (if (not (eq? f 'invokestatic))
		 (set! na (+fx na 1)) )
	     (-fx nr na) )))
      (else
       (error "dotnet" "unimplement instruction" i) )))

(define (peep defm)
   (match-case defm
      ((method ?gname ?params ?locals . ?code)
       (dead (cdddr defm)) )
      (else (error "peephole" "bad method definition" defm)) ))

(define (dead code)
   (define (make-labenv code)
      (cond ((null? code) '())
	    ((symbol? (car code)) (cons (cons (car code) 0)
					(make-labenv (cdr code)) ))
	    (else (make-labenv (cdr code))) ))
   (let ( (env (make-labenv code)) (continue? #t) )
      (define (change-lab lab incr)
	 (let ( (slot (assq lab env)) )
	    (if slot
		(begin (set-cdr! slot (+ incr (cdr slot)))
		       (if (= 0 (cdr slot))
			   (set! continue? #t)
			   'ok ))
		(error 'dead-code "unknown label" lab) )))
      (define (count-ins ins)
	 (for-each (lambda (lab) (change-lab lab 1)) (follow ins)) )
      (define (uncount-ins ins)
	 (for-each (lambda (lab) (change-lab lab -1)) (follow ins)) )
      (define (dead-code prev code)
	 (cond ((null? code)
		(set-cdr! prev '()) )
	       ((symbol? (car code))
		(if (= 0 (cdr (assq (car code) env)))
		    (dead-code prev (cdr code))
		    (begin (set-cdr! prev code)
			   (walk code (cdr code)) )))
	       ((memq (caar code) '(catch leave))
		(set-cdr! prev code)
		(walk code (cdr code)) )
	       (else (uncount-ins (car code))
		     (dead-code prev (cdr code))) ))
      (define (walk prev code)
	 (cond ((null? code) 'ok)
	       ((and (symbol? (car code))
		     (= 0 (cdr (assq (car code) env))) )
		(set-cdr! prev (cdr code))
		(walk prev (cdr code)) )
	       ((and (pair? (car code)) (not (next? (car code))))
		(dead-code code (cdr code)) )
	       (else (walk code (cdr code))) ))
      (for-each (lambda (ins) (count-ins ins)) code)
      (define (fix)
	 (if (not continue?)
	     'ok
	     (begin (set! continue? #f)
		    (walk code (cdr code))
		    (fix) )))
      (fix) ))
