#
 # g5p7.p7 -- Genetic2005 Virtual Machine -- like genetic2004 but much improved & bugs fixed
 #
 # Copyright (c) 2006 Henry Strickland -- <strick> in the domain <yak.net>
 #
 # Permission is hereby granted, free of charge, to any person obtaining a
 # copy of this software and associated documentation files (the "Software"),
 # to deal in the Software without restriction, including without limitation
 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
 # and/or sell copies of the Software, and to permit persons to whom the
 # Software is furnished to do so, subject to the following conditions:
 #
 # The above copyright notice and this permission notice shall be included
 # in all copies or substantial portions of the Software.
 #
 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
 # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
 # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 # OTHER DEALINGS IN THE SOFTWARE.
 #
 #         (* http://www.opensource.org/licenses/mit-license.php *)
 #


# metaproc to remove all comments from *data*, beginning with #, until end of line
proc strip_comments text { regsub -all -linestop -lineanchor {[#].*$} $text "" }


p7global (int)NUM_GLOBAL	{ return (8) }
p7global (int)NUM_STACK		{ return (256) }
p7global (int)NUM_CODE		{ return (256) }
p7global (int)NUM_OUT		{ return (256) }



p7class G2005	[strip_comments {

	(int*)regs	# global variables
	(byt*)stack	# subroutine stack
	(byt*)code	# read-only program code
	(byt*)outbuf	# output buffer
	(int)accum	# accumulator
	(int)outptr	# index into outbuf
	(byt)sp		# subroutine stack pointer, indexes into stack
	(byt)pc		# program counter, indexes into code
	(int)trace	# enables tracing if true
	(int)step	# count how many steps
	(int)maxstep	# stop after too many steps

} ]

p7proc (void)assert { (int)cond } {
	if ( ! cond ) { error "*** Assertion Failed ***" }
}


p7proc (int)G2005_putchar { (G2005)this (byt)ch } {
	# return TRUE when full

	assert ( outptr < NUM_OUT )

	set outbuf(outptr) (ch)
	incr outptr
	return ( outptr == NUM_OUT )
}

p7proc (void)G2005_reset { (G2005)this } {

	set regs [new (int*) (NUM_GLOBAL)]
	set stack [new (byt*) (NUM_STACK)]
	set code [new (byt*) (NUM_CODE)]
	set outbuf [new (byt*) (NUM_OUT)]
	set accum 0
	set outptr 0
	set sp 0
	set pc 0
	set trace 0
	set step 0
	set maxstep 0
}

p7proc (int)G2005_step { (G2005)this } {
	# return TRUE when full

	set (byt)bytecode ( code[pc] )

if (trace) { ::puts [::format "step %d sp %d accum %d pc %02x code %02x" $step $sp $accum $pc $bytecode] }

	set (byt)lo ( bytecode & 15 )
	set (byt)hi ( (bytecode>>4) & 15 )
	set (byt)reg ( hi & 7 )
	set (int)stores ( 0 != (hi&8) )
	set (int)tmp

	incr pc

	if ( lo==0 ) { # case 0: return

		incr sp -1
		set pc ( stack[sp] )

	} elseif ( lo==1 ) { # case 1: CALL N*16

		set stack($sp) (pc)
		incr sp
		set pc ( hi * 16 )

	} elseif ( lo==2 ) { # case 2: DBNZ N*16

		incr accum -1
		if ( accum ) {
			set pc (hi*16)
		}

	} elseif ( lo==3 ) { # case 3: PUTCHAR

		return [ G2005_putchar $this $accum ]

	} elseif ( lo==4 ) { # case 4: LDC N-8
		
		set accum ( [set (int) $hi] - 8 )   ;# cast $hi to signed int

	} elseif ( lo==5 ) { # case 5: INC n-8
		
		incr accum ( [set (int) $hi] - 8 )   ;# cast $hi to signed int

	} elseif ( lo==6 ) { # case 6: INC  accum by 1

		incr accum
		
	} elseif ( lo==7 ) { # case 7: STO V, RCL V

 		if (stores) { set regs(reg) (accum) } else { set accum (regs[reg]) }

	} elseif ( lo==8 ) { # case 8: ADD V

		set tmp ( regs(reg) + accum )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	} elseif ( lo==9 ) { # case 9: SUB V

		set tmp ( regs(reg) - accum )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	} elseif ( lo==10 ) { # case 10: MUL V

		set tmp ( regs(reg) * accum )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	} elseif ( lo==11 ) { # case 11:  NOP -- was DIV V

	} elseif ( lo==12 ) { # case 12:  NOP -- was MOD V

	} elseif ( lo==13 ) { # case 13:  ULE V  -- unsigned less than or equal

		# we have only signed ints, so add 0x80000000 to simulate unsigned
		set (int)un_a ( accum + 0x80000000 )
		set (int)un_r ( regs(reg) + 0x80000000 )
		set tmp ( un_r <= un_a )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	} elseif ( lo==14 ) { # case 14: OR V

		set tmp ( regs(reg) | accum )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	} elseif ( lo==15 ) { # case 15: NAND V

		set tmp ( ~ ( regs(reg) & accum ) )
 		if (stores) { set regs(reg) (tmp) } else { set accum (tmp) }

	}

	return 0	;# output buffer not full yet
}

p7proc (int)G2005_eval { (G2005)this (byt*)_code (int)_maxstep } {

	G2005_reset $this
	set code $_code
	set maxstep $_maxstep

	while ( step < maxstep ) {
		set (int)done [ G2005_step $this ]
		if (done) {break}
		incr step
	}
	return $step
}


p7proc (byt*)Genetic2005_with_P7 { (byt*)_code (int)_maxstep } {

	new (G2005)terp

	G2005_eval $terp $_code $_maxstep

	return $terp.outbuf
}
	
#  END