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