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: ' R0L Alias tos.b
36:
37: \ hfs wichtig, damit der erste Befehl richtig compiliert wird
38: reset \ hfs
39:
40: \ system depending macros
41: : next1,
42: [w] , r1 mov.w:g r1 jmpi.a ;
43: : next,
44: [ip] , w mov.w:g
45: # 2 , ip add.w:q next1, ;
46: \ note that this is really for 8086 and 286, and _not_ intented to run
47: \ fast on a Pentium (Pro). These old chips load their code from real RAM
48: \ and do it slow, anyway.
49: \ If you really want to have a fast 16 bit Forth on modern processors,
50: \ redefine it as
51: \ : next, [ip] w mov, 2 # ip add, [w] jmp, ;
52:
53: end-macros
54:
55: unlock
56: $0000 $FFFF region address-space
57: $C000 $4000 region rom-dictionary
58: $0400 $0400 region ram-dictionary
59: .regions
60: setup-target
61: lock
62:
63: \ ==============================================================
64: \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!)
65: \ ==============================================================
66: Label into-forth
67: # $ffff , ip mov.w:g \ ip will be patched
68: # $07FE , sp ldc \ sp at $0700...$07FE
69: # $0700 , rp mov.w:g \ rp at $0600...$0700
70: # $0F , $E3 mov.b:g
71: # $0F , $E1 mov.b:g
72: Label clock-init \ default is 125kHz/8
73: # $01 , $0A mov.b:g
74: # $28 , $07 mov.b:g
75: # $08 , $06 mov.b:g
76: # $00 , $0A mov.b:g
77: r1 , r1 mov.w:g
78: r1 , r1 mov.w:g
79: r1 , r1 mov.w:g
80: r1 , r1 mov.w:g
81: # $00 , $08 mov.b:g \ set to 20MHz
82: Label uart-init
83: # $23 , $B0 mov.b:g \ hfs
84: # $8105 , $A8 mov.w:g \ ser1: 9600 baud, 8N1 \ hfs
85: # $0500 , $AC mov.w:g \ hfs
86: next,
87: End-Label
88:
89:
90: \ ==============================================================
91: \ GFORTH minimal primitive set
92: \ ==============================================================
93: \ inner interpreter
94: Code: :docol
95: \ ': dout, \ only for debugging
96: # -2 , rp add.w:q
97: w , r1 mov.w:g
98: rp , w mov.w:g ip , [w] mov.w:g
99: # 4 , r1 add.w:q r1 , ip mov.w:g
100: next,
101: End-Code
102:
103: Code: :dovar
104: \ '2 dout, \ only for debugging
105: tos push.w:g
106: # 4 , w add.w:q
107: w , tos mov.w:g
108: next,
109: End-Code
110:
111: Code: :docon
112: \ '2 dout, \ only for debugging
113: tos push.w:g
114: 4 [w] , tos mov.w:g
115: next,
116: End-Code
117:
118: Code: :dovalue
119: \ '2 dout, \ only for debugging
120: tos push.w:g
121: 4 [w] , w mov.w:g [w] , tos mov.w:g
122: next,
123: End-Code
124:
125: Code: :dodefer
126: \ # $05 , $E1 mov.b:g
127: 4 [w] , w mov.w:g [w] , w mov.w:g
128: next1,
129: End-Code
130:
131: Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part
132: \ '6 dout, \ only for debugging
133: \ # $06 , $E1 mov.b:g
134: tos push.w:g
135: w , tos mov.w:g # 4 , tos add.w:q
136: # -2 , rp add.w:q
137: 2 [w] , r1 mov.w:g
138: rp , w mov.w:g ip , [w] mov.w:g
139: # 4 , r1 add.w:q r1 , ip mov.w:g
140: next, \ execute does> part
141: End-Code
142:
143: \ program flow
144: Code ;s ( -- ) \ exit colon definition
145: \ '; dout, \ only for debugging
146: rp , w mov.w:g # 2 , rp add.w:q
147: [w] , ip mov.w:g
148: next,
149: End-Code
150:
151: Code execute ( xt -- ) \ execute colon definition
152: \ 'E dout, \ only for debugging
153: \ # $07 , $E1 mov.b:g
154: tos , w mov.w:g \ copy tos to w
155: tos pop.w:g \ get new tos
156: next1,
157: End-Code
158:
159: Code ?branch ( f -- ) \ jump on f=0
160: # 2 , ip add.w:q
161: tos , tos tst.w 0= IF -2 [ip] , ip mov.w:g THEN
162: next,
163: End-Code
164:
165: Code (for) ( n -- r:0 r:n )
166: # -4 , rp add.w:q rp , w mov.w:g
167: r3 , 2 [w] mov.w:g
168: tos , [w] mov.w:g
169: tos pop.w:g
170: next,
171: End-Code
172:
173: Code (?do) ( n -- r:0 r:n )
174: # 2 , ip add.w:q
175: # -4 , rp add.w:q rp , w mov.w:g
176: tos , [w] mov.w:g
177: r1 pop.w:g
178: r1 , 2 [w] mov.w:g
179: tos pop.w:g
180: [w] , r1 sub.w:g
181: 0= IF -2 [ip] , ip mov.w:g THEN
182: next,
183: End-Code
184:
185: Code (do) ( n -- r:0 r:n )
186: # -4 , rp add.w:q rp , w mov.w:g
187: tos , [w] mov.w:g
188: tos pop.w:g
189: tos , 2 [w] mov.w:g
190: tos pop.w:g
191: next,
192: End-Code
193:
194: Code (next) ( -- )
195: # 2 , ip add.w:q
196: rp , w mov.w:g [w] , r1 mov.w:g
197: # -1 , r1 add.w:q r1 , [w] mov.w:g
198: u>= IF -2 [ip] , ip mov.w:g THEN
199: next,
200: End-Code
201:
202: Code (loop) ( -- )
203: # 2 , ip add.w:q
204: rp , w mov.w:g [w] , r1 mov.w:g
205: # 1 , r1 add.w:q r1 , [w] mov.w:g
206: 2 [w] , r1 sub.w:g
207: 0<> IF -2 [ip] , ip mov.w:g THEN
208: next,
209: End-Code
210:
211: \ memory access
212: Code @ ( addr -- n ) \ read cell
213: tos , w mov.w:g [w] , tos mov.w:g
214: next,
215: End-Code
216:
217: Code ! ( n addr -- ) \ write cell
218: tos , w mov.w:g tos pop.w:g tos , [w] mov.w:g
219: tos pop.w:g
220: next,
221: End-Code
222:
223: Code c@ ( addr -- n ) \ read cell
224: tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g
225: next,
226: End-Code
227:
228: Code c! ( n addr -- ) \ write cell
229: tos , w mov.w:g tos pop.w:g tos.b , [w] mov.b:g
230: tos pop.w:g
231: next,
232: End-Code
233:
234: \ arithmetic and logic
235: Code + ( n1 n2 -- n3 ) \ addition
236: r1 pop.w:g
237: r1 , tos add.w:g
238: next,
239: End-Code
240:
241: Code - ( n1 n2 -- n3 ) \ addition
242: r1 pop.w:g
243: tos , r1 sub.w:g
244: r1 , tos mov.w:g
245: next,
246: End-Code
247:
248: Code and ( n1 n2 -- n3 ) \ addition
249: r1 pop.w:g
250: r1 , tos and.w:g
251: next,
252: End-Code
253:
254: Code or ( n1 n2 -- n3 ) \ addition
255: r1 pop.w:g
256: r1 , tos or.w:g
257: next,
258: End-Code
259:
260: Code xor ( n1 n2 -- n3 ) \ addition
261: r1 pop.w:g
262: r1 , tos xor.w
263: next,
264: End-Code
265:
266: \ moving datas between stacks
267: Code r> ( -- n ; R: n -- )
268: tos push.w:g
269: rp , w mov.w:g
270: [w] , tos mov.w:g
271: # 2 , rp add.w:q \ ? hfs
272: next,
273: End-Code
274:
275: Code >r ( n -- ; R: -- n )
276: # -2 , rp add.w:q \ ? hfs
277: rp , w mov.w:g
278: tos , [w] mov.w:g
279: tos pop.w:g
280: next,
281: End-Code
282:
283: Code rdrop ( R:n -- )
284: # 2 , rp add.w:q \ ? hfs
285: next,
286: End-Code
287:
288: Code unloop ( R:n -- )
289: # 4 , rp add.w:q \ ? hfs
290: next,
291: End-Code
292:
293: \ datastack and returnstack address
294: Code sp@ ( -- sp ) \ get stack address
295: tos push.w:g
296: sp , tos stc
297: next,
298: End-Code
299:
300: Code sp! ( sp -- ) \ set stack address
301: tos , sp ldc
302: tos pop.w:g
303: next,
304: End-Code
305:
306: Code rp@ ( -- rp ) \ get returnstack address
307: tos push.w:g
308: rp , tos mov.w:g
309: next,
310: End-Code
311:
312: Code rp! ( rp -- ) \ set returnstack address
313: tos , rp mov.w:g
314: tos pop.w:g
315: next,
316: End-Code
317:
318: Code branch ( -- ) \ unconditional branch
319: [ip] , ip mov.w:g
320: next,
321: End-Code
322:
323: Code lit ( -- n ) \ inline literal
324: tos push.w:g
325: [ip] , tos mov.w:g
326: # 2 , ip add.w:q
327: next,
328: End-Code
329:
330: Code: :doesjump
331: end-code
332:
333: \ ==============================================================
334: \ usefull lowlevel words
335: \ ==============================================================
336: \ word definitions
337:
338:
339: \ branch and literal
340:
341: \ data stack words
342: Code dup ( n -- n n )
343: tos push.w:g
344: next,
345: End-Code
346:
347: Code 2dup ( d -- d d )
348: r1 pop.w:g
349: r1 push.w:g
350: tos push.w:g
351: r1 push.w:g
352: next,
353: End-Code
354:
355: Code drop ( n -- )
356: tos pop.w:g
357: next,
358: End-Code
359:
360: Code 2drop ( d -- )
361: tos pop.w:g
362: tos pop.w:g
363: next,
364: End-Code
365:
366: Code swap ( n1 n2 -- n2 n1 )
367: r1 pop.w:g
368: tos push.w:g
369: r1 , tos mov.w:g
370: next,
371: End-Code
372:
373: Code over ( n1 n2 -- n1 n2 n1 )
374: tos , r1 mov.w:g
375: tos pop.w:g
376: tos push.w:g
377: r1 push.w:g
378: next,
379: End-Code
380:
381: Code rot ( n1 n2 n3 -- n2 n3 n1 )
382: tos , r1 mov.w:g
383: r3 pop.w:g
384: tos pop.w:g
385: r3 push.w:g
386: r1 push.w:g
387: r3 , r3 xor.w
388: next,
389: End-Code
390:
391: Code -rot ( n1 n2 n3 -- n3 n1 n2 )
392: tos , r1 mov.w:g
393: tos pop.w:g
394: r3 pop.w:g
395: r1 push.w:g
396: r3 push.w:g
397: r3 , r3 xor.w
398: next,
399: End-Code
400:
401:
402: \ return stack
403: Code r@ ( -- n ; R: n -- n )
404: tos push.w:g
405: rp , w mov.w:g
406: [w] , tos mov.w:g
407: next,
408: End-Code
409:
410:
411: \ arithmetic
412:
413: Code um* ( u1 u2 -- ud ) \ unsigned multiply
414: rp , r3 mov.w:g
415: r2 pop.w:g
416: r2 , r0 mulu.w:g
417: r0 push.w:g
418: r2 , tos mov.w:g
419: r3 , rp mov.w:g
420: r3 , r3 xor.w
421: next,
422: End-Code
423:
424: Code um/mod ( ud u -- r q ) \ unsiged divide
425: rp , r3 mov.w:g
426: tos , r1 mov.w:g
427: r2 pop.w:g
428: tos pop.w:g
429: r1 divu.w
430: r2 push.w:g
431: r3 , rp mov.w:g
432: r3 , r3 xor.w
433: next,
434: End-Code
435:
436: \ shift
437: Code 2/ ( n1 -- n2 ) \ arithmetic shift right
438: \ hfs geht noch nicht !!! # -1 , tos sha.w
439: # -1 , r1h mov.b:q
440: r1h , tos sha.w
441: next,
442: End-Code
443:
444: 0 [IF]
445: Code lshift ( n1 n2 -- n3 ) \ shift n1 left n2 bits
446: \ tos.b , r1h mov.w:g
447: tos.b , r1h mov.b:g \ ? hfs
448: r1h , tos shl.w
449: next,
450: End-Code
451:
452: Code rshift ( n1 n2 -- n3 ) \ shift n1 right n2 bits
453: \ tos.b , r1h mov.w:g
454: tos.b , r1h mov.b:g \ ? hfs
455: r1h neg.b
456: r1h , tos shl.w
457: next,
458: End-Code
459: [THEN]
460:
461: \ compare
462: Code 0= ( n -- f ) \ Test auf 0
463: tos , tos tst.w
464: 0= IF # -1 , tos mov.w:g next,
465: THEN # 0 , tos mov.w:g next,
466: next,
467: End-Code
468:
469: Code 0< ( n -- f ) \ Test auf 0
470: tos , tos tst.w
471: 0< IF # -1 , tos mov.w:g next,
472: THEN # 0 , tos mov.w:g next,
473: next,
474: End-Code
475:
476: Code = ( n1 n2 -- f ) \ Test auf Gleichheit
477: r1 pop.w:g
478: r1 , tos sub.w:g
479: 0= IF # -1 , tos mov.w:g next,
480: THEN # 0 , tos mov.w:g next,
481: End-Code
482:
483: Code u< ( n1 n2 -- f ) \ Test auf Gleichheit
484: r1 pop.w:g
485: r1 , tos sub.w:g
486: u> IF # -1 , tos mov.w:g next,
487: THEN # 0 , tos mov.w:g next,
488: End-Code
489:
490: Code u> ( n1 n2 -- f ) \ Test auf Gleichheit
491: r1 pop.w:g
492: r1 , tos sub.w:g
493: u< IF # -1 , tos mov.w:g next,
494: THEN # 0 , tos mov.w:g next,
495: End-Code
496:
497: Code (key) ( -- char ) \ get character
498: # $08 , $E1 mov.b:g
499: tos push.w:g
500: \ BEGIN # $08 , $AD abs:16 tst.b 0<> UNTIL
501: BEGIN # $08 , $AD tst.b 0<> UNTIL
502: tos , tos xor.w
503: \ $AE abs:16 , tos.b mov.b:g
504: $AE , tos.b mov.b:g
505: next,
506: End-Code
507:
508: Code (emit) ( char -- ) \ output character
509: \ BEGIN # $08 , $AC tst.b 0= UNTIL
510: tos.b , $AA mov.b:g
511: tos pop.w:g
512: next,
513: End-Code
514:
515: \ additon io routines
516: Code (key?) ( -- f ) \ check for read sio character
517: tos push.w:g
518: \ # $08 , $AD abs:16 tst.b
519: # $08 , $AD tst.b
520: 0<> IF # -1 , tos mov.w:g next,
521: THEN # 0 , tos mov.w:g next,
522: End-Code
523:
524: Code emit? ( -- f ) \ check for write character to sio
525: tos push.w:g
526: \ # $02 , $AD abs:16 tst.b
527: # $08 , $AC tst.b
528: 0= IF # -1 , tos mov.w:g next,
529: THEN # 0 , tos mov.w:g next,
530: End-Code
531:
532: [then]
533: : (bye) ( 0 -- ) \ back to DOS
534: drop ;
535:
536: : bye ( -- ) 0 (bye) ;
537:
538: : compile-prim1 ;
539: : finish-code ;
540: : x@+/string ( addr u -- addr' u' c )
541: over c@ >r 1 /string r> ;
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