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