1: \ MISC simulator
2:
3: \ Copyright (C) 1998,2000,2003,2004,2007 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation, either version 3
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program. If not, see http://www.gnu.org/licenses/.
19:
20: decimal
21:
22: : .#### base @ >r hex
23: 0 <# # # # # #> type space r> base ! ;
24:
25: variable ndp : here ndp @ ;
26: variable src variable dst variable pc $10 pc !
27: Variable pc-old
28:
29: variable zf
30: variable sf
31: variable cf
32:
33: variable accu
34:
35: variable mem-size 128 1024 * mem-size !
36: mem-size @ allocate throw
37: constant mem
38:
39: 0 ndp !
40:
41: \ Jumping
42:
43: : pc> src @ 2* pc @ + ;
44: : >pc pc ! ;
45: : >pcsf sf @ IF >pc ELSE drop THEN ;
46: : >pczf zf @ IF >pc ELSE drop THEN ;
47: : >pccf cf @ IF >pc ELSE drop THEN ;
48:
49: \ Memory
50:
51: : ram> 2* mem + dup c@ 8 lshift swap char+ c@ or ;
52:
53: : >ram \ dup $4000 u< ABORT" Memory below $4000 is read-only"
54: 2* mem + over 8 rshift over c! char+ c! ;
55:
56: \ IO
57:
58: variable nesting 0 nesting !
59: : .hs
60: ." RP: " $4000 ram> .####
61: ." SP: " $4001 ram> .####
62: ." UP: " $4002 ram> .#### ;
63:
64: : .ip
65: $4003 ram> ." IP: " .#### ;
66: : trace
67: cr nesting @ spaces
68: dup CASE [char] : OF 1 nesting +! .ip ENDOF
69: [char] ; OF -1 nesting +! ENDOF ENDCASE ;
70:
71: : >txd
72: \ trace
73: [IFDEF] curoff curoff [THEN]
74: dup bl < IF
75: CASE
76: #cr OF ENDOF
77: #lf OF cr ENDOF
78: [IFDEF] del #bs OF del ENDOF [THEN]
79: dup emit ENDCASE
80: ELSE emit THEN
81: [IFDEF] tflush tflush [ELSE] key? drop [THEN]
82: [IFDEF] curon curon [THEN] [IFDEF] pause pause [THEN] ;
83: : tx?> 1 ;
84: : rxd> key [IFDEF] curon curon [THEN] ;
85: : rx?> key? 1 and [IFDEF] pause pause [THEN] ;
86:
87: \ Arithmetic
88:
89: : accu! ( u -- ) dup 0= zf ! dup $8000 and 0<> sf ! $FFFF and accu ! ;
90:
91: : >shr cf @ >r dup 1 and 0<> cf !
92: 1 rshift r> IF $8000 or THEN accu! ;
93: : >xor accu @ xor accu! ;
94: : >or accu @ or accu! ;
95: : >and accu @ and accu! ;
96:
97: : (>sub) 2dup u< cf ! - accu! ;
98: : >sub9 accu @ swap (>sub) ;
99: : >subA accu @ (>sub) ;
100:
101: : >add accu @ + $FFFF and dup accu @ u< cf ! accu! ;
102:
103: : sf> sf @ 1 and ;
104: : zf> zf @ 1 and ;
105: : cf> cf @ 1 and ;
106:
107: : accu> accu @ ;
108: : >accu accu! ;
109:
110: : aind> accu @ ram> ;
111: : >aind accu @ >ram ;
112:
113: : crash -$200 throw ;
114:
115: create table>
116: ' crash , ' tx?> , ' rxd> , ' rx?> ,
117: ' pc> , ' pc> , ' pc> , ' pc> ,
118: ' crash , ' crash , ' crash , ' aind> ,
119: ' accu> , ' sf> , ' zf> , ' crash ,
120: ' cf> , ' crash , ' crash , ' crash ,
121:
122: create >table
123: ' >txd , ' crash , ' crash , ' crash ,
124: ' >pc , ' >pcsf , ' >pczf , ' crash ,
125: ' >pccf , ' crash , ' crash , ' >aind ,
126: ' >accu , ' >sub9 , ' >suba , ' >add ,
127: ' >xor , ' >or , ' >and , ' >shr ,
128:
129: : special? ( n -- ) $10 $FFFC within 0= ;
130:
131: ' special? ALIAS special>? ' special? ALIAS >special?
132:
133: : dotable ( /trans table n -- trans/ )
134: 4 + $FFFF and cells + perform ;
135:
136: : do> ( -- val )
137: src @ >special?
138: IF table> src @ dotable
139: ELSE src @ ram>
140: THEN ;
141:
142: : >do ( val -- )
143: dst @ >special?
144: IF >table dst @ dotable
145: ELSE dst @ >ram
146: THEN ;
147:
148: variable trans -1 trans !
149:
150: : .stat
151: ." PC: " pc-old @ .####
152: ." : " src @ .####
153: ." -( " trans @ .####
154: ." )-> " dst @ .####
155: ." ACCU: " accu @ .#### ;
156:
157: variable steps 0 steps !
158:
159: : step 1 steps +!
160: pc @ pc-old !
161: pc @ ram> src !
162: pc @ 1+ ram> dst !
163: do> pc @ 2 + pc !
164: dup trans !
165: >do ;
166:
167: : s step .stat cr ;
168:
169: : load
170: bl word count r/o bin open-file throw >r
171: mem mem-size @ r@ read-file throw
172: r> close-file throw
173: . cr ;
174:
175: : n, ndp @ >ram 1 ndp +! ;
176:
177:
178: \ DUMP 2may93jaw - 9may93jaw 06jul93py
179:
180: Variable /dump
181:
182: : .4 ( addr -- addr' )
183: 3 FOR -1 /dump +! /dump @ 0<
184: IF ." " ELSE dup c@ 0 <# # # #> type space THEN
185: char+ NEXT ;
186: : .chars ( addr -- )
187: /dump @ bounds
188: ?DO I c@ dup $7F bl within
189: IF drop [char] . THEN emit
190: LOOP ;
191:
192: : .line ( addr -- )
193: dup .4 space .4 ." - " .4 space .4 drop 10 /dump +! space .chars ;
194:
195: : d ( addr u -- )
196: swap 2* mem + swap
197: cr base @ >r hex \ save base on return stack
198: 0 ?DO I' I - 10 min /dump !
199: dup mem - 2/ 8 u.r ." : " dup .line cr 10 +
200: 10 +LOOP
201: drop r> base ! ;
202:
203: defer end? ' noop IS end?
204:
205: variable t1 variable t2
206:
207: : token2 t1 @ src @ = t2 @ dst @ = and or ;
208:
209: : jmp? dst @ 5 < or ;
210: : surejmp? dst @ 0= or ;
211:
212: : st
213: dup ram> t1 ! 1+ ram> t2 !
214: ['] token2 IS end? ;
215:
216: : stepinto BEGIN step false end? UNTIL ;
217:
218: : g
219: [IFDEF] curon curon [THEN]
220: BEGIN step AGAIN
221: [IFDEF] curoff curoff [THEN] ;
222:
223: : si stepinto ." Stopped" cr .stat cr ;
224:
225: variable stepcnt
226:
227: : sq s
228: BEGIN key steps @ stepcnt ! CASE
229: [char] q OF EXIT ENDOF
230: [char] j OF ['] jmp? IS end? stepinto ENDOF
231: [char] s OF ['] surejmp? IS end? stepinto ENDOF
232: [char] g OF ['] g catch -$200 = IF ." crashed " THEN ENDOF
233: step
234: ENDCASE
235: ." [" steps @ stepcnt @ - 0 <# #S #> type ." ]"
236: .stat cr
237: AGAIN ;
238:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sim.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / misc