![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prim.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / 8086|
Return to prim.fs CVS log | Up to [gforth] / gforth / arch / 8086 |
1.1 pazsan 1: \ **************************************************************
2: \ File: PRIMS.FS
3: \ Lowlevel routines for GFORTH on 8086 (PC)
4: \ Autor: Klaus Kohl
5: \ Log: 30.07.97 KK: file generated (from KK-FORTH)
6: \
7: \ * Register using for 8086 on PC (like KK-FORTH):
8: \ Intel Forth used for 8bit-Register
9: \ BX TOS oberstes Stackelement TOSH TOSL
10: \ BP FRP Returnstack Pointer
11: \ SP FSP Stack Pointer
12: \ SI FIP Instruction Pointer
13: \ DI W Arbeitsregister
14: \
15: \ * Memory ( use only one 64K-Page ):
16: \ $0080-$00FF : TIB
17: \ $0100-$F800 : program
18: \ $F800-$FC00 : datastack
19: \ $FC00-$FFFF : returnstack
20: \ **************************************************************
21:
22:
23: start-macros
24: \ register definition
25: ' sp Alias fsp
26: ' bp Alias frp
27: ' bx Alias tos ' bl Alias tosl ' bh Alias tosh
28: ' si Alias fip
29: ' di Alias w
30:
31: \ system depending macros
32: : next,
33: lods,
34: ax w xchg,
35: w ) jmp, ;
36: \ note that this is really for 8086 and 286, and _not_ intented to run
37: \ fast on a Pentium (Pro). These old chips load their code from real RAM
38: \ and do it slow, anyway.
39: \ If you really want to have a fast 16 bit Forth on modern processors,
40: \ redefine it as
41: \ : next, fip ) w mov, 2 # fip add, w ) jmp, ;
42:
43: end-macros
44:
45: unlock
46: $0100 $f000 region dictionary
47: setup-target
48: lock
49:
50: \ ==============================================================
51: \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!)
52: \ ==============================================================
53: Label into-forth
54: $ffff # fip mov, \ ip will be patched
55: $fef0 # fsp mov, \ sp at $FD80...$FEF0
56: $fd80 # frp mov, \ rp at $F.00...$FD80
57: next,
58: End-Label
59:
60:
61: \ output debug information
62: Label (dout) \ like (emit) with character in dl
63: 6 # ah mov,
64: $21 int,
65: ret,
66: End-Label
67:
68: Start-Macros
69: \ : dout, ( char -- )
70: \ # dl byte mov,
71: \ (dout) # call, ;
72: : dout, drop ; \ no debug output
73: end-macros
74:
75:
76: \ ==============================================================
77: \ GFORTH minimal primitive set
78: \ ==============================================================
79: \ inner interpreter
80: Code: :docol
81: ': dout, \ only for debugging
82: frp dec, frp dec, fip frp ) mov, \ save ip
83: 4 w d) fip lea, \ calc pfa
84: next,
85: End-Code
86:
87: Code: :dovar
88: '2 dout, \ only for debugging
89: tos push,
90: 4 w d) tos lea,
91: next,
92: End-Code
93:
94: Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part
95: '6 dout, \ only for debugging
96: frp dec, frp dec, fip frp ) mov, \ save ip
97: 2 # w add, \
98: w ) fip mov, \ get does> address
99: tos push, \ save tos
100: 2 # w add,
101: w tos mov, \ copy pfa to tos
102: next, \ execute does> part
103: End-Code
104:
105:
106: \ program flow
107: Code ;s ( -- ) \ exit colon definition
108: '; dout, \ only for debugging
109: frp ) fip mov, frp inc, frp inc, \ get ip
110: next,
111: End-Code
112:
113: Code execute ( xt -- ) \ execute colon definition
114: 'E dout, \ only for debugging
115: tos w mov, \ copy tos to w
116: tos pop, \ get new tos
117: w ) jmp, \ execute
118: End-Code
119:
120: Code ?branch ( f -- ) \ jump on f<>0
121: tos tos or, tos pop, \ check and get new tos
122: 0= IF, fip ) fip add, next, \ jump
123: ELSE, fip inc, fip inc, next, THEN, \ skip
124: End-Code
125:
126:
127: \ memory access
128: Code @ ( addr -- n ) \ read cell
129: tos ) tos mov,
130: next,
131: End-Code
132:
133: Code ! ( n addr -- ) \ write cell
134: tos ) pop,
135: tos pop,
136: next,
137: End-Code
138:
139:
140: \ datastack and returnstack address
141: Code sp@ ( -- sp ) \ get stack address
142: tos push,
143: fsp tos mov,
144: next,
145: End-Code
146:
147: Code sp! ( sp -- ) \ set stack address
148: tos fsp mov,
149: tos pop,
150: next,
151: End-Code
152:
153: Code rp@ ( -- rp ) \ get returnstack address
154: tos push,
155: frp tos mov,
156: next,
157: End-Code
158:
159: Code rp! ( rp -- ) \ set returnstack address
160: tos frp mov,
161: tos pop,
162: next,
163: End-Code
164:
165:
166: \ arithmetic and logic
167: Code + ( n1 n2 -- n3 ) \ addition
168: ax pop,
169: ax tos add,
170: next,
171: End-Code
172:
173: Code xor ( n1 n2 -- n3 ) \ logic XOR
174: ax pop,
175: ax tos xor,
176: next,
177: End-Code
178:
179: Code and ( n1 n2 -- n3 ) \ logic AND
180: ax pop,
181: ax tos and,
182: next,
183: End-Code
184:
185:
186: \ i/o
187: Variable lastkey \ Flag und Zeichencode der letzen Taste
188:
189: Code (key) ( -- char ) \ get character
190: tos push,
191: lastkey #) ax mov,
192: ah ah or, 0= IF, 7 # ah mov, $21 int, THEN,
193: 0 # lastkey #) mov,
194: ah ah xor,
195: ax tos mov,
196: next,
197: End-Code
198:
199: Code (emit) ( char -- ) \ output character
200: tosl dl mov,
201: 6 # ah mov,
202: $ff # dl cmp, 0= IF, dl dec, THEN,
203: $21 int,
204: tos pop,
205: next,
206: End-Code
207:
208: \ ==============================================================
209: \ additional words (for awaitable response)
210: \ ==============================================================
211: \ memory character access
212: Code c@ ( addr -- c ) \ read character
213: tos ) tosl mov,
214: tosh tosh xor,
215: next,
216: End-Code
217:
218: Code c! ( c addr -- ) \ write character
219: ax pop,
220: al tos ) mov,
221: tos pop,
222: next,
223: End-Code
224:
225:
226: \ moving datas between stacks
227: Code r> ( -- n ; R: n -- )
228: tos push,
229: frp ) tos mov, frp inc, frp inc,
230: next,
231: End-Code
232:
233: Code >r ( n -- ; R: -- n )
234: frp dec, frp dec, tos frp ) mov,
235: tos pop,
236: next,
237: End-Code
238:
239: \ ==============================================================
240: \ usefull lowlevel words
241: \ ==============================================================
242: \ word definitions
243:
244: Code: :docon
245: '1 dout, \ only for debugging
246: tos push,
247: 4 w d) tos lea,
248: tos ) tos mov,
249: next,
250: End-Code
251:
252: Code: :dodefer
253: '4 dout, \ only for debugging
254: 4 w d) w mov,
255: w ) jmp,
256: End-Code
257:
258:
259: \ branch and literal
260: Code branch ( -- ) \ unconditional branch
261: fip ) fip add,
262: next,
263: End-Code
264:
265: Code lit ( -- n ) \ inline literal
266: tos push,
267: lods,
268: ax tos mov,
269: next,
270: End-Code
271:
272:
273: \ data stack words
274: Code dup ( n -- n n )
275: tos push,
276: next,
277: End-Code
278:
279: Code 2dup ( d -- d d )
280: ax pop,
281: ax push,
282: tos push,
283: ax push,
284: next,
285: End-Code
286:
287: Code drop ( n -- )
288: tos pop,
289: next,
290: End-Code
291:
292: Code 2drop ( d -- )
293: 2 # fsp add,
294: tos pop,
295: next,
296: End-Code
297:
298: Code swap ( n1 n2 -- n2 n1 )
299: ax pop,
300: tos push,
301: ax tos mov,
302: next,
303: End-Code
304:
305: Code over ( n1 n2 -- n1 n2 n1 )
306: tos ax mov,
307: tos pop,
308: tos push,
309: ax push,
310: next,
311: End-Code
312:
313: Code rot ( n1 n2 n3 -- n2 n3 n1 )
314: tos ax mov,
315: cx pop,
316: tos pop,
317: cx push,
318: ax push,
319: next,
320: End-Code
321:
322: Code -rot ( n1 n2 n3 -- n3 n1 n2 )
323: tos ax mov,
324: tos pop,
325: cx pop,
326: ax push,
327: cx push,
328: next,
329: End-Code
330:
331:
332: \ return stack
333: Code r@ ( -- n ; R: n -- n )
334: tos push,
335: frp ) tos mov,
336: next,
337: End-Code
338:
339:
340: \ arithmetic
341: Code - ( n1 n2 -- n3 ) \ Subtraktion
342: ax pop,
343: tos ax sub,
344: ax tos mov,
345: next,
346: End-Code
347:
348: Code um* ( u1 u2 -- ud ) \ unsigned multiply
349: tos ax mov,
350: cx pop,
351: cx mul,
352: ax push,
353: dx tos mov,
354: next,
355: End-Code
356:
357: Code um/mod ( ud u -- r q ) \ unsiged divide
358: tos cx mov,
359: dx pop,
360: ax pop,
361: cx div,
362: dx push,
363: ax tos mov,
364: next,
365: End-Code
366:
367:
368: \ logic
369: Code or ( n1 n2 -- n3 ) \ logic OR
370: ax pop, ax tos or, next,
371: End-Code
372:
373:
374: \ shift
375: Code 2/ ( n1 -- n2 ) \ arithmetic shift right
376: tos sar,
377: next,
378: End-Code
379:
380: Code lshift ( n1 n2 -- n3 ) \ shift n1 left n2 bits
381: tos cx mov,
382: tos pop,
383: cx cx or, 0<> IF, tos c* shl, THEN,
384: next,
385: End-Code
386:
387: Code rshift ( n1 n2 -- n3 ) \ shift n1 right n2 bits
388: tos cx mov,
389: tos pop,
390: cx cx or, 0<> IF, tos c* shr, THEN,
391: next,
392: End-Code
393:
394:
395: \ compare
396: Code 0= ( n -- f ) \ Test auf 0
397: tos tos or,
398: 0 # tos mov,
399: 0= IF, tos dec, THEN,
400: next,
401: End-Code
402:
403: Code = ( n1 n2 -- f ) \ Test auf Gleichheit
404: ax pop,
405: ax tos sub,
406: 0= IF, -1 # tos mov, next,
407: ELSE, 0 # tos mov, next,
408: THEN,
409: End-Code
410:
411:
412: \ additon io routines
1.2 pazsan 413: Code (key?) ( -- f ) \ check for read sio character
1.1 pazsan 414: tos push, lastkey # tos mov,
415: 1 tos d) ah mov, ah ah or,
416: 0= IF, $ff # dl mov, 6 # ah mov, $21 int,
417: 0 # ah mov,
418: 0<> IF, dl ah mov, ax tos ) mov, THEN,
419: THEN, ah tosl mov, ah tosh mov,
420: next,
421: End-Code
422:
423: Code emit? ( -- f ) \ check for write character to sio
424: tos push,
425: -1 # tos mov, \ output always possible
426: next,
427: End-Code
428:
429: \ ======================== not ready ============================
430: 0 [IF] \ not jet adapted
431:
432: \ ======================== not ready ============================
433: [ENDIF]
434:
435: Code bye ( -- ) \ back to DOS
436: 0 # al mov, $4c # ah mov, $21 int,
437: End-Code
438:
1.2 pazsan 439: -9 Alias: :doesjump