1: \ r8c/m16c primitives
2:
3: \ Copyright (C) 2006,2007 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 3
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, see http://www.gnu.org/licenses/.
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
34: ' R0L Alias tos.b
35:
36: \ hfs wichtig, damit der erste Befehl richtig compiliert wird
37: reset \ hfs
38:
39: \ system depending macros
40: : next1,
41: [w] , r1 mov.w:g r3r1 jmpi.a ;
42: : next,
43: [ip] , w mov.w:g
44: # 2 , ip add.w:q next1, ;
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
55: $0000 $FFFF region address-space
56: $C000 $4000 region rom-dictionary
57: $0400 $0400 region ram-dictionary
58: .regions
59: setup-target
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
67: # $0780 , sp ldc \ sp at $0600...$0700
68: # $0800 , rp mov.w:g \ rp at $0780...$0800
69: # $C084 , intbl ldc
70: # $0F , $E3 mov.b:g
71: # $0F , $E1 mov.b:g
72: Label mem-init
73: $01 , $0A bset:g
74: $00 , $05 bset:g \ open data RAM
75: $01 , $0A bclr:g
76: Label clock-init \ default is 125kHz/8
77: $00 , $0A bset:g
78: # $2808 , $06 mov.w:g
79: AHEAD THEN
80: 2 , $0C bclr:g
81: # $00 , $08 mov.b:g \ set to 20MHz
82: $00 , $0A bclr:g
83: Label uart-init
84: # $27 , $B0 mov.b:g \ hfs
85: \ # $8105 , $A8 mov.w:g \ ser1: 9600 baud, 8N1 \ hfs
86: \ # $2005 , $A8 mov.w:g \ ser1: 38k4 baud, 8N1 \ hfs
87: # $0500 , $AC mov.w:g \ hfs
88: I fset
89: next,
90: End-Label
91:
92:
93: \ ==============================================================
94: \ GFORTH minimal primitive set
95: \ ==============================================================
96: \ inner interpreter
97: align
98:
99: Code: :docol
100: \ ': dout, \ only for debugging
101: # -2 , rp add.w:q
102: w , r1 mov.w:g
103: rp , w mov.w:g ip , [w] mov.w:g
104: # 4 , r1 add.w:q r1 , ip mov.w:g
105: next,
106: End-Code
107:
108: align
109:
110: Code: :docon
111: \ '2 dout, \ only for debugging
112: tos push.w:g
113: 4 [w] , tos mov.w:g
114: next,
115: End-Code
116:
117: align
118:
119: Code: :dovalue
120: \ '2 dout, \ only for debugging
121: tos push.w:g
122: 4 [w] , w mov.w:g [w] , tos mov.w:g
123: next,
124: End-Code
125:
126: align
127:
128: Code: :dofield
129: 4 [w] , tos add.w:g
130: next,
131: end-code
132:
133: align
134:
135: Code: :dodefer
136: \ # $05 , $E1 mov.b:g
137: 4 [w] , w mov.w:g [w] , w mov.w:g
138: next1,
139: End-Code
140:
141: align
142:
143: Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part
144: \ '6 dout, \ only for debugging
145: \ # $06 , $E1 mov.b:g
146: tos push.w:g
147: w , tos mov.w:g # 4 , tos add.w:q
148: # -2 , rp add.w:q 2 [w] , r1 mov.w:g
149: rp , w mov.w:g ip , [w] mov.w:g
150: r1 , ip mov.w:g
151: next, \ execute does> part
152: End-Code
153:
154: $FF $C0FE here - tcallot
155:
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
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
173: tos , w mov.w:g \ copy tos to w
174: tos pop.w:g \ get new tos
175: next1,
176: End-Code
177:
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:
185: Code ?branch ( f -- ) \ jump on f=0
186: # 2 , ip add.w:q
187: tos , tos tst.w 0= IF -2 [ip] , ip mov.w:g THEN
188: tos pop.w:g
189: next,
190: End-Code
191:
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
237:
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:
249: \ memory access
250: Code @ ( addr -- n ) \ read cell
251: tos , w mov.w:g [w] , tos mov.w:g
252: next,
253: End-Code
254:
255: Code ! ( n addr -- ) \ write cell
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:
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
273: tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g
274: # 1 , w add.w:q w push.w:g
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:
291: Code 2* ( n1 n2 -- n3 ) \ addition
292: tos , tos add.w:g
293: next,
294: End-Code
295:
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:
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:
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
351: # 2 , rp add.w:q \ ? hfs
352: next,
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,
381: End-Code
382:
383: Code >r ( n -- ; R: -- n )
384: # -2 , rp add.w:q \ ? hfs
385: rp , w mov.w:g
386: tos , [w] mov.w:g
387: tos pop.w:g
388: next,
389: End-Code
390:
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:
401: \ datastack and returnstack address
402: Code sp@ ( -- sp ) \ get stack address
403: tos push.w:g
404: sp , tos stc
405: next,
406: End-Code
407:
408: Code sp! ( sp -- ) \ set stack address
409: tos , sp ldc
410: tos pop.w:g
411: next,
412: End-Code
413:
414: Code rp@ ( -- rp ) \ get returnstack address
415: tos push.w:g
416: rp , tos mov.w:g
417: next,
418: End-Code
419:
420: Code rp! ( rp -- ) \ set returnstack address
421: tos , rp mov.w:g
422: tos pop.w:g
423: next,
424: End-Code
425:
426: Code branch ( -- ) \ unconditional branch
427: [ip] , ip mov.w:g
428: next,
429: End-Code
430:
431: Code lit ( -- n ) \ inline literal
432: tos push.w:g
433: [ip] , tos mov.w:g
434: # 2 , ip add.w:q
435: next,
436: End-Code
437:
438: Code: :doesjump
439: end-code
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 )
451: tos push.w:g
452: next,
453: End-Code
454:
455: Code 2dup ( d -- d d )
456: r1 pop.w:g
457: r1 push.w:g
458: tos push.w:g
459: r1 push.w:g
460: next,
461: End-Code
462:
463: Code drop ( n -- )
464: tos pop.w:g
465: next,
466: End-Code
467:
468: Code 2drop ( d -- )
469: tos pop.w:g
470: tos pop.w:g
471: next,
472: End-Code
473:
474: Code swap ( n1 n2 -- n2 n1 )
475: r1 pop.w:g
476: tos push.w:g
477: r1 , tos mov.w:g
478: next,
479: End-Code
480:
481: Code over ( n1 n2 -- n1 n2 n1 )
482: tos , r1 mov.w:g
483: tos pop.w:g
484: tos push.w:g
485: r1 push.w:g
486: next,
487: End-Code
488:
489: Code rot ( n1 n2 n3 -- n2 n3 n1 )
490: tos , r1 mov.w:g
491: r3 pop.w:g
492: tos pop.w:g
493: r3 push.w:g
494: r1 push.w:g
495: r3 , r3 xor.w
496: next,
497: End-Code
498:
499: Code -rot ( n1 n2 n3 -- n3 n1 n2 )
500: tos , r1 mov.w:g
501: tos pop.w:g
502: r3 pop.w:g
503: r1 push.w:g
504: r3 push.w:g
505: r3 , r3 xor.w
506: next,
507: End-Code
508:
509:
510: \ return stack
511: Code r@ ( -- n ; R: n -- n )
512: tos push.w:g
513: rp , w mov.w:g
514: [w] , tos mov.w:g
515: next,
516: End-Code
517:
518:
519: \ arithmetic
520:
521: Code um* ( u1 u2 -- ud ) \ unsigned multiply
522: rp , r3 mov.w:g
523: r2 pop.w:g
524: r2 , r2r0 mulu.w:g
525: r0 push.w:g
526: r2 , tos mov.w:g
527: r3 , rp mov.w:g
528: r3 , r3 xor.w
529: next,
530: End-Code
531:
532: Code m* ( u1 u2 -- ud ) \ unsigned multiply
533: rp , r3 mov.w:g
534: r2 pop.w:g
535: r2 , r2r0 mul.w:g
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:
543: Code um/mod ( ud u -- r q ) \ unsiged divide
544: rp , r3 mov.w:g
545: tos , r1 mov.w:g
546: r2 pop.w:g
547: tos pop.w:g
548: r3r1 divu.w
549: r2 push.w:g
550: r3 , rp mov.w:g
551: r3 , r3 xor.w
552: next,
553: End-Code
554:
555: \ shift
556: Code 2/ ( n1 -- n2 ) \ arithmetic shift right
557: # -1 , tos sha.w
558: \ # -1 , r1h mov.b:q
559: \ r1h , tos sha.w
560: next,
561: End-Code
562:
563: Code lshift ( n1 n2 -- n3 ) \ shift n1 left n2 bits
564: \ tos.b , r1h mov.w:g
565: tos.b , r1h mov.b:g \ ? hfs
566: tos pop.w:g
567: r1h , tos shl.w
568: next,
569: End-Code
570:
571: Code rshift ( n1 n2 -- n3 ) \ shift n1 right n2 bits
572: \ tos.b , r1h mov.w:g
573: tos.b , r1h mov.b:g \ ? hfs
574: r1h neg.b
575: tos pop.w:g
576: r1h , tos shl.w
577: next,
578: End-Code
579:
580: \ compare
581: Code 0= ( n -- f ) \ Test auf 0
582: tos , tos tst.w
583: 0= IF # -1 , tos mov.w:q next,
584: THEN # 0 , tos mov.w:q next,
585: next,
586: End-Code
587:
588: Code 0< ( n -- f ) \ Test auf 0
589: tos , tos tst.w
590: 0< IF # -1 , tos mov.w:q next,
591: THEN # 0 , tos mov.w:q next,
592: next,
593: End-Code
594:
595: Code = ( n1 n2 -- f ) \ Test auf Gleichheit
596: r1 pop.w:g
597: r1 , tos sub.w:g
598: 0= IF # -1 , tos mov.w:q next,
599: THEN # 0 , tos mov.w:q next,
600: End-Code
601:
602: ' = alias u=
603:
604: Code u< ( n1 n2 -- f ) \ Test auf Gleichheit
605: r1 pop.w:g
606: r1 , tos sub.w:g
607: u> IF # -1 , tos mov.w:q next,
608: THEN # 0 , tos mov.w:q next,
609: End-Code
610:
611: Code u> ( n1 n2 -- f ) \ Test auf Gleichheit
612: r1 pop.w:g
613: r1 , tos sub.w:g
614: u< IF # -1 , tos mov.w:q next,
615: THEN # 0 , tos mov.w:q next,
616: End-Code
617:
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:
632: Code (key) ( -- char ) \ get character
633: tos push.w:g
634: BEGIN 3 , $AD btst:g 0<> UNTIL
635: $AE , tos mov.w:g r0h , r0h xor.b
636: next,
637: End-Code
638:
639: Code (emit) ( char -- ) \ output character
640: BEGIN 1 , $AD btst:g 0<> UNTIL
641: tos.b , $AA mov.b:g
642: tos pop.w:g
643: next,
644: End-Code
645:
646: \ additon io routines
647: Code (key?) ( -- f ) \ check for read sio character
648: tos push.w:g
649: 3 , $AD btst:g
650: 0<> IF # -1 , tos mov.w:q next,
651: THEN # 0 , tos mov.w:q next,
652: End-Code
653:
654: Code emit? ( -- f ) \ check for write character to sio
655: tos push.w:g
656: 1 , $AD btst:g
657: 0<> IF # -1 , tos mov.w:q next,
658: THEN # 0 , tos mov.w:q next,
659: End-Code
660:
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
668:
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:
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+ ;
702:
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:
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
726: tos pop.w:g
727: next,
728: end-code
729:
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!
738:
739: : timer-init ( -- )
740: &19999 $9E !
741: $0401 $9A !
742: 1 $50 c! ;
743:
744: : noop ;
745: defer pause ' noop is pause
746:
747: : ms ( n -- ) timer @ +
748: BEGIN pause dup timer @ - 0< UNTIL drop ;
749:
750: $400 constant ram-start
751: $2FFC Constant ram-shadow
752: 0 Constant ram-mirror
753: 0 Constant ram-size
754: $E0 Constant port0
755: $E1 Constant port1
756:
757: : led! port1 c! ;
758: : >lcd ( 4bit -- )
759: 1+ dup port0 c! dup 8 + port0 c! 1 us port0 c!
760: &40 us ;
761: : lcdctrl! ( n -- )
762: dup $F0 and >lcd
763: 4 lshift >lcd
764: &100 us ;
765: : lcdemit ( n -- ) &100 us
766: dup $F0 and 4 + >lcd
767: 4 lshift 4 + >lcd
768: &250 us ;
769: : lcdtype bounds ?DO I c@ lcdemit LOOP ;
770: : lcdpage $01 lcdctrl! &15 ms ;
771: : lcdcr $C0 lcdctrl! ;
772: : lcdinit ( -- )
773: $02 $0A bset $FD $E2 c!
774: &20 ms $30 >lcd 5 ms $33 lcdctrl! 5 ms $20 >lcd
775: &5 ms $28 lcdctrl!
776: &1 ms $0C lcdctrl!
777: &1 ms lcdpage ;
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 @ ;
781: : ?flash BEGIN $1B7 c@ 1 and 1 = UNTIL ;
782: : flashc! ( c addr -- ) $40 over c! c! ?flash ;
783: : flash! ( x addr -- ) 2dup flashc! >r 8 rshift r> 1+ flashc! ;
784: : flash-off ( addr -- ) $20 over c! $D0 swap c! ?flash ;
785: : flash-enable ( -- ) 1 $1b7 c! 3 $1b7 c! 0 $1b5 c! 2 $1b5 c! ;
786: : 9k6 $8105 $A8 ! ; \ baud setting
787: : 38k4 $2005 $A8 ! ; \ fast terminal
788: : r8cboot ( -- ) ['] noop IS pause
789: timer-init flash-enable lcdinit 38k4
790: s" Gforth EC R8C" lcdtype boot ;
791: ' r8cboot >body $C002 !
792: : savesystem ( -- )
793: dpp @ >r rom here normal-dp @ ram-start tuck - tuck
794: here over allot r> dpp ! -rot
795: bounds ?DO I c@ over flashc! 1+ LOOP drop
796: ram-shadow tuck flash! cell+ flash! ;
797: : refill-loop ( -- )
798: BEGIN 3 emit refill WHILE interpret REPEAT ;
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 ;
805: : include ( "file" -- ) parse-name included ;
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 ! ;
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