Annotation of gforth/arch/r8c/prim.fs, revision 1.39
1.1 pazsan 1: \ r8c/m16c primitives
2:
1.38 anton 3: \ Copyright (C) 2006,2007 Free Software Foundation, Inc.
1.1 pazsan 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
1.39 ! anton 9: \ as published by the Free Software Foundation, either version 3
1.1 pazsan 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
1.39 ! anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 pazsan 19:
20: \ * Register using for r8c
21: \ Renesas Forth used for
22: \ R0 TOS oberstes Stackelement
23: \ R3 RP Returnstack Pointer
24: \ SP SP Stack Pointer
25: \ A1 IP Instruction Pointer
26: \ A0 W Arbeitsregister
27: \
28: \ * Memory ( use only one 64K-Page ): TBD
29: \ **************************************************************
30:
31:
32: start-macros
33: \ register definition
1.2 pazsan 34: ' R0L Alias tos.b
1.1 pazsan 35:
1.7 pazsan 36: \ hfs wichtig, damit der erste Befehl richtig compiliert wird
37: reset \ hfs
38:
1.1 pazsan 39: \ system depending macros
1.8 pazsan 40: : next1,
1.18 pazsan 41: [w] , r1 mov.w:g r3r1 jmpi.a ;
1.1 pazsan 42: : next,
43: [ip] , w mov.w:g
1.8 pazsan 44: # 2 , ip add.w:q next1, ;
1.1 pazsan 45: \ note that this is really for 8086 and 286, and _not_ intented to run
46: \ fast on a Pentium (Pro). These old chips load their code from real RAM
47: \ and do it slow, anyway.
48: \ If you really want to have a fast 16 bit Forth on modern processors,
49: \ redefine it as
50: \ : next, [ip] w mov, 2 # ip add, [w] jmp, ;
51:
52: end-macros
53:
54: unlock
1.2 pazsan 55: $0000 $FFFF region address-space
56: $C000 $4000 region rom-dictionary
1.5 pazsan 57: $0400 $0400 region ram-dictionary
1.2 pazsan 58: .regions
59: setup-target
1.1 pazsan 60: lock
61:
62: \ ==============================================================
63: \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!)
64: \ ==============================================================
65: Label into-forth
66: # $ffff , ip mov.w:g \ ip will be patched
1.18 pazsan 67: # $0780 , sp ldc \ sp at $0600...$0700
1.31 pazsan 68: # $0800 , rp mov.w:g \ rp at $0780...$0800
1.32 pazsan 69: # $C084 , intbl ldc
1.9 pazsan 70: # $0F , $E3 mov.b:g
71: # $0F , $E1 mov.b:g
1.16 pazsan 72: Label mem-init
1.18 pazsan 73: $01 , $0A bset:g
74: $00 , $05 bset:g \ open data RAM
75: $01 , $0A bclr:g
1.9 pazsan 76: Label clock-init \ default is 125kHz/8
1.18 pazsan 77: $00 , $0A bset:g
1.33 pazsan 78: # $2808 , $06 mov.w:g
1.16 pazsan 79: AHEAD THEN
1.18 pazsan 80: 2 , $0C bclr:g
1.9 pazsan 81: # $00 , $08 mov.b:g \ set to 20MHz
1.18 pazsan 82: $00 , $0A bclr:g
1.5 pazsan 83: Label uart-init
1.13 pazsan 84: # $27 , $B0 mov.b:g \ hfs
1.32 pazsan 85: \ # $8105 , $A8 mov.w:g \ ser1: 9600 baud, 8N1 \ hfs
1.23 pazsan 86: \ # $2005 , $A8 mov.w:g \ ser1: 38k4 baud, 8N1 \ hfs
1.10 pazsan 87: # $0500 , $AC mov.w:g \ hfs
1.33 pazsan 88: I fset
1.14 pazsan 89: next,
1.1 pazsan 90: End-Label
91:
92:
93: \ ==============================================================
94: \ GFORTH minimal primitive set
95: \ ==============================================================
96: \ inner interpreter
1.19 pazsan 97: align
98:
1.1 pazsan 99: Code: :docol
100: \ ': dout, \ only for debugging
101: # -2 , rp add.w:q
1.7 pazsan 102: w , r1 mov.w:g
1.1 pazsan 103: rp , w mov.w:g ip , [w] mov.w:g
1.7 pazsan 104: # 4 , r1 add.w:q r1 , ip mov.w:g
1.1 pazsan 105: next,
106: End-Code
107:
1.19 pazsan 108: align
1.1 pazsan 109:
1.4 pazsan 110: Code: :docon
111: \ '2 dout, \ only for debugging
112: tos push.w:g
1.10 pazsan 113: 4 [w] , tos mov.w:g
1.4 pazsan 114: next,
115: End-Code
116:
1.19 pazsan 117: align
118:
1.8 pazsan 119: Code: :dovalue
120: \ '2 dout, \ only for debugging
121: tos push.w:g
1.10 pazsan 122: 4 [w] , w mov.w:g [w] , tos mov.w:g
1.8 pazsan 123: next,
1.4 pazsan 124: End-Code
125:
1.19 pazsan 126: align
127:
1.13 pazsan 128: Code: :dofield
129: 4 [w] , tos add.w:g
130: next,
131: end-code
132:
1.19 pazsan 133: align
134:
1.9 pazsan 135: Code: :dodefer
1.10 pazsan 136: \ # $05 , $E1 mov.b:g
137: 4 [w] , w mov.w:g [w] , w mov.w:g
1.9 pazsan 138: next1,
139: End-Code
1.8 pazsan 140:
1.19 pazsan 141: align
142:
1.1 pazsan 143: Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part
144: \ '6 dout, \ only for debugging
1.8 pazsan 145: \ # $06 , $E1 mov.b:g
146: tos push.w:g
147: w , tos mov.w:g # 4 , tos add.w:q
1.20 pazsan 148: # -2 , rp add.w:q 2 [w] , r1 mov.w:g
1.13 pazsan 149: rp , w mov.w:g ip , [w] mov.w:g
1.20 pazsan 150: r1 , ip mov.w:g
1.1 pazsan 151: next, \ execute does> part
1.5 pazsan 152: End-Code
1.19 pazsan 153:
1.32 pazsan 154: $FF $C0FE here - tcallot
1.5 pazsan 155:
1.19 pazsan 156: Code: :dovar
157: \ '2 dout, \ only for debugging
158: tos push.w:g
159: # 4 , w add.w:q
160: w , tos mov.w:g
161: next,
162: End-Code
163:
164: \ program flow
1.1 pazsan 165: Code ;s ( -- ) \ exit colon definition
166: \ '; dout, \ only for debugging
167: rp , w mov.w:g # 2 , rp add.w:q
168: [w] , ip mov.w:g
169: next,
170: End-Code
171:
172: Code execute ( xt -- ) \ execute colon definition
1.8 pazsan 173: tos , w mov.w:g \ copy tos to w
174: tos pop.w:g \ get new tos
175: next1,
1.1 pazsan 176: End-Code
177:
1.23 pazsan 178: Code perform ( xt -- ) \ execute colon definition
179: tos , w mov.w:g \ copy tos to w
180: tos pop.w:g \ get new tos
181: [w] , w mov.w:g
182: next1,
183: End-Code
184:
1.10 pazsan 185: Code ?branch ( f -- ) \ jump on f=0
1.7 pazsan 186: # 2 , ip add.w:q
1.10 pazsan 187: tos , tos tst.w 0= IF -2 [ip] , ip mov.w:g THEN
1.11 pazsan 188: tos pop.w:g
1.2 pazsan 189: next,
1.1 pazsan 190: End-Code
191:
1.10 pazsan 192: Code (for) ( n -- r:0 r:n )
193: # -4 , rp add.w:q rp , w mov.w:g
194: r3 , 2 [w] mov.w:g
195: tos , [w] mov.w:g
196: tos pop.w:g
197: next,
198: End-Code
199:
200: Code (?do) ( n -- r:0 r:n )
201: # 2 , ip add.w:q
202: # -4 , rp add.w:q rp , w mov.w:g
203: tos , [w] mov.w:g
204: r1 pop.w:g
205: r1 , 2 [w] mov.w:g
206: tos pop.w:g
207: [w] , r1 sub.w:g
208: 0= IF -2 [ip] , ip mov.w:g THEN
209: next,
210: End-Code
211:
212: Code (do) ( n -- r:0 r:n )
213: # -4 , rp add.w:q rp , w mov.w:g
214: tos , [w] mov.w:g
215: tos pop.w:g
216: tos , 2 [w] mov.w:g
217: tos pop.w:g
218: next,
219: End-Code
220:
221: Code (next) ( -- )
222: # 2 , ip add.w:q
223: rp , w mov.w:g [w] , r1 mov.w:g
224: # -1 , r1 add.w:q r1 , [w] mov.w:g
225: u>= IF -2 [ip] , ip mov.w:g THEN
226: next,
227: End-Code
228:
229: Code (loop) ( -- )
230: # 2 , ip add.w:q
231: rp , w mov.w:g [w] , r1 mov.w:g
232: # 1 , r1 add.w:q r1 , [w] mov.w:g
233: 2 [w] , r1 sub.w:g
234: 0<> IF -2 [ip] , ip mov.w:g THEN
235: next,
236: End-Code
1.1 pazsan 237:
1.23 pazsan 238: Code (+loop) ( n -- )
239: # 2 , ip add.w:q
240: rp , w mov.w:g [w] , r1 mov.w:g
241: 2 [w] , r1 sub.w:g # $8000 , r1 xor.w
242: tos , r1 add.w:g
243: no IF -2 [ip] , ip mov.w:g THEN
244: tos , [w] add.w:g
245: tos pop.w:g
246: next,
247: End-Code
248:
1.1 pazsan 249: \ memory access
250: Code @ ( addr -- n ) \ read cell
1.2 pazsan 251: tos , w mov.w:g [w] , tos mov.w:g
1.1 pazsan 252: next,
253: End-Code
254:
255: Code ! ( n addr -- ) \ write cell
1.2 pazsan 256: tos , w mov.w:g tos pop.w:g tos , [w] mov.w:g
257: tos pop.w:g
258: next,
259: End-Code
260:
1.23 pazsan 261: Code +! ( n addr -- ) \ write cell
262: tos , w mov.w:g tos pop.w:g tos , [w] add.w:g
263: tos pop.w:g
264: next,
265: End-Code
266:
267: Code c@ ( addr -- uc ) \ read cell
268: tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g
269: next,
270: End-Code
271:
272: Code count ( addr -- addr+1 uc ) \ read cell
1.2 pazsan 273: tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g
1.23 pazsan 274: # 1 , w add.w:q w push.w:g
1.2 pazsan 275: next,
276: End-Code
277:
278: Code c! ( n addr -- ) \ write cell
279: tos , w mov.w:g tos pop.w:g tos.b , [w] mov.b:g
280: tos pop.w:g
281: next,
282: End-Code
283:
284: \ arithmetic and logic
285: Code + ( n1 n2 -- n3 ) \ addition
286: r1 pop.w:g
287: r1 , tos add.w:g
288: next,
289: End-Code
290:
1.23 pazsan 291: Code 2* ( n1 n2 -- n3 ) \ addition
292: tos , tos add.w:g
293: next,
294: End-Code
295:
1.2 pazsan 296: Code - ( n1 n2 -- n3 ) \ addition
297: r1 pop.w:g
298: tos , r1 sub.w:g
299: r1 , tos mov.w:g
300: next,
301: End-Code
302:
1.23 pazsan 303: Code negate ( n1 -- n2 )
304: tos neg.w
305: next,
306: End-Code
307:
308: Code invert ( n1 -- n2 )
309: tos not.w:g
310: next,
311: End-Code
312:
313: Code 1+ ( n1 n2 -- n3 ) \ addition
314: # 1 , tos add.w:g
315: next,
316: End-Code
317:
318: Code 1- ( n1 n2 -- n3 ) \ addition
319: # -1 , tos add.w:g
320: next,
321: End-Code
322:
323: Code cell+ ( n1 n2 -- n3 ) \ addition
324: # 2 , tos add.w:g
325: next,
326: End-Code
327:
1.2 pazsan 328: Code and ( n1 n2 -- n3 ) \ addition
329: r1 pop.w:g
330: r1 , tos and.w:g
331: next,
332: End-Code
333:
334: Code or ( n1 n2 -- n3 ) \ addition
335: r1 pop.w:g
336: r1 , tos or.w:g
337: next,
338: End-Code
339:
340: Code xor ( n1 n2 -- n3 ) \ addition
341: r1 pop.w:g
342: r1 , tos xor.w
343: next,
344: End-Code
345:
346: \ moving datas between stacks
347: Code r> ( -- n ; R: n -- )
348: tos push.w:g
349: rp , w mov.w:g
350: [w] , tos mov.w:g
1.7 pazsan 351: # 2 , rp add.w:q \ ? hfs
1.1 pazsan 352: next,
1.23 pazsan 353: End-Code
354:
355: Code i ( -- n ; R: n -- )
356: tos push.w:g
357: rp , w mov.w:g
358: [w] , tos mov.w:g
359: next,
360: End-Code
361:
362: Code i' ( -- n ; R: n -- )
363: tos push.w:g
364: rp , w mov.w:g
365: 2 [w] , tos mov.w:g
366: next,
367: End-Code
368:
369: Code j ( -- n ; R: n -- )
370: tos push.w:g
371: rp , w mov.w:g
372: 4 [w] , tos mov.w:g
373: next,
374: End-Code
375:
376: Code k ( -- n ; R: n -- )
377: tos push.w:g
378: rp , w mov.w:g
379: 8 [w] , tos mov.w:g
380: next,
1.1 pazsan 381: End-Code
382:
1.2 pazsan 383: Code >r ( n -- ; R: -- n )
1.7 pazsan 384: # -2 , rp add.w:q \ ? hfs
1.2 pazsan 385: rp , w mov.w:g
386: tos , [w] mov.w:g
387: tos pop.w:g
388: next,
389: End-Code
390:
1.10 pazsan 391: Code rdrop ( R:n -- )
392: # 2 , rp add.w:q \ ? hfs
393: next,
394: End-Code
395:
396: Code unloop ( R:n -- )
397: # 4 , rp add.w:q \ ? hfs
398: next,
399: End-Code
400:
1.1 pazsan 401: \ datastack and returnstack address
402: Code sp@ ( -- sp ) \ get stack address
1.2 pazsan 403: tos push.w:g
404: sp , tos stc
405: next,
406: End-Code
1.1 pazsan 407:
408: Code sp! ( sp -- ) \ set stack address
1.2 pazsan 409: tos , sp ldc
410: tos pop.w:g
411: next,
1.1 pazsan 412: End-Code
413:
414: Code rp@ ( -- rp ) \ get returnstack address
1.2 pazsan 415: tos push.w:g
416: rp , tos mov.w:g
1.1 pazsan 417: next,
418: End-Code
419:
420: Code rp! ( rp -- ) \ set returnstack address
1.2 pazsan 421: tos , rp mov.w:g
422: tos pop.w:g
423: next,
424: End-Code
1.1 pazsan 425:
1.2 pazsan 426: Code branch ( -- ) \ unconditional branch
427: [ip] , ip mov.w:g
428: next,
1.1 pazsan 429: End-Code
430:
1.2 pazsan 431: Code lit ( -- n ) \ inline literal
432: tos push.w:g
433: [ip] , tos mov.w:g
1.3 pazsan 434: # 2 , ip add.w:q
1.2 pazsan 435: next,
1.1 pazsan 436: End-Code
437:
1.2 pazsan 438: Code: :doesjump
439: end-code
1.1 pazsan 440:
441: \ ==============================================================
442: \ usefull lowlevel words
443: \ ==============================================================
444: \ word definitions
445:
446:
447: \ branch and literal
448:
449: \ data stack words
450: Code dup ( n -- n n )
1.3 pazsan 451: tos push.w:g
1.1 pazsan 452: next,
453: End-Code
454:
455: Code 2dup ( d -- d d )
1.3 pazsan 456: r1 pop.w:g
457: r1 push.w:g
458: tos push.w:g
459: r1 push.w:g
1.1 pazsan 460: next,
461: End-Code
462:
463: Code drop ( n -- )
1.3 pazsan 464: tos pop.w:g
1.1 pazsan 465: next,
466: End-Code
467:
468: Code 2drop ( d -- )
1.3 pazsan 469: tos pop.w:g
470: tos pop.w:g
1.1 pazsan 471: next,
472: End-Code
473:
474: Code swap ( n1 n2 -- n2 n1 )
1.5 pazsan 475: r1 pop.w:g
476: tos push.w:g
477: r1 , tos mov.w:g
1.1 pazsan 478: next,
479: End-Code
480:
481: Code over ( n1 n2 -- n1 n2 n1 )
1.5 pazsan 482: tos , r1 mov.w:g
483: tos pop.w:g
484: tos push.w:g
485: r1 push.w:g
1.1 pazsan 486: next,
487: End-Code
488:
489: Code rot ( n1 n2 n3 -- n2 n3 n1 )
1.5 pazsan 490: tos , r1 mov.w:g
1.7 pazsan 491: r3 pop.w:g
1.5 pazsan 492: tos pop.w:g
1.7 pazsan 493: r3 push.w:g
1.5 pazsan 494: r1 push.w:g
1.7 pazsan 495: r3 , r3 xor.w
1.1 pazsan 496: next,
497: End-Code
498:
499: Code -rot ( n1 n2 n3 -- n3 n1 n2 )
1.5 pazsan 500: tos , r1 mov.w:g
501: tos pop.w:g
1.7 pazsan 502: r3 pop.w:g
1.5 pazsan 503: r1 push.w:g
1.7 pazsan 504: r3 push.w:g
505: r3 , r3 xor.w
1.1 pazsan 506: next,
507: End-Code
508:
509:
510: \ return stack
511: Code r@ ( -- n ; R: n -- n )
1.5 pazsan 512: tos push.w:g
513: rp , w mov.w:g
514: [w] , tos mov.w:g
1.1 pazsan 515: next,
516: End-Code
517:
518:
519: \ arithmetic
520:
521: Code um* ( u1 u2 -- ud ) \ unsigned multiply
1.7 pazsan 522: rp , r3 mov.w:g
1.5 pazsan 523: r2 pop.w:g
1.24 pazsan 524: r2 , r2r0 mulu.w:g
1.5 pazsan 525: r0 push.w:g
526: r2 , tos mov.w:g
1.7 pazsan 527: r3 , rp mov.w:g
528: r3 , r3 xor.w
1.5 pazsan 529: next,
1.1 pazsan 530: End-Code
531:
1.16 pazsan 532: Code m* ( u1 u2 -- ud ) \ unsigned multiply
533: rp , r3 mov.w:g
534: r2 pop.w:g
1.24 pazsan 535: r2 , r2r0 mul.w:g
1.16 pazsan 536: r0 push.w:g
537: r2 , tos mov.w:g
538: r3 , rp mov.w:g
539: r3 , r3 xor.w
540: next,
541: End-Code
542:
1.1 pazsan 543: Code um/mod ( ud u -- r q ) \ unsiged divide
1.7 pazsan 544: rp , r3 mov.w:g
1.5 pazsan 545: tos , r1 mov.w:g
546: r2 pop.w:g
547: tos pop.w:g
1.24 pazsan 548: r3r1 divu.w
1.5 pazsan 549: r2 push.w:g
1.7 pazsan 550: r3 , rp mov.w:g
551: r3 , r3 xor.w
1.5 pazsan 552: next,
1.1 pazsan 553: End-Code
554:
555: \ shift
556: Code 2/ ( n1 -- n2 ) \ arithmetic shift right
1.18 pazsan 557: # -1 , tos sha.w
558: \ # -1 , r1h mov.b:q
559: \ r1h , tos sha.w
1.1 pazsan 560: next,
561: End-Code
562:
563: Code lshift ( n1 n2 -- n3 ) \ shift n1 left n2 bits
1.7 pazsan 564: \ tos.b , r1h mov.w:g
1.14 pazsan 565: tos.b , r1h mov.b:g \ ? hfs
566: tos pop.w:g
567: r1h , tos shl.w
568: next,
1.1 pazsan 569: End-Code
570:
571: Code rshift ( n1 n2 -- n3 ) \ shift n1 right n2 bits
1.7 pazsan 572: \ tos.b , r1h mov.w:g
1.14 pazsan 573: tos.b , r1h mov.b:g \ ? hfs
574: r1h neg.b
575: tos pop.w:g
576: r1h , tos shl.w
1.1 pazsan 577: next,
578: End-Code
579:
580: \ compare
581: Code 0= ( n -- f ) \ Test auf 0
1.5 pazsan 582: tos , tos tst.w
1.18 pazsan 583: 0= IF # -1 , tos mov.w:q next,
584: THEN # 0 , tos mov.w:q next,
1.1 pazsan 585: next,
586: End-Code
587:
1.10 pazsan 588: Code 0< ( n -- f ) \ Test auf 0
589: tos , tos tst.w
1.18 pazsan 590: 0< IF # -1 , tos mov.w:q next,
591: THEN # 0 , tos mov.w:q next,
1.10 pazsan 592: next,
593: End-Code
594:
1.1 pazsan 595: Code = ( n1 n2 -- f ) \ Test auf Gleichheit
1.5 pazsan 596: r1 pop.w:g
597: r1 , tos sub.w:g
1.18 pazsan 598: 0= IF # -1 , tos mov.w:q next,
599: THEN # 0 , tos mov.w:q next,
1.1 pazsan 600: End-Code
601:
1.16 pazsan 602: ' = alias u=
603:
1.10 pazsan 604: Code u< ( n1 n2 -- f ) \ Test auf Gleichheit
605: r1 pop.w:g
606: r1 , tos sub.w:g
1.18 pazsan 607: u> IF # -1 , tos mov.w:q next,
608: THEN # 0 , tos mov.w:q next,
1.10 pazsan 609: End-Code
610:
611: Code u> ( n1 n2 -- f ) \ Test auf Gleichheit
612: r1 pop.w:g
613: r1 , tos sub.w:g
1.18 pazsan 614: u< IF # -1 , tos mov.w:q next,
615: THEN # 0 , tos mov.w:q next,
1.10 pazsan 616: End-Code
617:
1.23 pazsan 618: Code < ( n1 n2 -- f ) \ Test auf Gleichheit
619: r1 pop.w:g
620: r1 , tos sub.w:g
621: > IF # -1 , tos mov.w:q next,
622: THEN # 0 , tos mov.w:q next,
623: End-Code
624:
625: Code > ( n1 n2 -- f ) \ Test auf Gleichheit
626: r1 pop.w:g
627: r1 , tos sub.w:g
628: < IF # -1 , tos mov.w:q next,
629: THEN # 0 , tos mov.w:q next,
630: End-Code
631:
1.3 pazsan 632: Code (key) ( -- char ) \ get character
1.5 pazsan 633: tos push.w:g
1.18 pazsan 634: BEGIN 3 , $AD btst:g 0<> UNTIL
1.27 pazsan 635: $AE , tos mov.w:g r0h , r0h xor.b
1.3 pazsan 636: next,
637: End-Code
638:
639: Code (emit) ( char -- ) \ output character
1.18 pazsan 640: BEGIN 1 , $AD btst:g 0<> UNTIL
1.7 pazsan 641: tos.b , $AA mov.b:g
1.5 pazsan 642: tos pop.w:g
643: next,
1.3 pazsan 644: End-Code
645:
1.1 pazsan 646: \ additon io routines
647: Code (key?) ( -- f ) \ check for read sio character
1.5 pazsan 648: tos push.w:g
1.18 pazsan 649: 3 , $AD btst:g
650: 0<> IF # -1 , tos mov.w:q next,
651: THEN # 0 , tos mov.w:q next,
1.1 pazsan 652: End-Code
653:
654: Code emit? ( -- f ) \ check for write character to sio
1.5 pazsan 655: tos push.w:g
1.18 pazsan 656: 1 , $AD btst:g
657: 0<> IF # -1 , tos mov.w:q next,
658: THEN # 0 , tos mov.w:q next,
1.1 pazsan 659: End-Code
660:
1.23 pazsan 661: \ String operations
662:
663: Code fill ( addr u char -- )
664: R3 pop.w:g ip , r1 mov.w:g A1 pop.w:g
665: sstr.b tos pop.w:g
666: R3 , R3 xor.w r1 , ip mov.w:g next,
667: End-Code
1.14 pazsan 668:
1.23 pazsan 669: Code cmove ( from to count -- )
670: tos , R3 mov.w:g ip , r1 mov.w:g
671: a1 pop.w:g a0 pop.w:g r1 push.w:g r1 , r1 xor.w
672: smovf.b
673: R3 , R3 xor.w ip pop.w:g tos pop.w:g next,
674: End-Code
675:
676: Code cmove> ( from to count -- )
677: tos , R3 mov.w:g ip , r1 mov.w:g
678: a1 pop.w:g a0 pop.w:g r1 push.w:g r1 , r1 xor.w
679: r3 , a0 add.w:g # -1 , a0 add.w:q
680: r3 , a1 add.w:g # -1 , a1 add.w:q
681: smovb.b
682: R3 , R3 xor.w ip pop.w:g tos pop.w:g next,
683: End-Code
684:
1.24 pazsan 685: Code (find-samelen) ( u f83name1 -- u f83name2/0 )
686: tos , w mov.w:g r0 pop.w:g
687: BEGIN 2 [w] , r0h mov.b:g # $1F , r0h and.b:g
688: r0l , r0h cmp.b:g 0<> WHILE [w] , w mov.w:g
689: 0= UNTIL THEN
690: r0h , r0h xor.b r0 push.w:g w , tos mov.w:g
691: next,
692: End-Code
693:
694: : capscomp ( c_addr1 u c_addr2 -- n )
695: swap bounds
696: ?DO dup c@ I c@ <>
697: IF dup c@ toupper I c@ toupper =
698: ELSE true THEN WHILE 1+ LOOP drop 0
699: ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
700: : sgn ( n -- -1/0/1 )
701: dup 0= IF EXIT THEN 0< 2* 1+ ;
1.23 pazsan 702:
1.18 pazsan 703: Code btst ( b# addr -- f ) \ check for bit set in addr
704: tos , w mov.w:g # 3 , w shl.w
705: r1 pop.w:g r1 , w add.w:g [w] btst:g
706: 0<> IF # -1 , tos mov.w:q next,
707: THEN # 0 , tos mov.w:q next,
708: End-Code
709:
710: Code bset ( b# addr -- ) \ set bit in addr
711: tos , w mov.w:g # 3 , w shl.w
712: r1 pop.w:g r1 , w add.w:g [w] bset:g
713: tos pop.w:g next,
714: End-Code
715:
716: Code bclr ( b# addr -- ) \ clr bit in addr
717: tos , w mov.w:g # 3 , w shl.w
718: r1 pop.w:g r1 , w add.w:g [w] bclr:g
719: tos pop.w:g next,
720: End-Code
721:
1.16 pazsan 722: Code us ( n -- ) \ n microseconds delay
723: BEGIN AHEAD THEN AHEAD THEN
724: r1 , r1 mov.w:g
725: # -1 , tos add.w:q 0= UNTIL
1.14 pazsan 726: tos pop.w:g
727: next,
728: end-code
1.34 pazsan 729:
1.33 pazsan 730: Variable timer
731:
732: Code ms-irq ( -- )
733: # 1 , timer add.w:g
734: reit
735: end-code
736:
737: ' ms-irq >body $C084 $40 + ! 0 $C084 $42 + c!
1.14 pazsan 738:
1.33 pazsan 739: : timer-init ( -- )
740: &19999 $9E !
741: $0401 $9A !
742: 1 $50 c! ;
743:
1.34 pazsan 744: : noop ;
745: defer pause ' noop is pause
746:
1.33 pazsan 747: : ms ( n -- ) timer @ +
1.34 pazsan 748: BEGIN pause dup timer @ - 0< UNTIL drop ;
1.33 pazsan 749:
1.30 pazsan 750: $400 constant ram-start
751: $2FFC Constant ram-shadow
752: 0 Constant ram-mirror
753: 0 Constant ram-size
1.14 pazsan 754: $E0 Constant port0
755: $E1 Constant port1
756:
757: : led! port1 c! ;
1.16 pazsan 758: : >lcd ( 4bit -- )
759: 1+ dup port0 c! dup 8 + port0 c! 1 us port0 c!
760: &40 us ;
1.14 pazsan 761: : lcdctrl! ( n -- )
762: dup $F0 and >lcd
763: 4 lshift >lcd
1.16 pazsan 764: &100 us ;
765: : lcdemit ( n -- ) &100 us
1.14 pazsan 766: dup $F0 and 4 + >lcd
767: 4 lshift 4 + >lcd
1.16 pazsan 768: &250 us ;
1.14 pazsan 769: : lcdtype bounds ?DO I c@ lcdemit LOOP ;
1.16 pazsan 770: : lcdpage $01 lcdctrl! &15 ms ;
1.14 pazsan 771: : lcdcr $C0 lcdctrl! ;
772: : lcdinit ( -- )
1.32 pazsan 773: $02 $0A bset $FD $E2 c!
1.25 pazsan 774: &20 ms $30 >lcd 5 ms $33 lcdctrl! 5 ms $20 >lcd
1.16 pazsan 775: &5 ms $28 lcdctrl!
776: &1 ms $0C lcdctrl!
777: &1 ms lcdpage ;
1.25 pazsan 778: \ default channel is channel 6
779: : adc@ ( chan -- value ) $80 + $D6 c! $28 $D7 c!
780: 6 $D6 bset BEGIN 6 $D6 btst 0= UNTIL $C0 @ ;
1.18 pazsan 781: : ?flash BEGIN $1B7 c@ 1 and 1 = UNTIL ;
782: : flashc! ( c addr -- ) $40 over c! c! ?flash ;
1.20 pazsan 783: : flash! ( x addr -- ) 2dup flashc! >r 8 rshift r> 1+ flashc! ;
1.18 pazsan 784: : flash-off ( addr -- ) $20 over c! $D0 swap c! ?flash ;
1.36 pazsan 785: : flash-enable ( -- ) 1 $1b7 c! 3 $1b7 c! 0 $1b5 c! 2 $1b5 c! ;
1.23 pazsan 786: : 9k6 $8105 $A8 ! ; \ baud setting
787: : 38k4 $2005 $A8 ! ; \ fast terminal
1.34 pazsan 788: : r8cboot ( -- ) ['] noop IS pause
789: timer-init flash-enable lcdinit 38k4
1.23 pazsan 790: s" Gforth EC R8C" lcdtype boot ;
1.14 pazsan 791: ' r8cboot >body $C002 !
1.26 pazsan 792: : savesystem ( -- )
1.28 pazsan 793: dpp @ >r rom here normal-dp @ ram-start tuck - tuck
1.29 pazsan 794: here over allot r> dpp ! -rot
795: bounds ?DO I c@ over flashc! 1+ LOOP drop
1.22 pazsan 796: ram-shadow tuck flash! cell+ flash! ;
1.26 pazsan 797: : refill-loop ( -- )
798: BEGIN 3 emit refill WHILE interpret REPEAT ;
1.35 pazsan 799: : included ( addr u -- )
800: 2 emit dup $20 + emit type
801: echo @ IF
802: echo off ['] refill-loop catch
803: dup IF 4 emit THEN echo on throw
804: THEN ;
1.26 pazsan 805: : include ( "file" -- ) parse-name included ;
1.27 pazsan 806: : empty ( -- ) $2800 flash-off $2000 flash-off
807: forth-wordlist ram-mirror + ram-start - @ forth-wordlist !
808: normal-dp ram-mirror + ram-start - @ normal-dp ! $2000 flash-dp ! ;
1.18 pazsan 809:
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