1:
2:
3: 0 [IF]
4: Ideas/Todo
5:
6:
7: [THEN]
8:
9: UNLOCK
10: >ENVIRON
11: \ true SetValue PrimTrace
12:
13: LOCK
14:
15: UNLOCK
16: also assembler definitions
17:
18: X has? PrimTrace [IF]
19: : dout PC+6 X , accu X ,
20: *accu X , txd X ,
21: PC+4 X , jmp X ,
22: X , 0 X , ;
23: [ELSE]
24: : dout drop ;
25: [THEN]
26:
27: LOCK
28:
29: \ pie primitives
30:
31: $20 allot
32:
33: Label start ahere 2 + , jmp ,
34: Label "IntoForth" 4711 ,
35:
36: Label RP' 0 ,
37: Label SP' 0 ,
38: Label UP' 0 ,
39: Label IP' 0 ,
40:
41: Label #0 0 ,
42: Label #1 1 ,
43: Label #2 2 ,
44: Label #4 4 ,
45: Label #FF $FF ,
46: Label #$8000 $8000 ,
47: Label #-1 -1 ,
48: Label "Next" 1802 ,
49: Label "Next1" 1802 ,
50: Label ""Next"" "Next" ,
51: End-Label
52:
53: \ The virtual machine registers an data (stacks) go
54: \ to a seperate memory region (hopefully ram)
55:
56: \ UNLOCK
57: \ current-region vm-memory activate ( saved-region )
58: \ LOCK
59:
60: Label RP 0 ,
61: Label SP 0 ,
62: Label UP 0 ,
63: Label IP 0 ,
64: Label W 0 ,
65: Label t0 0 ,
66: Label t1 0 ,
67: Label t2 0 ,
68: Label t3 0 ,
69: Label srcx 0 ,
70: Label dstx 0 ,
71: "Next" , jmp ,
72: Label data-stack 50 cells allot
73: Label data-stack-top 2 cells allot
74: Label return-stack 50 cells allot
75: Label return-stack-top 2 cells allot
76:
77: End-Label
78:
79: \ UNLOCK
80: \ ( saved-region ) activate
81: \ LOCK
82:
83: \ Up to here it's self modified
84: Label IntoForth
85: \ Transfer VM registers initial values
86: RP' , RP ,
87: SP' , SP ,
88: IP' , IP ,
89: UP' , UP , \ useless since UP is initialized by gforth boot
90: ""Next"" , dstx 1 + ,
91: #0 , dstx 2 + ,
92:
93: Label Next #0 , add , \ clear carry
94: IP , shr ,
95: sym Next
96: *accu , W ,
97: #1 , add ,
98: accu , add ,
99: accu , IP ,
100: Label Next1 W , shr ,
101: *accu , shr ,
102: accu , jmp ,
103:
104: Label "xmov" srcx ,
105: End-Label
106:
107: IntoForth "IntoForth" 2* !
108: Next "Next" 2* !
109: Next1 "Next1" 2* !
110:
111: has? PrimTrace [IF]
112: Label "0" '< ,
113: Label "1" '1 ,
114: Label "2" '2 ,
115: Label "3" '3 ,
116: Label "4" '4 ,
117: Label "5" '5 ,
118: Label "6" '6 ,
119: Label "A" 'A ,
120: Label "B" 'B ,
121: Label "C" 'C ,
122: Label "D" 'D ,
123: Label "E" 'E ,
124: Label "F" '> ,
125: Label "?" '? ,
126: Label "+" '+ ,
127: Label "/" '/ ,
128: Label "H" 'H ,
129: Label "I" 'I ,
130: Label "J" 'J ,
131: Label "K" 'K ,
132: Label "L" 'L ,
133: Label "M" 'M ,
134: Label "N" 'N ,
135: Label "O" 'O ,
136: Label "P" 'P ,
137: Label "Q" 'Q ,
138: Label "R" 'R ,
139: Label "S" 'S ,
140: Label "T" 'T ,
141: Label "#" '# ,
142: End-Label
143: [THEN]
144:
145:
146: Code: :docol
147: ': dout
148: RP , accu ,
149: #1 , sub ,
150: accu , RP ,
151: IP , *accu ,
152: W , accu ,
153: #4 , add ,
154: accu , IP ,
155: "Next" , jmp ,
156: end-code
157:
158: Code: :docon
159: '1 dout
160: #0 , add ,
161: W , shr ,
162: #2 , add ,
163: *accu , t0 ,
164: SP , accu ,
165: #1 , sub ,
166: accu , SP ,
167: t0 , *accu ,
168: "Next" , jmp ,
169: end-code
170:
171: Code: :dovar
172: '2 dout
173: W , accu ,
174: #4 , add ,
175: accu , t0 ,
176: SP , accu ,
177: #1 , sub ,
178: accu , SP ,
179: t0 , *accu ,
180: "Next" , jmp ,
181: end-code
182:
183: Code: :douser
184: '3 dout
185: #0 , add ,
186: W , shr ,
187: #2 , add ,
188: *accu , accu ,
189: UP , add ,
190: accu , t0 ,
191: SP , accu ,
192: #1 , sub ,
193: accu , SP ,
194: t0 , *accu ,
195: "Next" , jmp ,
196: end-code
197:
198: Code: :dodefer
199: '4 dout
200: #0 , add ,
201: W , shr ,
202: #2 , add ,
203: *accu , W ,
204: "Next1" , jmp ,
205: end-code
206:
207: Code: :dofield
208: '5 dout
209: #0 , add ,
210: W , shr ,
211: #2 , add ,
212: *accu , accu ,
213: accu , t0 ,
214: SP , accu ,
215: *accu , accu ,
216: t0 , add ,
217: accu , t0 ,
218: SP , accu ,
219: t0 , *accu ,
220: "Next" , jmp ,
221: end-code
222:
223: Code: :dodoes
224: '6 dout
225: RP , accu ,
226: #1 , sub ,
227: accu , RP ,
228: IP , *accu ,
229: W , accu ,
230: #4 , add ,
231: accu , t0 ,
232: SP , accu ,
233: #1 , sub ,
234: accu , SP ,
235: t0 , *accu ,
236: t0 , accu ,
237: #2 , sub ,
238: #0 , add ,
239: accu , shr ,
240: *accu , IP ,
241: "Next" , jmp ,
242: end-code
243:
244: Code: :doesjump
245: end-code
246:
247: Code execute
248: 'E dout
249: SP , accu ,
250: *accu , W ,
251: #1 , add ,
252: accu , SP ,
253: "Next1" , jmp ,
254: end-code
255:
256: Code ;s
257: '; dout
258: RP , accu ,
259: #1 , add ,
260: accu , RP ,
261: #1 , sub ,
262: *accu , IP ,
263: "Next" , jmp ,
264: end-code
265:
266: Code !
267: '! dout
268: SP , accu ,
269: *accu , t0 ,
270: #1 , add ,
271: *accu , t1 ,
272: #1 , add ,
273: accu , SP ,
274: t0 , shr ,
275: t1 , *accu ,
276: "Next" , jmp ,
277: end-code
278:
279: Code @
280: '@ dout
281: #0 , add ,
282: SP , accu ,
283: *accu , shr ,
284: *accu , t0 ,
285: SP , accu ,
286: t0 , *accu ,
287: "Next" , jmp ,
288: end-code
289:
290: Code ?branch
291: '? dout
292: #0 , add ,
293: IP , shr ,
294: accu , t0 ,
295: #1 , add ,
296: accu , add ,
297: accu , IP ,
298: SP , accu ,
299: *accu , t1 ,
300: #1 , add ,
301: accu , SP ,
302: t1 , accu ,
303: pc+4 , jz ,
304: "Next" , jmp ,
305: '~ dout
306: t0 , accu ,
307: *accu , IP ,
308: "Next" , jmp ,
309: end-code
310:
311: Code branch
312: 'b dout
313: #0 , add ,
314: IP , shr ,
315: *accu , IP ,
316: "Next" , jmp ,
317: end-code
318:
319: Code (loop)
320: 'l dout
321: #0 , add ,
322: IP , shr ,
323: accu , t0 ,
324: #1 , add ,
325: accu , add ,
326: accu , IP ,
327:
328: RP , accu ,
329: *accu , t2 ,
330: #1 , add ,
331: *accu , t3 ,
332: t2 , accu ,
333: #1 , add ,
334: accu , t1 ,
335: RP , accu ,
336: t1 , *accu ,
337: t1 , accu ,
338: t3 , sub ,
339: "Next" , jz ,
340: t0 , accu ,
341: *accu , IP ,
342: "Next" , jmp ,
343: end-code
344:
345: Code xor
346: 'x dout
347: SP , accu ,
348: *accu , t0 ,
349: #1 , add ,
350: accu , SP ,
351: *accu , accu ,
352: t0 , xor ,
353: accu , t0 ,
354: SP , accu ,
355: t0 , *accu ,
356: "Next" , jmp ,
357: end-code
358:
359: Code or
360: 'o dout
361: SP , accu ,
362: *accu , t0 ,
363: #1 , add ,
364: accu , SP ,
365: *accu , accu ,
366: t0 , or ,
367: accu , t0 ,
368: SP , accu ,
369: t0 , *accu ,
370: "Next" , jmp ,
371: end-code
372:
373: Code and
374: 'a dout
375: SP , accu ,
376: *accu , t0 ,
377: #1 , add ,
378: accu , SP ,
379: *accu , accu ,
380: t0 , and ,
381: accu , t0 ,
382: SP , accu ,
383: t0 , *accu ,
384: "Next" , jmp ,
385: end-code
386:
387: Code +
388: '+ dout
389: SP , accu ,
390: *accu , t0 ,
391: #1 , add ,
392: accu , SP ,
393: *accu , accu ,
394: t0 , add ,
395: accu , t0 ,
396: SP , accu ,
397: t0 , *accu ,
398: "Next" , jmp ,
399: end-code
400:
401: Code -
402: '- dout
403: SP , accu ,
404: *accu , t0 ,
405: #1 , add ,
406: accu , SP ,
407: *accu , accu ,
408: t0 , sub ,
409: accu , t0 ,
410: SP , accu ,
411: t0 , *accu ,
412: "Next" , jmp ,
413: end-code
414:
415: Code 2/
416: '/ dout
417: #0 , add ,
418: SP , accu ,
419: *accu , accu ,
420: PC+6 , js ,
421: accu , shr ,
422: PC+6 , jmp ,
423: accu , shr ,
424: #$8000 , or ,
425: accu , t0 ,
426: SP , accu ,
427: t0 , *accu ,
428: "Next" , jmp ,
429: end-code
430:
431: Code 0=
432: '° dout
433: SP , accu ,
434: *accu , accu ,
435: ZF , accu ,
436: #1 , xor ,
437: #1 , sub ,
438: accu , t0 ,
439: SP , accu ,
440: t0 , *accu ,
441: "Next" , jmp ,
442: end-code
443:
444: Code 0<>
445: '% dout
446: SP , accu ,
447: *accu , accu ,
448: ZF , accu ,
449: #1 , sub ,
450: accu , t0 ,
451: SP , accu ,
452: t0 , *accu ,
453: "Next" , jmp ,
454: end-code
455:
456: Code =
457: '= dout
458: SP , accu ,
459: *accu , t0 ,
460: #1 , add ,
461: accu , SP ,
462: *accu , accu ,
463: t0 , sub ,
464: ZF , accu ,
465: #1 , xor ,
466: #1 , sub ,
467: accu , t0 ,
468: SP , accu ,
469: t0 , *accu ,
470: "Next" , jmp ,
471: end-code
472:
473: Code u<
474: '< dout
475: SP , accu ,
476: *accu , t0 ,
477: #1 , add ,
478: accu , SP ,
479: *accu , accu ,
480: t0 , sub ,
481: CF , accu ,
482: #1 , xor ,
483: #1 , sub ,
484: accu , t0 ,
485: SP , accu ,
486: t0 , *accu ,
487: "Next" , jmp ,
488: end-code
489:
490: Code 1+
491: 'p dout
492: SP , accu ,
493: *accu , accu ,
494: #1 , add ,
495: accu , t0 ,
496: SP , accu ,
497: t0 , *accu ,
498: "Next" , jmp ,
499: end-code
500:
501: Code cell+
502: 'P dout
503: SP , accu ,
504: *accu , accu ,
505: #2 , add ,
506: accu , t0 ,
507: SP , accu ,
508: t0 , *accu ,
509: "Next" , jmp ,
510: end-code
511:
512: Code 8<<
513: '{ dout
514: #0 , add ,
515: SP , accu ,
516: *accu , accu ,
517: accu , add ,
518: accu , add ,
519: accu , add ,
520: accu , add ,
521: accu , add ,
522: accu , add ,
523: accu , add ,
524: accu , add ,
525: accu , t0 ,
526: SP , accu ,
527: t0 , *accu ,
528: "Next" , jmp ,
529: end-code
530:
531: Code 8>>
532: '{ dout
533: #0 , add ,
534: SP , accu ,
535: Label c-even@ *accu , shr ,
536: accu , shr ,
537: accu , shr ,
538: accu , shr ,
539: accu , shr ,
540: accu , shr ,
541: accu , shr ,
542: accu , shr ,
543: #FF , and ,
544: accu , t0 ,
545: SP , accu ,
546: t0 , *accu ,
547: "Next" , jmp ,
548: Label "c-even@" c-even@ ,
549: end-code
550:
551: Code c@
552: 'c dout
553: #0 , add ,
554: SP , accu ,
555: *accu , shr ,
556: PC+4 , jc ,
557: "c-even@" , jmp ,
558: *accu , accu ,
559: #FF , and ,
560: accu , t0 ,
561: SP , accu ,
562: t0 , *accu ,
563: "Next" , jmp ,
564: end-code
565:
566: Code 2*
567: '* dout
568: SP , accu ,
569: *accu , accu ,
570: accu , add ,
571: accu , t0 ,
572: SP , accu ,
573: t0 , *accu ,
574: "Next" , jmp ,
575: end-code
576:
577: Code >r
578: 'R dout
579: SP , accu ,
580: *accu , t0 ,
581: #1 , add ,
582: accu , SP ,
583: RP , accu ,
584: #1 , sub ,
585: accu , RP ,
586: t0 , *accu ,
587: "Next" , jmp ,
588: end-code
589:
590: Code r>
591: 'r dout
592: RP , accu ,
593: *accu , t0 ,
594: #1 , add ,
595: accu , RP ,
596: SP , accu ,
597: #1 , sub ,
598: accu , SP ,
599: t0 , *accu ,
600: "Next" , jmp ,
601: end-code
602:
603: Code sp@
604: 's dout
605: SP , accu ,
606: accu , add ,
607: accu , t0 ,
608: SP , accu ,
609: #1 , sub ,
610: accu , SP ,
611: t0 , *accu ,
612: "Next" , jmp ,
613: end-code
614:
615: Code sp!
616: 'S dout
617: #0 , add ,
618: SP , accu ,
619: *accu , shr ,
620: accu , SP ,
621: "Next" , jmp ,
622: end-code
623:
624: Code rp@
625: RP , accu ,
626: accu , add ,
627: accu , t0 ,
628: SP , accu ,
629: #1 , sub ,
630: accu , SP ,
631: t0 , *accu ,
632: "Next" , jmp ,
633: end-code
634:
635: Code rp! sym rp!
636: SP , accu ,
637: *accu , t0 ,
638: #1 , add ,
639: accu , SP ,
640: #0 , add ,
641: t0 , shr ,
642: accu , RP ,
643: "Next" , jmp ,
644: end-code
645:
646: Code drop
647: 'd dout
648: SP , accu ,
649: #1 , add ,
650: accu , SP ,
651: "Next" , jmp ,
652: end-code
653:
654: Code lit
655: '# dout
656: IP , shr ,
657: *accu , t0 ,
658: #1 , add ,
659: accu , add ,
660: accu , IP ,
661: SP , accu ,
662: #1 , sub ,
663: accu , SP ,
664: t0 , *accu ,
665: "Next" , jmp ,
666: end-code
667:
668: Code dup
669: 'u dout
670: SP , accu ,
671: *accu , t0 ,
672: #1 , sub ,
673: accu , SP ,
674: t0 , *accu ,
675: "Next" , jmp ,
676: end-code
677:
678: Code r@
679: 'I dout
680: RP , accu ,
681: *accu , t0 ,
682: SP , accu ,
683: #1 , sub ,
684: accu , SP ,
685: t0 , *accu ,
686: "Next" , jmp ,
687: end-code
688:
689: Code over
690: 'v dout
691: SP , accu ,
692: #1 , add ,
693: *accu , t0 ,
694: #2 , sub ,
695: accu , SP ,
696: t0 , *accu ,
697: "Next" , jmp ,
698: end-code
699:
700: Code swap
701: 'w dout
702: SP , accu ,
703: *accu , t0 ,
704: #1 , add ,
705: *accu , t1 ,
706: t0 , *accu ,
707: #1 , sub ,
708: t1 , *accu ,
709: "Next" , jmp ,
710: end-code
711:
712: Code d+
713: SP , accu ,
714: *accu , t0 ,
715: #1 , add ,
716: *accu , t1 ,
717: #1 , add ,
718: *accu , t2 ,
719: accu , SP ,
720: #1 , add ,
721: *accu , accu ,
722: t1 , add ,
723: accu , t1 ,
724: CF , accu ,
725: t2 , add ,
726: t0 , add ,
727: accu , t0 ,
728: SP , accu ,
729: t0 , *accu ,
730: #1 , add ,
731: t1 , *accu ,
732: "Next" , jmp ,
733: end-code
734:
735: Label cf1 0 ,
736: End-Label
737: Code d2*+ sym d2*+
738: SP , accu ,
739: Label >d2*+ *accu , t0 ,
740: #1 , add ,
741: *accu , t1 ,
742: #1 , add ,
743: *accu , t2 ,
744: accu , t3 ,
745: t0 , accu ,
746: t2 , add ,
747: t2 , add ,
748: accu , t2 ,
749: CF , accu ,
750: t1 , add ,
751: t1 , add ,
752: accu , t0 ,
753: t1 , accu ,
754: #$8000 , and ,
755: accu , t1 ,
756: t3 , accu ,
757: t2 , *accu ,
758: #1 , sub ,
759: t0 , *accu ,
760: #1 , sub ,
761: t1 , *accu ,
762: "Next" , jmp ,
763: end-code
764:
765: Label "d2*+" >d2*+ ,
766: End-Label
767: Code /modstep ( ud c R: u -- ud-?u 0/1 )
768: sym /modstep
769: SP , accu ,
770: *accu , t0 ,
771: #1 , add ,
772: *accu , t1 ,
773: #1 , add ,
774: *accu , t2 ,
775: t2 , accu ,
776: t0 , sub ,
777: accu , t0 ,
778: CF , accu ,
779: t1 , or ,
780: PC+6 , JZ ,
781: #0 , accu ,
782: PC+6 , jmp ,
783: t0 , t2 ,
784: #1 , accu ,
785: accu , t0 ,
786: SP , accu ,
787: #1 , add ,
788: t0 , *accu ,
789: #1 , add ,
790: t2 , *accu ,
791: #1 , sub ,
792: "d2*+" , jmp ,
793: end-code
794:
795: Code (key)
796: SP , accu ,
797: #1 , sub ,
798: accu , SP ,
799: rxd , *accu ,
800: "Next" , jmp ,
801: end-code
802:
803: Code (key?)
804: rx? , accu ,
805: ZF , accu ,
806: #1 , sub ,
807: accu , t0 ,
808: SP , accu ,
809: #1 , sub ,
810: accu , SP ,
811: t0 , *accu ,
812: "Next" , jmp ,
813: end-code
814:
815: Code (emit)
816: SP , accu ,
817: *accu , txd ,
818: #1 , add ,
819: accu , SP ,
820: "Next" , jmp ,
821: end-code
822:
823: UP 2* Constant UP
824:
825: : up@ up @ ;
826: : up! up ! ;
827:
828: \ include ./key.fs
829: include ./optcmove.fs
830:
831: : (bye) 0 execute ;
832: : float+ 8 + ;
833: : finish-code ;
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 / misc