File:  [gforth] / gforth / arch / misc / sim.fs
Revision 1.6: download - view: text, annotated - select for diffs
Sun Aug 17 22:52:33 2003 UTC (20 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: v0-6-2, HEAD
Started to fix Gforth EC (4stack and MISC work again)

    1: 
    2: decimal
    3: 
    4: : .####  base @ >r hex
    5: 	0 <# # # # # #> type space r> base ! ;
    6: 
    7: variable ndp	: here ndp @ ;
    8: variable src	variable dst	variable pc	$10 pc !
    9: Variable pc-old
   10: 
   11: variable zf
   12: variable sf
   13: variable cf
   14: 
   15: variable accu
   16: 
   17: variable mem-size	128 1024 * mem-size !
   18: mem-size @ allocate throw
   19: constant mem 
   20: 
   21: 0 ndp !
   22: 
   23: \ Jumping
   24: 
   25: : pc>		src @ 2* pc @ + ;
   26: : >pc 		pc ! ;
   27: : >pcsf		sf @ IF >pc ELSE drop THEN ;
   28: : >pczf		zf @ IF >pc ELSE drop THEN ;
   29: : >pccf		cf @ IF >pc ELSE drop THEN ;
   30: 
   31: \ Memory
   32: 
   33: : ram>		2* mem + dup c@ 8 lshift swap char+ c@ or ;
   34: 
   35: : >ram		\ dup $4000 u< ABORT" Memory below $4000 is read-only"
   36:                 2* mem + over 8 rshift over c! char+ c! ;
   37: 
   38: \ IO
   39: 
   40: variable nesting 0 nesting !
   41: : .hs
   42: 	." RP: " $4000 ram> .####
   43: 	." SP: " $4001 ram> .####
   44: 	." UP: " $4002 ram> .#### ;
   45: 
   46: : .ip
   47: 	$4003 ram> ." IP: " .#### ;
   48: : trace
   49: 		cr nesting @ spaces 
   50: 		dup CASE [char] : OF 1 nesting +! .ip ENDOF 
   51: 		[char] ; OF -1 nesting +! ENDOF ENDCASE ;
   52: 
   53: : >txd		
   54: \                trace
   55: 		[IFDEF] curoff curoff [THEN]
   56: 		dup bl < IF
   57: 		    CASE
   58: 			#cr OF  ENDOF
   59: 			#lf OF  cr  ENDOF
   60: 			[IFDEF] del #bs OF  del  ENDOF [THEN]
   61: 			dup emit  ENDCASE
   62: 		    ELSE  emit  THEN
   63: 		[IFDEF] tflush tflush [ELSE] key? drop [THEN]
   64: 		[IFDEF] curon curon [THEN] [IFDEF] pause pause [THEN] ;
   65: : tx?>		1 ;
   66: : rxd>		key [IFDEF] curon curon [THEN] ;
   67: : rx?>		key? 1 and [IFDEF] pause pause [THEN] ;
   68: 
   69: \ Arithmetic
   70: 
   71: : accu!	( u -- ) dup 0= zf ! dup $8000 and 0<> sf ! $FFFF and accu ! ;		
   72: 
   73: : >shr  cf @ >r dup 1 and 0<> cf !
   74:     1 rshift r> IF $8000 or THEN accu! ;
   75: : >xor  accu @ xor accu! ;
   76: : >or   accu @ or accu! ;
   77: : >and  accu @ and accu! ;
   78: 
   79: : (>sub) 2dup u< cf ! - accu! ;
   80: : >sub9	 accu @ swap (>sub) ;
   81: : >subA  accu @ (>sub) ;
   82:  
   83: : >add	 accu @ + $FFFF and dup accu @ u< cf ! accu! ;
   84: 
   85: : sf>	sf @ 1 and ;
   86: : zf>	zf @ 1 and ;
   87: : cf>	cf @ 1 and ;
   88: 
   89: : accu>		accu @ ;
   90: : >accu		accu! ;
   91: 
   92: : aind> accu @ ram> ;
   93: : >aind accu @ >ram ;
   94: 
   95: : crash  -$200 throw ;
   96: 
   97: create table>
   98: 	' crash ,	' tx?> ,	' rxd> ,	' rx?> ,
   99: 	' pc> ,		' pc> ,		' pc> ,		' pc> ,
  100: 	' crash ,	' crash ,	' crash ,	' aind> ,
  101: 	' accu> ,	' sf> ,		' zf> ,		' crash ,
  102: 	' cf> ,		' crash ,	' crash ,	' crash ,
  103: 
  104: create >table
  105: 	' >txd ,	' crash ,	' crash ,	' crash ,
  106: 	' >pc ,		' >pcsf , 	' >pczf ,	' crash ,
  107: 	' >pccf ,	' crash ,	' crash ,	' >aind ,
  108: 	' >accu ,	' >sub9 ,	' >suba ,	' >add ,
  109: 	' >xor ,	' >or ,		' >and ,	' >shr ,
  110: 	
  111: : special? ( n -- ) $10 $FFFC within 0= ;
  112: 
  113: ' special? ALIAS special>?	' special? ALIAS >special?
  114: 
  115: : dotable ( /trans table n -- trans/ )
  116:     4 + $FFFF and cells + perform ;
  117: 
  118: : do>	( -- val )
  119: 	src @ >special?
  120: 	IF	table> src @ dotable
  121: 	ELSE	src @ ram> 
  122: 	THEN  ;
  123: 
  124: : >do	( val -- )
  125: 	dst @ >special?
  126: 	IF	>table dst @ dotable
  127: 	ELSE	dst @ >ram
  128: 	THEN ;
  129: 
  130: variable trans -1 trans !
  131: 
  132: : .stat
  133: 	." PC: " pc-old @ .#### 
  134: 	." : " src @ .####
  135: 	." -( " trans @ .####
  136: 	." )-> " dst @ .####
  137:         ." ACCU: " accu @ .#### ;
  138: 
  139: variable steps 0 steps !
  140: 
  141: : step  1 steps +!
  142: 	pc @ pc-old !
  143: 	pc @ ram> src !
  144: 	pc @ 1+ ram> dst !
  145: 	do> 	pc @ 2 + pc !
  146: 		dup trans ! 
  147: 	>do ;
  148: 
  149: : s step .stat cr ;
  150: 
  151: : load	
  152: 	bl word count r/o bin open-file throw >r
  153: 	mem mem-size @ r@ read-file throw
  154: 	r> close-file throw 
  155: 	. cr ;
  156: 
  157: : n,	ndp @ >ram 1 ndp +! ;
  158: 
  159: 
  160: \ DUMP                       2may93jaw - 9may93jaw    06jul93py
  161: 
  162: Variable /dump
  163: 
  164: : .4 ( addr -- addr' )
  165:     3 FOR  -1 /dump +!  /dump @ 0<
  166:         IF  ."    "  ELSE  dup c@ 0 <# # # #> type space  THEN
  167:     char+ NEXT ;
  168: : .chars ( addr -- )
  169:     /dump @ bounds
  170:     ?DO I c@ dup $7F bl within
  171: 	IF  drop [char] .  THEN  emit
  172:     LOOP ;
  173: 
  174: : .line ( addr -- )
  175:   dup .4 space .4 ." - " .4 space .4 drop  10 /dump +!  space .chars ;
  176: 
  177: : d  ( addr u -- )
  178:     swap 2* mem + swap
  179:     cr base @ >r hex        \ save base on return stack
  180:     0 ?DO  I' I - 10 min /dump !
  181:         dup mem - 2/ 8 u.r ." : " dup .line cr  10 +
  182:         10 +LOOP
  183:     drop r> base ! ;
  184: 
  185: defer end? ' noop IS end?
  186: 
  187: variable t1 variable t2
  188: 
  189: : token2 t1 @ src @ = t2 @ dst @ = and or ;
  190: 
  191: : jmp?   dst @ 5 < or ;
  192: : surejmp? dst @ 0= or ;
  193: 
  194: : st
  195:   dup ram> t1 ! 1+ ram> t2 ! 
  196:   ['] token2 IS end? ;
  197: 
  198: : stepinto BEGIN step false end? UNTIL ;
  199: 
  200: : g
  201:     [IFDEF] curon curon [THEN]
  202:     BEGIN step AGAIN
  203:     [IFDEF] curoff curoff [THEN] ;
  204: 
  205: : si stepinto ." Stopped" cr .stat cr ;
  206: 
  207: variable stepcnt
  208: 
  209: : sq s 
  210: 	BEGIN key steps @ stepcnt ! CASE 
  211: 		[char] q OF EXIT ENDOF
  212: 		[char] j OF ['] jmp? IS end? stepinto ENDOF
  213: 		[char] s OF ['] surejmp? IS end? stepinto ENDOF
  214: 		[char] g OF ['] g catch -$200 = IF ." crashed " THEN  ENDOF
  215: 		step
  216: 		ENDCASE
  217: 		." [" steps @ stepcnt @ - 0 <# #S #> type ." ]"
  218: 		.stat cr
  219: 	AGAIN ;
  220: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>