;;;; 	Copyright (C) 1995 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 


;;; An almost-Java macro-assembler and disassembler.
;;; This file also has functions to generate some of the 
;;; bytecode engine C source.
;;;


(require 'match-slib)



;;; {Compact opcodes}
;;;
;;; These are used in the the output of assemblers as a 
;;; paltform-neutral format for code.  
;;;

;; Instructions and macros are represented by symbols with 
;; special entries in their property lists.  Macros may be 
;; also be procedures with the same property set.
;;
(define (set-li-instruction-desc! symbol desc)
  (if (symbol? symbol)
      (set-symbol-property! symbol 'li-instruction-desc desc)
      (set-procedure-property! symbol 'li-instruction-desc desc)))
;;
(define (li-instruction-desc symbol-or-prop)
  (if (symbol? symbol-or-prop)
      (symbol-property symbol-or-prop 'li-instruction-desc)
      (procedure-property symbol-or-prop 'li-instruction-desc)))
;;
(define (procedure->li-macro! proc)
  (let ((fn (lambda (stmt labels forwards names const-tab return)
	      (return (apply proc (or (and (pair? stmt) (cdr stmt))
				      (asm-throw 'bad-statement stmt)))
		      labels
		      forwards
		      names
		      const-tab))))
    (set-li-instruction-desc! fn (list #f fn #f #f))
    fn))

;; The basic instruction set.
;;
;; The "Equiv. internal instruction" refers to the instruction set of the
;; interpreter.  Compact instructions are expanded to internal intructions 
;; by the interpreter.
;;
(define li-opcodes
  (let ((table
	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	 ;; Instruction		     Opcode  Operands				Equiv. internal instruction
	 ;; ------------------------------------------------------------------------------------------------------
	 ;;
	 `((nop					0	()					ili_nop)
	   (aconst_null				1	()					ili_push_0)
	   (iconst_m1				2	()					ili_iconst_m1)
	   (iconst_0				3	()					ili_iconst_0)
	   (iconst_1			       	4	()					ili_iconst_1)
	   (iconst_2				5	()					ili_iconst_2)
	   (iconst_3				6	()					ili_iconst_3)
	   (iconst_4				7	()					ili_iconst_4)
	   (iconst_5				8	()					ili_iconst_5)
	   (lconst_0				9	()					ili_lconst_0)
	   (lconst_1				10	()					ili_lconst_1)
	   (fconst_0				11	()					ili_fconst_0)
	   (fconst_1				12	()					ili_fconst_1)
	   (fconst_2				13	()					ili_fconst_2)
	   (dconst_0				14	()					ili_dconst_0)
	   (dconst_1				15	()					ili_dconst_1)
	   (bipush 				16	(signed_byte)				ili_push_literal)
	   (sipush				17	(signed_short)				ili_push_literal)
	   (ldc1				18	(byte_constant_index)			ili_push_constant)
	   (ldc2				19	(constant_index)			ili_push_constant)
	   (ldc2w				20	(constant_index_w)			ili_push_constant2)
	   (iload				21	(local_index)				ili_iload)
	   (lload				22	(local_index)				ili_lload)
	   (fload				23	(local_index)				ili_iload)
	   (dload				24	(local_index)				ili_lload)
	   (aload				25	(local_index)				ili_iload)
	   (iload_0				26	()					ili_iload_0)
	   (iload_1				27	()					ili_iload_1)
	   (iload_2				28	()					ili_iload_2)
	   (iload_3				29	()					ili_iload_3)
	   (lload_0				30	()					ili_lload_0)
	   (lload_1				31	()					ili_lload_1)
	   (lload_2				32	()					ili_lload_2)
	   (lload_3				33	()					ili_lload_3)
	   (fload_0				34	()					ili_iload_0)
	   (fload_1				35	()					ili_iload_1)
	   (fload_2				36	()					ili_iload_2)
	   (fload_3				37	()					ili_iload_3)
	   (dload_0				38	()					ili_lload_0)
	   (dload_1				39	()					ili_lload_1)
	   (dload_2				40	()					ili_lload_2)
	   (dload_3				41	()					ili_lload_3)
	   (aload_0				42	()					ili_iload_0)
	   (aload_1				43	()					ili_iload_1)
	   (aload_2				44	()					ili_iload_2)
	   (aload_3				45	()					ili_iload_3)
	   (iaload				46	()					ili_iaload)
	   (laload				47	()					ili_laload)
	   (faload				48	()					ili_faload)
	   (daload				49	()					ili_daload)
	   (aaload				50	()					ili_aaload)
	   (baload				51	()					ili_baload)
	   (caload				52	()					ili_caload)
	   (saload				53	()					ili_saload)
	   (istore				54	(local_index)				ili_istore)
	   (lstore				55	(local_index)				ili_lstore)
	   (fstore				56	(local_index)				ili_istore)
	   (dstore				57	(local_index)				ili_lstore)
	   (astore				58	(local_index)				ili_istore)
	   (istore_0				59	()					ili_istore_0)
	   (istore_1				60	()					ili_istore_1)
	   (istore_2				61	()					ili_istore_2)
	   (istore_3				62	()					ili_istore_3)
	   (lstore_0				63	()					ili_lstore_0)
	   (lstore_1				64	()					ili_lstore_1)
	   (lstore_2				65	()					ili_lstore_2)
	   (lstore_3				66	()					ili_lstore_3)
	   (fstore_0				67	()					ili_istore_0)
	   (fstore_1				68	()					ili_istore_1)
	   (fstore_2				69	()					ili_istore_2)
	   (fstore_3				70	()					ili_istore_3)
	   (dstore_0				71	()					ili_lstore_0)
	   (dstore_1				72	()					ili_lstore_1)
	   (dstore_2				73	()					ili_lstore_2)
	   (dstore_3				74	()					ili_lstore_3)
	   (astore_0				75	()					ili_istore_0)
	   (astore_1				76	()					ili_istore_1)
	   (astore_2				77	()					ili_istore_2)
	   (astore_3				78	()					ili_istore_3)
	   (iastore				79	()					ili_iastore)
	   (lastore				80	()					ili_lastore)
	   (fastore				81	()					ili_fastore)
	   (dastore				82	()					ili_dastore)
	   (aastore				83	()					ili_aastore)
	   (bastore				84	()					ili_bastore)
	   (castore				85	()					ili_castore)
	   (sastore				86	()					ili_sastore)
	   (pop					87	()					ili_pop)
	   (pop2				88	()					ili_pop2)
	   (dup					89	()					ili_dup)
	   (dup_x1				90	()					ili_dup_x1)
	   (dup_x2				91	()					ili_dup_x2)
	   (dup2				92	()					ili_dup2)
	   (dup2_x1				93	()					ili_dup2_x1)
	   (dup2_x2				94	()					ili_dup2_x2)
	   (swap				95	()					ili_swap)
	   (iadd				96	()					ili_iadd)
	   (ladd				97	()					ili_ladd)
	   (fadd				98	()					ili_fadd)
	   (dadd				99	()					ili_dadd)
	   (isub				100	()					ili_isub)
	   (lsub				101	()					ili_lsub)
	   (fsub				102	()					ili_fsub)
	   (dsub				103	()					ili_dsub)
	   (imul				104	()					ili_imul)
	   (lmul				105	()					ili_lmul)
	   (fmul				106	()					ili_fmul)
	   (dmul				107	()					ili_dmul)
	   (idiv				108	()					ili_idiv)
	   (ldiv				109	()					ili_ldiv)
	   (fdiv				110	()					ili_fdiv)
	   (ddiv				111	()					ili_ddiv)
	   (imod				112	()					ili_imod)
	   (lmod				113	()					ili_lmod)
	   (fmod				114	()					ili_fmod)
	   (dmod				115	()					ili_dmod)
	   (ineg				116	()					ili_ineg)
	   (lneg				117	()					ili_lneg)
	   (fneg				118	()					ili_fneg)
	   (dneg				119	()					ili_dneg)
	   (ishl				120	()					ili_ishl)
	   (lshl				121	()					ili_lshl)
	   (ishr				122	()					ili_ishr)
	   (lshr				123	()					ili_lshr)
	   (iushr				124	()					ili_iushr)
	   (lushr				125	()					ili_lushr)
	   (iand				126	()					ili_iand)
	   (land				127	()					ili_land)
	   (ior					128	()					ili_ior)
	   (lor					129	()					ili_lor)
	   (ixor				130	()					ili_ixor)
	   (lxor				131	()					ili_lxor)
	   (iinc 				132	(local_index signed_byte)		ili_iinc)
	   (i2f					133	()					ili_i2f)
	   (i2d					134	()					ili_i2d)
	   (i2l					135	()					ili_i2l)
	   (l2i					136	()					ili_l2i)
	   (l2f					137	()					ili_l2f)
	   (l2d					138	()					ili_l2d)
	   (f2i					139	()					ili_f2i)
	   (f2l					140	()					ili_f2l)
	   (f2d					141	()					ili_f2d)
	   (d2i					142	()					ili_d2i)
	   (d2l					143	()					ili_d2l)
	   (d2f					144	()					ili_d2f)
	   (int2byte				145	()					ili_int2byte)
	   (int2char				146	()					ili_int2char)
	   (int2short				147	()					ili_int2short)
	   (lcmp				148	()					ili_lcmp)
	   (fcmpl				149	()					ili_fcmpl)
	   (fcmpg				150	()					ili_fcmpg)
	   (dcmpl				151	()					ili_dcmpl)
	   (dcmpg				152	()					ili_dcmpg)
	   (ifeq				153	(branch_offset)				ili_ifeq)
	   (ifne				154	(branch_offset)				ili_ifne)
	   (iflt				155	(branch_offset)				ili_iflt)
	   (ifge				156	(branch_offset)				ili_ifge)
	   (ifgt				157	(branch_offset)				ili_ifgt)
	   (ifle				158	(branch_offset)				ili_ifle)
	   (if_icmpeq				159	(branch_offset)				ili_if_icmpeq)
	   (if_icmpne				160	(branch_offset)				ili_if_icmpne)
	   (if_icmplt				161	(branch_offset)				ili_if_icmplt)
	   (if_icmpge				162	(branch_offset)				ili_if_icmpge)
	   (if_icmpgt				163	(branch_offset)				ili_if_icmpgt)
	   (if_icmple				164	(branch_offset)				ili_if_icmple)
	   (if_acmpeq				165	(branch_offset)				ili_if_icmpeq)
	   (if_acmpne				166	(branch_offset)				ili_if_icmpne)
	   (goto				167	(branch_offset)				ili_goto)
	   (jsr					168	()					ili_jsr)
	   (ret					169	()					ili_ret)
	   (tableswitch				170	(jump_table)				ili_tableswitch)
	   (lookupswitch			171	(lookup_table)				ili_lookupswitch)
	   (ireturn				172	()					ili_ireturn)
	   (lreturn				173	()					ili_lreturn)
	   (freturn				174	()					ili_ireturn)
	   (dreturn				175	()					ili_lreturn)
	   (areturn				176	()					ili_ireturn)
	   (return				177	()					ili_vreturn)
	   (getstatic				178	(constant_field_index)			ili_getstatic)
	   (putstatic				179	(constant_field_index)			ili_putstatic)
	   (getfield				180	(constant_field_index)			ili_getfield)
	   (putfield				181	(constant_field_index)			ili_putfield)
	   (invokevirtual			182	(constant_method_index)			ili_invokevirtual)
	   (invokenonvirtual			183	(constant_method_index)			ili_invokenonvirtual)
	   (invokestatic			184	(constant_method_index)			ili_invokestatic)
	   (invokeinterface			185	(constant_method_index)			ili_invokeinterface)
	   (newfromname				186	()					ili_newfromname)
	   (new					187	(constant_type_index)			ili_new)
	   (newarray				188	(array_typecode)			ili_newarray)
	   (anewarray				189	(constant_type_index)			ili_anewarray)
	   (arraylength				190	()					ili_arraylength)
	   (athrow				191	()					ili_athrow)
	   (checkcast				192	(constant_type_index)			ili_checkcast)
	   (instanceof				193	(constant_type_index)			ili_instanceof)
	   (monitorenter			194	()					ili_monitorenter)
	   (monitorexit				195	()					ili_monitorexit)
	   (verifystack				196	()					ili_verifystack)
	   (breakpoint				197	()					ili_breakpoint)
	   (multianewarray			198	(constant_type_index unsigned_byte)	ili_multianewarray)


	   (ibitnot				199	()					ili_ibitnot)
	   (icnot				200	()					ili_icnot)
	   (icand				201	()					ili_icand)
	   (icor				202	()					ili_icor)
	   (halt				205	()					ili_halt)

	   (sadd				206	()					ili_sadd)
	   (ssub				207	()					ili_ssub)
	   (smul				208	()					ili_smul)
	   (sdiv				209	()					ili_sdiv)
	   (smod				210	()					ili_smod)
	   (scand				211	()					ili_scand)
	   (scor				212	()					ili_scor)
	   (sneg				213	()					ili_sneg)


	   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	   ;; Macro		     Callout			Operands (opt)		unused field
	   ;; ------------------------------------------------------------------------------------------------------
	   ;;
	   (load	     ,(lambda args
				(apply li-load-macro args))	#f			#f)

	   (store	     ,(lambda args
				(apply li-store-macro args))	#f			#f)

	   (decl	     ,(lambda args
				(apply li-decl-macro args))	#f			#f)

	   )))

    (for-each (lambda (desc) (set-li-instruction-desc! (car desc) desc)) table)

    table))


;; Compact operand formats and one byte encodings for them.
;;
(define li-operand-formats
  '((array_typecode		#\a)
    (branch_offset		#\b)
    (byte_constant_index	#\c)
    (constant_index		#\e)
    (constant_index_w		#\f)
    (constant_field_index	#\d)
    (constant_method_index	#\g)
    (constant_type_index	#\h)
    (jump_table			#\i)
    (local_index		#\j)
    (lookup_table		#\k)
    (signed_byte		#\l)
    (signed_short		#\m)
    (unsigned_byte		#\n)))

 ;;; {The Macro Assembler}
 ;;;

(define (li-assemble code names const-tab)


  ;; The first pass generates opcodes and most operands.
  ;; Forward-referenced labels are accumulated to be fixed in
  ;; the second pass.
  ;;
  (define (generate-instructions
	   src-pos bytes byte-pos labels forwards names const-tab)

    (cond
     ;; No more code to assemble; start the second pass:
     ;;
     ((null? src-pos) (fix-forwards (begin
				      (vector-set-length! bytes byte-pos)
				      bytes)
				    labels forwards names const-tab))

     ;; A label;  record its definition:
     ;;
     ((symbol? (car src-pos))
      (if (member (car src-pos) labels)
	  (asm-throw 'redefined-label (car src-pos))
	  (generate-instructions (cdr src-pos)
				 bytes
				 byte-pos
				 (acons (car src-pos) byte-pos labels)
				 forwards
				 names const-tab)))

     ;; Normal instruction or a macro call:
     ;;
     ((list? (car src-pos))

      (let* ((stmt (car src-pos))
	     (inx (car stmt))
	     (operands (cdr stmt))
	     (desc (or (li-instruction-desc inx)
		       (asm-throw 'unrecognized-instruction inx)))
	     (code (cadr desc))
	     (arg-desc (caddr desc)))

	(cond
	 ((and arg-desc
	       (not (and (list? operands) (= (length operands) (length arg-desc)))))
	  ;; Ill-formated operands:
	  ;;
	  (asm-throw 'wrong-number-of-operands (car src-pos)))

	 ((procedure? code)
	  ;; This is a macro.  
	  ;;
	  (code (cons (car stmt)
		      (map (lambda (n) (named-object n names))
			   (cdr stmt)))
		labels
		forwards
		names
		const-tab
		(lambda (expansion labels forwards names const-tab)
		  (generate-instructions (append expansion (cdr src-pos))
					 bytes
					 byte-pos
					 labels
					 forwards
					 names
					 const-tab))))

	 (else
	  ;; For normal instructions, generate the opcode and then call
	  ;; the operand compiler.
	  ;;
	  (generate-operands arg-desc
			     operands
			     src-pos
			     (li-generate! code 1 bytes byte-pos)
			     (+ 1 byte-pos)
			     labels
			     forwards
			     names const-tab)))))

     ;; Bogosity:
     ;;
     (else (asm-throw 'unrecognized-assembly-statement (car src-pos)))))

  ;; Generating operands is just a matter of dispatching to 
  ;; the handler for the particular format.
  ;;
  (define (generate-operands
	   arg-desc operands src-pos bytes byte-pos labels forwards names const-tab)
    (if (null? arg-desc)
	(generate-instructions
	 (cdr src-pos) bytes byte-pos labels forwards names const-tab)

	((or (li-operand-assembler (car arg-desc))
	     (asm-throw 'internal-assembler-error
			"Undefined operand format: "  (car arg-desc)))
	 (named-object (car operands) names)
	 bytes
	 byte-pos
	 labels
	 forwards
	 names const-tab
	 (lambda (bytes byte-pos labels forwards names const-tab)
	   (generate-operands (cdr arg-desc)
			      (cdr operands)
			      src-pos
			      bytes
			      byte-pos
			      labels
			      forwards
			      names const-tab)))))

  (define (named-object name names)
    (cond
     ((assoc name names) => cdr)
     (t name)))

  ;; In the second pass, forward references are resolved.
  ;;
  (define (fix-forwards bytes labels forwards names const-tab)
    (if (null? forwards)
	bytes
	(let* ((fwd (car forwards))
	       (label (caar fwd))
	       (rand-size (cadar fwd))
	       (fixup-loc (cdr fwd))
	       (labval (- (cdr (or (assoc label labels)
				   (asm-throw 'missing-label label)))
			  (li-read-val rand-size bytes fixup-loc))))
	  (fix-forwards (li-generate! labval rand-size bytes fixup-loc)
			labels
			(cdr forwards)
			names const-tab))))

  (generate-instructions code
			 (make-string 16)
			 0
			 '()
			 '()
			 names const-tab))


(define (asm-throw . args) (apply error args))



;; For every operand format, a rule is needed that 
;; translates assembler source for that operand
;; into compact byte-codes.  These are recorded
;; as a special property of the symbolic name of
;; the operand format.
;;
(define (set-li-operand-assembler! symbol thunk)
  (set-symbol-property! symbol 'operand-assembler thunk))
(define (set-li-operand-disassembler! symbol thunk)
  (set-symbol-property! symbol 'operand-disassembler thunk))


;;
(define (li-operand-assembler symbol)
  (symbol-property symbol 'operand-assembler))
(define (li-operand-disassembler symbol)
  (symbol-property symbol 'operand-disassembler))



;; Compact byte-codes are stored in strings.  Generally we
;; want to generate them from numeric values and to store
;; them in one or two bytes.  (Actually, if someone will fix
;; the log* functions, this will be quite a bit more general.)
;;
(define (li-generate! value nbytes bytes byte-pos)
  (cond
   ((> (+ nbytes byte-pos) (string-length bytes))
    (li-generate! value nbytes
		  (vector-set-length! bytes (* 2 (string-length bytes)))
		  byte-pos))
   ((= nbytes 0) bytes)
   (t
    (li-generate! value
		  (- nbytes 1)
		  (begin
		    (string-set! bytes
				 byte-pos
				 (integer->char
				  (let ((shamt (* 8 (- nbytes 1))))
				    (ash (logand value (ash #xff shamt))
					 (- shamt)))))
		    bytes)
		  (+ 1 byte-pos)))))


;; The opposite of li-generate!.
;;
(define (li-read-val size bytes byte-pos)
  (let loop ((answer 0)
	     (pos byte-pos)
	     (size size))
    (if (= size 0)
	answer
	(loop (+ (* answer 256) (char->integer (string-ref bytes pos)))
	      (+ pos 1)
	      (- size 1)))))

;;
(define (li-read-val-signed size bytes byte-pos)
  (let* ((hibyte (char->integer (string-ref bytes byte-pos)))
	 (bits (li-read-val size bytes byte-pos)))
    (if (< hibyte 128)
	bits
	(- bits (ash 1 (* 8 size))))))


;; The constant table is built on the fly.  It is an ordinary vector
;; with list elements.  Each element is a tag and some data.
;; For example a string constant "foo" is: (Asciz foo)
;; (That example illustrates a point worth mentioning -- strings
;; are stored as symbols for fast comparison).
;;

(define (li-constant! const-tab desc)
  (or (vector-member const-tab desc)
      (let ((answer (vector-length const-tab)))
	(vector-set-length! const-tab (+ 1 answer))
	(vector-set! const-tab answer desc)
	answer)))

(define (vector-member v k)
  (let loop ((pos 0))
    (and (< pos (vector-length v))
	 (if (eq? k (vector-ref v pos))
	     pos
	     (loop (+ pos 1))))))


;; Array Typecode Operands (arguments to "newarray")
;;

(define li-array-typecodes '((array 1)
			     (boolean 4)
			     (char 5)
			     (float 6)
			     (double 7)
			     (byte 8)
			     (short 9)
			     (int 10)
			     (long 11)))


(set-li-operand-assembler! 'array_typecode
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (return (li-generate! (cadr (or (assoc rand li-array-typecodes)
				    (asm-throw 'bad-array-type rand)))
			  1
			  bytes byte-pos)
	    (+ byte-pos 1)
	    labels
	    forwards
	    names const-tab)))

 ;;; branch-offset operands
 ;;;

(set-li-operand-assembler! 'branch_offset
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (assoc rand labels)
	(return (li-generate! (+ 1 (- (cdr (assoc rand labels)) byte-pos))
			      2 bytes byte-pos)
		(+ 2 byte-pos)
		labels
		forwards
		names const-tab)
	(return (li-generate! (- byte-pos 1) 2 bytes byte-pos)
		(+ 2 byte-pos)
		labels
		(acons (list rand 2) byte-pos forwards)
		names const-tab))))


(set-li-operand-disassembler! 'branch_offset
  (lambda (answers bytes byte-pos return)
    (return (cons (+ -1 byte-pos (li-read-val-signed 2 bytes byte-pos)) answers)
	    (+ byte-pos 2))))


       
 ;;; byte_constant_index operands
 ;;;
(set-li-operand-assembler! 'byte_constant_index
  (lambda (rand-passed bytes byte-pos labels forwards names const-tab return)
    (let ((rand (if (not (list? rand-passed))
		    rand-passed
		    (li-constant! const-tab rand-passed))))
      (if (not (and (number? rand)
		    (> rand 0)
		    (< rand 256)))
	  (error 'illegal-byte-constant-index rand)
	  (return (li-generate! rand 1 bytes byte-pos)
		  (+ 1 byte-pos)
		  labels
		  forwards
		  names const-tab)))))

(set-li-operand-disassembler! 'byte_constant_index
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val 1 bytes byte-pos) answers)
	    (+ byte-pos 1))))


 ;;; constant_index operands
 ;;;
(set-li-operand-assembler! 'constant_index
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (not (and (number? rand)
		  (> rand 0)
		  (< rand 65536)))
	(error 'illegal-constant-index rand)
	(return (li-generate! rand 2 bytes byte-pos)
		(+ 2 byte-pos)
		labels
		forwards
		names const-tab))))

(set-li-operand-disassembler! 'constant_index
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val 2 bytes byte-pos) answers)
	    (+ byte-pos 2))))



 ;;; constant_index_w operands
 ;;;
(set-li-operand-assembler! 'constant_index_w
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (not (and (number? rand)
		  (> rand 0)
		  (< rand 65536)))
	(error 'illegal-constant-index rand)
	(return (li-generate! rand 2 bytes byte-pos)
		(+ 2 byte-pos)
		labels
		forwards
		names const-tab))))

(set-li-operand-disassembler! 'constant_index_w
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val 2 bytes byte-pos) answers)
	    (+ byte-pos 2))))


;; signed_byte operands
;;
(set-li-operand-assembler! 'signed_byte
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (not (and (number? rand)
		  (> rand -129)
		  (< rand 127)))
	(error 'illegal-signed-byte rand)
	(return (li-generate! rand 1 bytes byte-pos)
		(+ 1 byte-pos)
		labels
		forwards
		names const-tab))))

(set-li-operand-disassembler! 'signed_byte
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val-signed 1 bytes byte-pos) answers)
	    (+ byte-pos 1))))


;; signed_short operands
;;
(set-li-operand-assembler! 'signed_short
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (not (and (number? rand)
		  (> rand -32769)
		  (< rand 32768)))
	(error 'illegal-signed-short rand)
	(return (li-generate! rand 2 bytes byte-pos)
		(+ 2 byte-pos)
		labels
		forwards
		names const-tab))))

(set-li-operand-disassembler! 'signed_short
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val-signed 2 bytes byte-pos) answers)
	    (+ byte-pos 2))))

;; unsigned_byte operands
;;
(set-li-operand-assembler! 'unsigned_byte
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (if (not (and (number? rand)
		  (>= rand 0)
		  (< rand 256)))
	(error 'illegal-unsigned-byte rand)
	(return (li-generate! rand 1 bytes byte-pos)
		(+ 1 byte-pos)
		labels
		forwards
		names const-tab))))

(set-li-operand-disassembler! 'unsigned_byte
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val 1 bytes byte-pos) answers)
	    (+ byte-pos 1))))


;; local_index operands
;;
(set-li-operand-assembler! 'local_index
  (lambda (rand bytes byte-pos labels forwards names const-tab return)
    (let ((n (if (and (list? rand)
		      (eq? 'ilocal (car rand))
		      (eq? 2 (length rand)))
		 (cadr rand)
		 rand)))
      (if (not (and (number? n)
		    (>= n 0)
		    (< n 256)))
	  (error 'illegal-local-index rand)
	  (return (li-generate! n 1 bytes byte-pos)
		  (+ 1 byte-pos)
		  labels
		  forwards
		  names const-tab)))))

(set-li-operand-disassembler! 'local_index
  (lambda (answers bytes byte-pos return)
    (return (cons (li-read-val 1 bytes byte-pos) answers)
	    (+ byte-pos 1))))



;; Operand compilers are still needed for these.
;;
;;    (constant_field_index	#\d)
;;    (constant_method_index	#\g)
;;    (constant_type_index	#\h)
;;    (jump_table		#\i)
;;    (local_index		#\j)
;;    (lookup_table		#\k)


 ;;; {The decl macro}
 ;;;

(define (li-decl-macro stmt labels forwards names const-tab return)
  (match stmt
    (`(decl ,(? symbol? name) ,defn)
     (return '()
	     labels
	     forwards
	     (let ((p (or (assoc name names)
			  (begin
			    (set! names (acons name defn names))
			    (car names)))))
	       (set-cdr! p defn)
	       names)
	     const-tab))

    (else (asm-throw 'bad-declaration stmt))))


 ;;; {The load macro}
 ;;;

(define li-one-inx-loads
  `(
    (null		aconst_null)
    (-1 		iconst_m1)
    (0			iconst_0)
    (1			iconst_1)
    (2			iconst_2)
    (3			iconst_3)
    (4			iconst_4)
    (5			iconst_5)
    ((long 0) 		lconst_0)
    ((long 1) 		lconst_1)
    (0.0 		fconst_0)
    (1.0 		fconst_1)
    ((double 0.0)	dconst_0)
    ((double 1.0) 	dconst_1)
    ((double 0)		dconst_0)
    ((double 1) 	dconst_1)

    ((ilocal 0) 	iload_0)
    ((ilocal 1) 	iload_1)
    ((ilocal 2) 	iload_2)
    ((ilocal 3) 	iload_3)
    ((llocal 0) 	lload_0)
    ((llocal 1) 	lload_1)
    ((llocal 2) 	lload_2)
    ((llocal 3) 	lload_3)
    ((flocal 0) 	fload_0)
    ((flocal 1) 	fload_1)
    ((flocal 2) 	fload_2)
    ((flocal 3) 	fload_3)
    ((dlocal 0) 	dload_0)
    ((dlocal 1) 	dload_1)
    ((dlocal 2) 	dload_2)
    ((dlocal 3) 	dload_3)
    ((alocal 0) 	aload_0)
    ((alocal 1) 	aload_1)
    ((alocal 2) 	aload_2)
    ((alocal 3) 	aload_3)))

(define (li-load-macro stmt labels forwards names const-tab return)

  (define (rangei? a l h)
    (and (<= l a)
	 (<= a h)))

  (let* ((args (cdr stmt))
	 (expansion
	  (cond
	   ((and (= (length args) 1)
		 (assoc (car args) li-one-inx-loads))
	    => (lambda (x) (list (cdr x))))

	   ((not (= (length args) 1))
	    (asm-throw 'wrong-number-of-args stmt))

	   (t 
	    (match (car args)
	      ((? (lambda (x) (and (integer? x) (exact? x))) n)
	       (cond
		((rangei? n -128 127) 		`((bipush ,n)))
		((rangei? n -32768 32767) 	`((sipush ,n)))
		(t fixme)))		; ldc1/ldc2

	      ((? number? n) 			(fixme)) ; ldc1/ldc2
	      ((? string? n)			(fixme)) ; ldc1/ldc2
	      (`(long   ,(? number? n))	(load-long n))   ; ldc2w
	      (`(double ,(? number? n))	(load-double n))

	      (`(ilocal ,(? number? n))	`((iload ,n)))
	      (`(llocal ,(? number? n))	`((lload ,n)))
	      (`(flocal ,(? number? n))	`((fload ,n)))
	      (`(dlocal ,(? number? n))	`((dload ,n)))
	      (`(alocal ,(? number? n))	`((aload ,n)))
	      (`(const  ,(? number? n))
	       (if (rangei? n 0 255)
		   `((ldc1 ,n))
		   `((ldc2 ,n))))
	      (`(const2 (? number? n))	`((ldc2w ,n)))
	      )))))
    (return expansion labels forwards names const-tab)))



 ;;; {The store macro}
 ;;;

(define li-one-inx-stores
  '(((ilocal 0) istore_0)
    ((ilocal 1) istore_1)
    ((ilocal 2) istore_2)
    ((ilocal 3) istore_3)
    ((llocal 0) lstore_0)
    ((llocal 1) lstore_1)
    ((llocal 2) lstore_2)
    ((llocal 3) lstore_3)
    ((flocal 0) fstore_0)
    ((flocal 1) fstore_1)
    ((flocal 2) fstore_2)
    ((flocal 3) fstore_3)
    ((dlocal 0) dstore_0)
    ((dlocal 1) dstore_1)
    ((dlocal 2) dstore_2)
    ((dlocal 3) dstore_3)
    ((alocal 0) astore_0)
    ((alocal 1) astore_1)
    ((alocal 2) astore_2)
    ((alocal 3) astore_3)))


(define (li-store-macro stmt labels forwards names const-tab return)

  (let* ((args (cdr stmt))
	 (expansion
	  (cond
	   ((and (= (length args) 1)
		 (assoc (car args) li-one-inx-stores))
	    => (lambda (x) (list (cdr x))))

	   ((not (= (length args) 1))
	    (asm-throw 'wrong-number-of-args stmt))

	   (t 
	    (match (car args)
	      (`(ilocal ,(? number? n))	`((istore ,n)))
	      (`(llocal ,(? number? n))	`((lstore ,n)))
	      (`(flocal ,(? number? n))	`((fstore ,n)))
	      (`(dlocal ,(? number? n))	`((dstore ,n)))
	      (`(alocal ,(? number? n))	`((astore ,n)))
	      (else (asm-throw 'bad-store stmt)))))))
    (return expansion labels forwards names const-tab)))


 ;;; {Internal Opcodes}
 ;;;

(define ili-opcodes
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; instruction		operands
  ;;------------------------------------
  ;;
  '((ili_nop			())
    (ili_push_0		())
    (ili_iconst_m1		())
    (ili_iconst_0		())
    (ili_iconst_1		())
    (ili_iconst_2		())
    (ili_iconst_3		())
    (ili_iconst_4		())
    (ili_iconst_5		())
    (ili_lconst_0		())
    (ili_lconst_1		())
    (ili_fconst_0		())
    (ili_fconst_1		())
    (ili_fconst_2		())
    (ili_dconst_0		())
    (ili_dconst_1		())
    (ili_push_literal		(scm))
    (ili_push_literal2		(scm2 scm2))
    (ili_push_constant		(constant_index))
    (ili_push_constant2		(constant2_index))
    (ili_iload			(local_index))
    (ili_lload			(local_index))
    (ili_iload_0		())
    (ili_iload_1		())
    (ili_iload_2		())
    (ili_iload_3		())
    (ili_lload_0		())
    (ili_lload_1		())
    (ili_lload_2		())
    (ili_lload_3		())
    (ili_istore			(local_index))
    (ili_lstore			(local_index))
    (ili_istore_0		())
    (ili_istore_1		())
    (ili_istore_2		())
    (ili_istore_3		())
    (ili_lstore_0		())
    (ili_lstore_1		())
    (ili_lstore_2		())
    (ili_lstore_3		())
    (ili_iinc			(local_index scm))
    (ili_pop			())
    (ili_pop2			())
    (ili_dup			())
    (ili_dup2			())
    (ili_dup_x1			())
    (ili_dup_x2			())
    (ili_dup2_x1		())
    (ili_dup2_x2		())
    (ili_swap			())
    (ili_lshr			())
    (ili_lshl			())
    (ili_lushr			())
    (ili_land			())
    (ili_lxor			())
    (ili_lor			())
    (ili_ishr			())
    (ili_ishl			())
    (ili_iushr			())
    (ili_iand			())
    (ili_ixor			())
    (ili_ior			())
    (ili_ldiv			())
    (ili_lmul			())
    (ili_ladd			())
    (ili_lsub			())
    (ili_lmod			())
    (ili_idiv			())
    (ili_imul			())
    (ili_iadd			())
    (ili_isub			())
    (ili_imod			())
    (ili_fdiv			())
    (ili_fmul			())
    (ili_fadd			())
    (ili_fsub			())
    (ili_fmod			())
    (ili_ddiv			())
    (ili_dmul			())
    (ili_dadd			())
    (ili_dsub			())
    (ili_dmod			())
    (ili_ineg			())
    (ili_lneg			())
    (ili_dneg			())
    (ili_fneg			())
    (ili_i2f			())
    (ili_i2l			())
    (ili_i2d			())
    (ili_f2i			())
    (ili_f2l			())
    (ili_f2d			())
    (ili_l2i			())
    (ili_l2f			())
    (ili_l2d			())
    (ili_d2i			())
    (ili_d2f			())
    (ili_d2l			())
    (ili_int2byte		())
    (ili_int2char		())
    (ili_int2short		())
    (ili_goto			(code_addr))
    (ili_jsr			(code_addr))
    (ili_ret			())
    (ili_tableswitch		())
    (ili_lookupswitch		())
    (ili_icmp			())
    (ili_lcmp			())
    (ili_fcmpl			())
    (ili_dcmpl			())
    (ili_fcmpg			())
    (ili_dcmpg			())
    (ili_ifeq			(code_addr))
    (ili_ifne			(code_addr))
    (ili_iflt			(code_addr))
    (ili_ifgt			(code_addr))
    (ili_ifge			(code_addr))
    (ili_ifle			(code_addr))
    (ili_if_icmpeq		(code_addr))
    (ili_if_icmpne		(code_addr))
    (ili_if_icmplt		(code_addr))
    (ili_if_icmpgt		(code_addr))
    (ili_if_icmple		(code_addr))
    (ili_if_icmpge		(code_addr))
    (ili_newfromname		())
    (ili_new			())
    (ili_ds_new			(*))
    (ili_getfield		())
    (ili_ds_getfield		(*))
    (ili_ds_lgetfield		(*))
    (ili_putfield		())
    (ili_ds_putfield		(*))
    (ili_ds_lputfield		(*))
    (ili_getstatic		())
    (ili_ds_getstatic		(*))
    (ili_ds_lgetstatic		(*))
    (ili_putstatic		())
    (ili_ds_putstatic		(*))
    (ili_ds_lputstatic		(*))
    (ili_newarray		())
    (ili_anewarray		())
    (ili_arraylength		())
    (ili_multianewarray		())
    (ili_iaload			())
    (ili_laload			())
    (ili_faload			())
    (ili_daload			())
    (ili_aaload			())
    (ili_baload			())
    (ili_caload			())
    (ili_saload			())
    (ili_iastore		())
    (ili_lastore		())
    (ili_fastore		())
    (ili_dastore		())
    (ili_aastore		())
    (ili_bastore		())
    (ili_castore		())
    (ili_sastore		())
    (ili_invokevirtual		(constant_method_index))
    (ili_ds_invokevirtual	(*))
    (ili_invokenonvirtual	())
    (ili_invokestatic		())
    (ili_ds_invoke_known	(*))
    (ili_invokeinterface	())
    (ili_ds_invokeinterface	(*))
    (ili_vreturn		())
    (ili_ireturn		())
    (ili_lreturn		())
    (ili_instanceof		())
    (ili_ds_instanceof		(*))
    (ili_checkcast		())
    (ili_ds_checkcast		(*))
    (ili_athrow			())
    (ili_monitorenter		())
    (ili_monitorexit		())
    (ili_verifystack		())
    (ili_breakpoint		())

    (ili_ibitnot		())
    (ili_icnot			())
    (ili_icand			())
    (ili_icor			())
    (ili_halt			())
    (ili_sadd			())
    (ili_ssub			())
    (ili_smul			())
    (ili_sdiv			())
    (ili_smod			())
    (ili_scand			())
    (ili_scor			())
    (ili_sneg			())
    ))


;; Internal opcode operand formats.
;;
(define ili-operand-formats
  '(code_addr
    constant_index
    constant_method_index
    local_index
    scm
    scm2))


;;; {Generating Parts of the Interpreter}
;;;

(define (li-standard-cdecls)
  (with-output-to-file "bc-inx.h"
    (lambda ()
      (li-opcode-cdecls)
      (li-vspace-cdecls)
      (li-operand-cdecls)
      (li-vspace-cdecls)
      (ili-opcode-cdelcs)
      (li-vspace-cdecls)
      (li-inx-desc-cdecls)
      ))
  (with-output-to-file "bc-map.h"
    (lambda ()
      (ili-instruction-mapping-cdecls)
      )))



(define (li-vspace-cdecls)
  (display "\n\n"))

(define (li-opcode-cdecls)
  (display "enum li_opcode\n{\n")
  (for-each (lambda (i)
	      (if (not (procedure? (cadr i)))
		  (begin
		    (display "  li_")
		    (display (car i))
		    (display " = ")
		    (display (cadr i))
		    (display ",\n"))))
	    li-opcodes)
  (display "};\n"))

(define (ili-opcode-cdelcs)
  (display "enum ili_opcode\n{\n")
  (let ((pos 0))
    (for-each  (lambda (i)
		 (display "  ")
		 (display (car i))
		 (display " = ")
		 (display pos)
		 (set! pos (+ 1 pos))
		 (display ",\n"))
	       ili-opcodes))
  (display "};\n"))



;; Generate an array describing the compact instruction set.
;;
(define (li-inx-desc-cdecls)
  (display "struct li_desc\n")
  (display "{\n")
  (display "  char * name;\n")
  (display "  char * operands;\n")
  (display "  int len;\n")
  (display "  enum ili_opcode internal_opcode;\n")
  (display "};\n\n")
  (display "struct li_desc li_desc[] = \n{\n")
  (for-each
   (lambda (i)
     (if (not (procedure? (cadr i)))
	 (begin
	   (display "  { \"")
	   (display (car i))
	   (display "\", \"")
	   (map (lambda (o) (display (cadr (assoc o li-operand-formats))))
		(caddr i))
	   (display "\", ")
	   (display (+ 1 (length (cadr (assoc (cadddr i) ili-opcodes)))))
	   (display ", ")
	   (display (cadddr i))
	   (display " },\n"))))
   li-opcodes)
  (display "};\n"))

;; Write definitions for the compact operand formats.
;;
(define (li-operand-cdecls)
  (display "enum li_operand_format\n{\n")
  (for-each (lambda (i)
	      (display "  ")
	      (display (car i))
	      (display " = '")
	      (display (cadr i))
	      (display "',\n"))
	    li-operand-formats)
  (display "};\n"))


;; Write a mapping from internal instruction opcodes
;; to code labels.
;;
(define (ili-instruction-mapping-cdecls)
  (display "#ifndef __GNUC__\n")
  (for-each (lambda (i)
	      (display "#define _")
	      (display (car i))
	      (display " ")
	      (display (car i))
	      (display "\n"))
	    ili-opcodes)
  (display "#endif\n\n")
  (display "static void * ili_instruction_mapping[] =\n{\n")
  (for-each (lambda (i)
	      (display "  &&_")
	      (display (car i))
	      (display ",\n"))
	    ili-opcodes)
  (display "};\n"))



;;; {The Disassembler}
;;;

(define li-inverse-opcodes
  (map (lambda (desc)
	 (cons (cadr desc)
	       (cons (car desc)
		     (cddr desc))))
       li-opcodes))

(define (li-disasm bytes)

  (define (li-disasm-operands answer desc bytes byte-pos return)
    (if (null? desc)
	(return (reverse answer) byte-pos)
	(let ((disser (li-operand-disassembler (car desc))))
	  (or disser
	      (asm-throw 'unknown-operand-format (car desc)))
	  (disser answer bytes byte-pos
		  (lambda (new-answer new-byte-pos)
		    (li-disasm-operands new-answer
					(cdr desc)
					bytes
					new-byte-pos
					return))))))
  
  (let loop ((byte-pos 0)
	     (reversed-answer '()))
    (if (>= byte-pos (string-length bytes))
	(reverse reversed-answer)
	(let* ((opcode (li-read-val 1 bytes byte-pos))
	       (desc (assoc opcode li-inverse-opcodes)))
	  (if (not desc)
	      (asm-throw 'unknown-bytecode
			 opcode
			 (list 'at-position byte-pos bytes))
	      (li-disasm-operands '()
				  (caddr desc)
				  bytes (+ 1 byte-pos)
				  (lambda (rands new-pos)
				    (loop new-pos
					  (cons (cons byte-pos (cons (cadr desc) rands))
						reversed-answer)))))))))

