decimal

: .####  base @ >r hex
	0 <# # # # # #> type space r> base ! ;

variable ndp	: here ndp @ ;
variable src	variable dst	variable pc	$10 pc !
Variable pc-old

variable zf
variable sf
variable cf

variable accu

variable mem-size	128 1024 * mem-size !
mem-size @ allocate throw
constant mem 

0 ndp !

\ Jumping

: pc>		src @ 2* pc @ + ;
: >pc 		pc ! ;
: >pcsf		sf @ IF >pc ELSE drop THEN ;
: >pczf		zf @ IF >pc ELSE drop THEN ;
: >pccf		cf @ IF >pc ELSE drop THEN ;

\ Memory

: ram>		2* mem + dup c@ 8 lshift swap char+ c@ or ;

: >ram		\ dup $4000 u< ABORT" Memory below $4000 is read-only"
                2* mem + over 8 rshift over c! char+ c! ;

\ IO

variable nesting 0 nesting !
: .hs
	." RP: " $4000 ram> .####
	." SP: " $4001 ram> .####
	." UP: " $4002 ram> .#### ;

: .ip
	$4003 ram> ." IP: " .#### ;
: trace
		cr nesting @ spaces 
		dup CASE [char] : OF 1 nesting +! .ip ENDOF 
		[char] ; OF -1 nesting +! ENDOF ENDCASE ;

: >txd		
\                trace
		[IFDEF] curoff curoff [THEN]
		dup bl < IF
		    CASE
			#cr OF  ENDOF
			#lf OF  cr  ENDOF
			[IFDEF] del #bs OF  del  ENDOF [THEN]
			dup emit  ENDCASE
		    ELSE  emit  THEN
		[IFDEF] tflush tflush [ELSE] key? drop [THEN]
		[IFDEF] curon curon [THEN] [IFDEF] pause pause [THEN] ;
: tx?>		1 ;
: rxd>		key [IFDEF] curon curon [THEN] ;
: rx?>		key? 1 and [IFDEF] pause pause [THEN] ;

\ Arithmetic

: accu!	( u -- ) dup 0= zf ! dup $8000 and 0<> sf ! $FFFF and accu ! ;		

: >shr  cf @ >r dup 1 and 0<> cf !
    1 rshift r> IF $8000 or THEN accu! ;
: >xor  accu @ xor accu! ;
: >or   accu @ or accu! ;
: >and  accu @ and accu! ;

: (>sub) 2dup u< cf ! - accu! ;
: >sub9	 accu @ swap (>sub) ;
: >subA  accu @ (>sub) ;
 
: >add	 accu @ + $FFFF and dup accu @ u< cf ! accu! ;

: sf>	sf @ 1 and ;
: zf>	zf @ 1 and ;
: cf>	cf @ 1 and ;

: accu>		accu @ ;
: >accu		accu! ;

: aind> accu @ ram> ;
: >aind accu @ >ram ;

: crash  -$200 throw ;

create table>
	' crash ,	' tx?> ,	' rxd> ,	' rx?> ,
	' pc> ,		' pc> ,		' pc> ,		' pc> ,
	' crash ,	' crash ,	' crash ,	' aind> ,
	' accu> ,	' sf> ,		' zf> ,		' crash ,
	' cf> ,		' crash ,	' crash ,	' crash ,

create >table
	' >txd ,	' crash ,	' crash ,	' crash ,
	' >pc ,		' >pcsf , 	' >pczf ,	' crash ,
	' >pccf ,	' crash ,	' crash ,	' >aind ,
	' >accu ,	' >sub9 ,	' >suba ,	' >add ,
	' >xor ,	' >or ,		' >and ,	' >shr ,
	
: special? ( n -- ) $10 $FFFC within 0= ;

' special? ALIAS special>?	' special? ALIAS >special?

: dotable ( /trans table n -- trans/ )
    4 + $FFFF and cells + perform ;

: do>	( -- val )
	src @ >special?
	IF	table> src @ dotable
	ELSE	src @ ram> 
	THEN  ;

: >do	( val -- )
	dst @ >special?
	IF	>table dst @ dotable
	ELSE	dst @ >ram
	THEN ;

variable trans -1 trans !

: .stat
	." PC: " pc-old @ .#### 
	." : " src @ .####
	." -( " trans @ .####
	." )-> " dst @ .####
        ." ACCU: " accu @ .#### ;

variable steps 0 steps !

: step  1 steps +!
	pc @ pc-old !
	pc @ ram> src !
	pc @ 1+ ram> dst !
	do> 	pc @ 2 + pc !
		dup trans ! 
	>do ;

: s step .stat cr ;

: load	
	bl word count r/o bin open-file throw >r
	mem mem-size @ r@ read-file throw
	r> close-file throw 
	. cr ;

: n,	ndp @ >ram 1 ndp +! ;


\ DUMP                       2may93jaw - 9may93jaw    06jul93py

Variable /dump

: .4 ( addr -- addr' )
    3 FOR  -1 /dump +!  /dump @ 0<
        IF  ."    "  ELSE  dup c@ 0 <# # # #> type space  THEN
    char+ NEXT ;
: .chars ( addr -- )
    /dump @ bounds
    ?DO I c@ dup $7F bl within
	IF  drop [char] .  THEN  emit
    LOOP ;

: .line ( addr -- )
  dup .4 space .4 ." - " .4 space .4 drop  10 /dump +!  space .chars ;

: d  ( addr u -- )
    swap 2* mem + swap
    cr base @ >r hex        \ save base on return stack
    0 ?DO  I' I - 10 min /dump !
        dup mem - 2/ 8 u.r ." : " dup .line cr  10 +
        10 +LOOP
    drop r> base ! ;

defer end? ' noop IS end?

variable t1 variable t2

: token2 t1 @ src @ = t2 @ dst @ = and or ;

: jmp?   dst @ 5 < or ;
: surejmp? dst @ 0= or ;

: st
  dup ram> t1 ! 1+ ram> t2 ! 
  ['] token2 IS end? ;

: stepinto BEGIN step false end? UNTIL ;

: g
    [IFDEF] curon curon [THEN]
    BEGIN step AGAIN
    [IFDEF] curoff curoff [THEN] ;

: si stepinto ." Stopped" cr .stat cr ;

variable stepcnt

: sq s 
	BEGIN key steps @ stepcnt ! CASE 
		[char] q OF EXIT ENDOF
		[char] j OF ['] jmp? IS end? stepinto ENDOF
		[char] s OF ['] surejmp? IS end? stepinto ENDOF
		[char] g OF ['] g catch -$200 = IF ." crashed " THEN  ENDOF
		step
		ENDCASE
		." [" steps @ stepcnt @ - 0 <# #S #> type ." ]"
		.stat cr
	AGAIN ;