![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to forth.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / kernel|
Return to forth.c CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / kernel |
1.1 root 1: /* tag: C implementation of all forth primitives,
2: * internal words, inner interpreter and such
3: *
4: * Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
5: *
6: * See the file "COPYING" for further information about
7: * the copyright and warranty status of this work.
8: */
9:
10: #include "config.h"
11: #include "sysinclude.h"
12: #include "kernel/stack.h"
13: #include "kernel/kernel.h"
14: #include "dict.h"
15:
16: /*
17: * cross platform abstraction
18: */
19:
20: #include "cross.h"
21:
22: #ifndef FCOMPILER
23: #include "libc/vsprintf.h"
24: #else
25: #include <stdarg.h>
26: #endif
27:
28: /*
29: * execution works as follows:
30: * - PC is pushed on return stack
31: * - PC is set to new CFA
32: * - address pointed by CFA is executed by CPU
33: */
34:
35: typedef void forth_word(void);
36:
37: static forth_word * const words[];
38: ucell PC;
39: volatile int interruptforth = 0;
40:
41: #define DEBUG_MODE_NONE 0
42: #define DEBUG_MODE_STEP 1
43: #define DEBUG_MODE_TRACE 2
44: #define DEBUG_MODE_STEPUP 3
45:
46: #define DEBUG_BANNER "\nStepper keys: <space>/<enter> Up Down Trace Rstack Forth\n"
47:
48: /* Empty linked list of debug xts */
49: struct debug_xt {
50: ucell xt_docol;
51: ucell xt_semis;
52: int mode;
53: struct debug_xt *next;
54: };
55:
56: static struct debug_xt debug_xt_eol = { (ucell)0, (ucell)0, 0, NULL};
57: static struct debug_xt *debug_xt_list = &debug_xt_eol;
58:
59: /* Static buffer for xt name */
60: char xtname[MAXNFALEN];
61:
62: #ifndef FCOMPILER
63: /* instead of pointing to an explicit 0 variable we
64: * point behind the pointer.
65: */
66: static ucell t[] = { 0, 0, 0, 0 };
67: static ucell *trampoline = t;
68:
69: /*
70: * Code Field Address (CFA) definitions (DOCOL and the like)
71: */
72:
73: void forth_init(void)
74: {
75: init_trampoline(trampoline);
76: }
77: #endif
78:
79: #ifndef CONFIG_DEBUG_INTERPRETER
80: #define dbg_interp_printk( a... ) do { } while(0)
81: #else
82: #define dbg_interp_printk( a... ) printk( a )
83: #endif
84:
85: #ifndef CONFIG_DEBUG_INTERNAL
86: #define dbg_internal_printk( a... ) do { } while(0)
87: #else
88: #define dbg_internal_printk( a... ) printk( a )
89: #endif
90:
91:
92: void init_trampoline(ucell *tramp)
93: {
94: tramp[0] = DOCOL;
95: tramp[1] = 0;
96: tramp[2] = target_ucell(pointer2cell(tramp) + 3 * sizeof(ucell));
97: tramp[3] = 0;
98: }
99:
100: static inline void processxt(ucell xt)
101: {
102: void (*tokenp) (void);
103:
104: dbg_interp_printk("processxt: pc=%x, xt=%x\n", PC, xt);
105: tokenp = words[xt];
106: tokenp();
107: }
108:
109: static void docol(void)
110: { /* DOCOL */
111: PUSHR(PC);
112: PC = read_ucell(cell2pointer(PC));
113:
114: dbg_interp_printk("docol: %s\n", cell2pointer( lfa2nfa(PC - sizeof(cell)) ));
115: }
116:
117: static void semis(void)
118: {
119: PC = POPR();
120: }
121:
122: static inline void next(void)
123: {
124: PC += sizeof(ucell);
125:
126: dbg_interp_printk("next: PC is now %x\n", PC);
127: processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
128: }
129:
130: static inline void next_dbg(void);
131:
132: int enterforth(xt_t xt)
133: {
134: ucell *_cfa = (ucell*)cell2pointer(xt);
135: cell tmp;
136:
137: if (read_ucell(_cfa) != DOCOL) {
138: trampoline[1] = target_ucell(xt);
139: _cfa = trampoline;
140: }
141:
142: if (rstackcnt < 0) {
143: rstackcnt = 0;
144: }
145:
146: tmp = rstackcnt;
147: interruptforth = FORTH_INTSTAT_CLR;
148:
149: PUSHR(PC);
150: PC = pointer2cell(_cfa);
151:
152: while (rstackcnt > tmp && !(interruptforth & FORTH_INTSTAT_STOP)) {
153: if (debug_xt_list->next == NULL) {
154: while (rstackcnt > tmp && !interruptforth) {
155: dbg_interp_printk("enterforth: NEXT\n");
156: next();
157: }
158: } else {
159: while (rstackcnt > tmp && !interruptforth) {
160: dbg_interp_printk("enterforth: NEXT_DBG\n");
161: next_dbg();
162: }
163: }
164:
165: /* Always clear the debug mode change flag */
166: interruptforth = interruptforth & (~FORTH_INTSTAT_DBG);
167: }
168:
169: #if 0
170: /* return true if we took an exception. The caller should normally
171: * handle exceptions by returning immediately since the throw
172: * is supposed to abort the execution of this C-code too.
173: */
174:
175: if (rstackcnt != tmp) {
176: printk("EXCEPTION DETECTED!\n");
177: }
178: #endif
179: return rstackcnt != tmp;
180: }
181:
182: /* called inline thus a slightly different behaviour */
183: static void lit(void)
184: { /* LIT */
185: PC += sizeof(cell);
186: PUSH(read_ucell(cell2pointer(PC)));
187: dbg_interp_printk("lit: %x\n", read_ucell(cell2pointer(PC)));
188: }
189:
190: static void docon(void)
191: { /* DOCON */
192: ucell tmp = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
193: PUSH(tmp);
194: dbg_interp_printk("docon: PC=%x, value=%x\n", PC, tmp);
195: }
196:
197: static void dovar(void)
198: { /* DOVAR */
199: ucell tmp = read_ucell(cell2pointer(PC)) + sizeof(ucell);
200: PUSH(tmp); /* returns address to variable */
201: dbg_interp_printk("dovar: PC: %x, %x\n", PC, tmp);
202: }
203:
204: static void dobranch(void)
205: { /* unconditional branch */
206: PC += sizeof(cell);
207: PC += read_cell(cell2pointer(PC));
208: }
209:
210: static void docbranch(void)
211: { /* conditional branch */
212: PC += sizeof(cell);
213: if (POP()) {
214: dbg_internal_printk(" ?branch: end loop\n");
215: } else {
216: dbg_internal_printk(" ?branch: follow branch\n");
217: PC += read_cell(cell2pointer(PC));
218: }
219: }
220:
221:
222: static void execute(void)
223: { /* EXECUTE */
224: ucell address = POP();
225: dbg_interp_printk("execute: %x\n", address);
226:
227: PUSHR(PC);
228: trampoline[1] = target_ucell(address);
229: PC = pointer2cell(trampoline);
230: }
231:
232: /*
233: * call ( ... function-ptr -- ??? )
234: */
235: static void call(void)
236: {
237: #ifdef FCOMPILER
238: printk("Sorry. Usage of Forth2C binding is forbidden during bootstrap.\n");
239: exit(1);
240: #else
241: void (*funcptr) (void);
242: funcptr=(void *)cell2pointer(POP());
243: dbg_interp_printk("call: %x", funcptr);
244: funcptr();
245: #endif
246: }
247:
248: /*
249: * sys-debug ( errno -- )
250: */
251:
252: static void sysdebug(void)
253: {
254: #ifdef FCOMPILER
255: cell errorno=POP();
256: exception(errorno);
257: #else
258: (void) POP();
259: #endif
260: }
261:
262: static void dodoes(void)
263: { /* DODOES */
264: ucell data = read_ucell(cell2pointer(PC)) + (2 * sizeof(ucell));
265: ucell word = read_ucell(cell2pointer(read_ucell(cell2pointer(PC)) + sizeof(ucell)));
266:
267: dbg_interp_printk("DODOES data=%x word=%x\n", data, word);
268:
269: PUSH(data);
270: PUSH(word);
271:
272: execute();
273: }
274:
275: static void dodefer(void)
276: {
277: docol();
278: }
279:
280: static void dodo(void)
281: {
282: cell startval, endval;
283: startval = POP();
284: endval = POP();
285:
286: PUSHR(endval);
287: PUSHR(startval);
288: }
289:
290: static void doisdo(void)
291: {
292: cell startval, endval, offset;
293:
294: startval = POP();
295: endval = POP();
296:
297: PC += sizeof(cell);
298:
299: if (startval == endval) {
300: offset = read_cell(cell2pointer(PC));
301: PC += offset;
302: } else {
303: PUSHR(endval);
304: PUSHR(startval);
305: }
306: }
307:
308: static void doloop(void)
309: {
310: cell offset, startval, endval;
311:
312: startval = POPR() + 1;
313: endval = POPR();
314:
315: PC += sizeof(cell);
316:
317: if (startval < endval) {
318: offset = read_cell(cell2pointer(PC));
319: PC += offset;
320: PUSHR(endval);
321: PUSHR(startval);
322: }
323:
324: }
325:
326: static void doplusloop(void)
327: {
328: ucell high, low;
329: cell increment, startval, endval, offset;
330:
331: increment = POP();
332:
333: startval = POPR();
334: endval = POPR();
335:
336: low = (ucell) startval;
337: startval += increment;
338:
339: PC += sizeof(cell);
340:
341: if (increment >= 0) {
342: high = (ucell) startval;
343: } else {
344: high = low;
345: low = (ucell) startval;
346: }
347:
348: if (endval - (low + 1) >= high - low) {
349: offset = read_cell(cell2pointer(PC));
350: PC += offset;
351:
352: PUSHR(endval);
353: PUSHR(startval);
354: }
355: }
356:
357: /*
358: * instance handling CFAs
359: */
360: #ifndef FCOMPILER
361: static ucell get_myself(void)
362: {
363: static ucell *myselfptr = NULL;
364: if (myselfptr == NULL) {
365: myselfptr = (ucell*)cell2pointer(findword("my-self")) + 1;
366: }
367: ucell *myself = (ucell*)cell2pointer(*myselfptr);
368: return (myself != NULL) ? *myself : 0;
369: }
370:
371: static void doivar(void)
372: {
373: ucell r, *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
374: ucell ibase = get_myself();
375:
376: dbg_interp_printk("ivar, offset: %d size: %d (ibase %d)\n", p[0], p[1], ibase );
377:
378: r = ibase ? ibase + p[0] : pointer2cell(&p[2]);
379: PUSH( r );
380: }
381:
382: static void doival(void)
383: {
384: ucell r, *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
385: ucell ibase = get_myself();
386:
387: dbg_interp_printk("ivar, offset: %d size: %d\n", p[0], p[1] );
388:
389: r = ibase ? ibase + p[0] : pointer2cell(&p[2]);
390: PUSH( *(ucell *)cell2pointer(r) );
391: }
392:
393: static void doidefer(void)
394: {
395: ucell *p = (ucell *)(*(ucell *) cell2pointer(PC) + sizeof(ucell));
396: ucell ibase = get_myself();
397:
398: dbg_interp_printk("doidefer, offset: %d size: %d\n", p[0], p[1] );
399:
400: PUSHR(PC);
401: PC = ibase ? ibase + p[0] : pointer2cell(&p[2]);
402: PC -= sizeof(ucell);
403: }
404: #else
405: static void noinstances(void)
406: {
407: printk("Opening devices is not supported during bootstrap. Sorry.\n");
408: exit(1);
409: }
410: #define doivar noinstances
411: #define doival noinstances
412: #define doidefer noinstances
413: #endif
414:
415: /*
416: * $include / $encode-file
417: */
418: #ifdef FCOMPILER
419: static void
420: string_relay(void (*func)(const char *))
421: {
422: int len = POP();
423: char *name, *p = (char*)cell2pointer(POP());
424: name = malloc(len + 1);
425: memcpy(name, p, len);
426: name[len] = 0;
427: (*func)(name);
428: free(name);
429: }
430: #else
431: #define string_relay(dummy) do { DROP(); DROP(); } while(0)
432: #endif
433:
434: static void
435: do_include(void)
436: {
437: string_relay(&include_file);
438: }
439:
440: static void
441: do_encode_file( void )
442: {
443: string_relay(&encode_file);
444: }
445:
446: /*
447: * Debug support functions
448: */
449:
450: static
451: int printf_console(const char *fmt, ...)
452: {
453: cell tmp;
454:
455: char buf[512];
456: va_list args;
457: int i;
458:
459: va_start(args, fmt);
460: i = vsnprintf(buf, sizeof(buf), fmt, args);
461: va_end(args);
462:
463: /* Push to the Forth interpreter for console output */
464: tmp = rstackcnt;
465:
466: PUSH(pointer2cell(buf));
467: PUSH((int)strlen(buf));
468: trampoline[1] = findword("type");
469:
470: PUSHR(PC);
471: PC = pointer2cell(trampoline);
472:
473: while (rstackcnt > tmp) {
474: dbg_interp_printk("printf_console: NEXT\n");
475: next();
476: }
477:
478: return i;
479: }
480:
481: static
482: int getchar_console(void)
483: {
484: cell tmp;
485:
486: /* Push to the Forth interpreter for console output */
487: tmp = rstackcnt;
488:
489: trampoline[1] = findword("key");
490:
491: PUSHR(PC);
492: PC = pointer2cell(trampoline);
493:
494: while (rstackcnt > tmp) {
495: dbg_interp_printk("getchar_console: NEXT\n");
496: next();
497: }
498:
499: return POP();
500: }
501:
502: static void
503: display_dbg_dstack(void)
504: {
505: /* Display dstack contents between parentheses */
506: int i;
507:
508: if (dstackcnt == 0) {
509: printf_console(" ( Empty ) ");
510: return;
511: } else {
512: printf_console(" ( ");
513: for (i = 1; i <= dstackcnt; i++) {
514: if (i != 1) {
515: printf_console(" ");
516: }
517: printf_console("%" FMT_CELL_x, dstack[i]);
518: }
519: printf_console(" ) ");
520: }
521: }
522:
523: static void
524: display_dbg_rstack(void)
525: {
526: /* Display rstack contents between parentheses */
527: int i;
528:
529: if (rstackcnt == 0) {
530: printf_console(" ( Empty ) ");
531: return;
532: } else {
533: printf_console("\nR: ( ");
534: for (i = 1; i <= rstackcnt; i++) {
535: if (i != 1) {
536: printf_console(" ");
537: }
538: printf_console("%" FMT_CELL_x, rstack[i]);
539: }
540: printf_console(" ) \n");
541: }
542: }
543:
544: static int
545: add_debug_xt(ucell xt)
546: {
547: struct debug_xt *debug_xt_item;
548:
549: /* If the xt CFA isn't DOCOL then issue a warning and do nothing */
550: if (read_ucell(cell2pointer(xt)) != DOCOL) {
551: printf_console("\nprimitive words cannot be debugged\n");
552: return 0;
553: }
554:
555: /* If this xt is already in the list, do nothing but indicate success */
556: for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL;
557: debug_xt_item = debug_xt_item->next)
558: if (debug_xt_item->xt_docol == xt) {
559: return 1;
560: }
561:
562: /* We already have the CFA (PC) indicating the starting cell of
563: the word, however we also need the ending cell too (we cannot
564: rely on the rstack as it can be arbitrarily changed by a forth
565: word). Hence the use of findsemis() */
566:
567: /* Otherwise add to the head of the linked list */
568: debug_xt_item = malloc(sizeof(struct debug_xt));
569: debug_xt_item->xt_docol = xt;
570: debug_xt_item->xt_semis = findsemis(xt);
571: debug_xt_item->mode = DEBUG_MODE_NONE;
572: debug_xt_item->next = debug_xt_list;
573: debug_xt_list = debug_xt_item;
574:
575: /* Indicate debug mode change */
576: interruptforth |= FORTH_INTSTAT_DBG;
577:
578: /* Success */
579: return 1;
580: }
581:
582: static void
583: del_debug_xt(ucell xt)
584: {
585: struct debug_xt *debug_xt_item, *tmp_xt_item;
586:
587: /* Handle the case where the xt is at the head of the list */
588: if (debug_xt_list->xt_docol == xt) {
589: tmp_xt_item = debug_xt_list;
590: debug_xt_list = debug_xt_list->next;
591: free(tmp_xt_item);
592:
593: return;
594: }
595:
596: /* Otherwise find this xt in the linked list and remove it */
597: for (debug_xt_item = debug_xt_list; debug_xt_item->next != NULL;
598: debug_xt_item = debug_xt_item->next) {
599: if (debug_xt_item->next->xt_docol == xt) {
600: tmp_xt_item = debug_xt_item->next;
601: debug_xt_item->next = debug_xt_item->next->next;
602: free(tmp_xt_item);
603: }
604: }
605:
606: /* If the list is now empty, indicate debug mode change */
607: if (debug_xt_list->next == NULL) {
608: interruptforth |= FORTH_INTSTAT_DBG;
609: }
610: }
611:
612: static void
613: do_source_dbg(struct debug_xt *debug_xt_item)
614: {
615: /* Forth source debugger implementation */
616: char k, done = 0;
617:
618: /* Display current dstack */
619: display_dbg_dstack();
620: printf_console("\n");
621:
622: fstrncpy(xtname, lfa2nfa(read_ucell(cell2pointer(PC)) - sizeof(cell)), MAXNFALEN);
623: printf_console("%p: %s ", cell2pointer(PC), xtname);
624:
625: /* If in trace mode, we just carry on */
626: if (debug_xt_item->mode == DEBUG_MODE_TRACE) {
627: return;
628: }
629:
630: /* Otherwise in step mode, prompt for a keypress */
631: k = getchar_console();
632:
633: /* Only proceed if done is true */
634: while (!done) {
635: switch (k) {
636:
637: case ' ':
638: case '\n':
639: /* Perform a single step */
640: done = 1;
641: break;
642:
643: case 'u':
644: case 'U':
645: /* Up - unmark current word for debug, mark its caller for
646: * debugging and finish executing current word */
647:
648: /* Since this word could alter the rstack during its execution,
649: * we only know the caller when (semis) is called for this xt.
650: * Hence we mark the xt as a special DEBUG_MODE_STEPUP which
651: * means we run as normal, but schedule the xt for deletion
652: * at its corresponding (semis) word when we know the rstack
653: * will be set to its final parent value */
654: debug_xt_item->mode = DEBUG_MODE_STEPUP;
655: done = 1;
656: break;
657:
658: case 'd':
659: case 'D':
660: /* Down - mark current word for debug and step into it */
661: done = add_debug_xt(read_ucell(cell2pointer(PC)));
662: if (!done) {
663: k = getchar_console();
664: }
665: break;
666:
667: case 't':
668: case 'T':
669: /* Trace mode */
670: debug_xt_item->mode = DEBUG_MODE_TRACE;
671: done = 1;
672: break;
673:
674: case 'r':
675: case 'R':
676: /* Display rstack */
677: display_dbg_rstack();
678: done = 0;
679: k = getchar_console();
680: break;
681:
682: case 'f':
683: case 'F':
684: /* Start subordinate Forth interpreter */
685: PUSHR(PC - sizeof(cell));
686: PC = findword("outer-interpreter") + sizeof(ucell);
687:
688: /* Save rstack position for when we return */
689: dbgrstackcnt = rstackcnt;
690: done = 1;
691: break;
692:
693: default:
694: /* Display debug banner */
695: printf_console(DEBUG_BANNER);
696: k = getchar_console();
697: }
698: }
699: }
700:
701: static void docol_dbg(void)
702: { /* DOCOL */
703: struct debug_xt *debug_xt_item;
704:
705: PUSHR(PC);
706: PC = read_ucell(cell2pointer(PC));
707:
708: /* If current xt is in our debug xt list, display word name */
709: debug_xt_item = debug_xt_list;
710: while (debug_xt_item->next) {
711: if (debug_xt_item->xt_docol == PC) {
712: fstrncpy(xtname, lfa2nfa(PC - sizeof(cell)), MAXNFALEN);
713: printf_console("\n: %s ", xtname);
714:
715: /* Step mode is the default */
716: debug_xt_item->mode = DEBUG_MODE_STEP;
717: }
718:
719: debug_xt_item = debug_xt_item->next;
720: }
721:
722: dbg_interp_printk("docol_dbg: %s\n", cell2pointer(lfa2nfa(PC - sizeof(cell))));
723: }
724:
725: static void semis_dbg(void)
726: {
727: struct debug_xt *debug_xt_item, *debug_xt_up = NULL;
728:
729: /* If current semis is in our debug xt list, disable debug mode */
730: debug_xt_item = debug_xt_list;
731: while (debug_xt_item->next) {
732: if (debug_xt_item->xt_semis == PC) {
733: if (debug_xt_item->mode != DEBUG_MODE_STEPUP) {
734: /* Handle the normal case */
735: fstrncpy(xtname, lfa2nfa(debug_xt_item->xt_docol - sizeof(cell)), MAXNFALEN);
736: printf_console("\n[ Finished %s ] ", xtname);
737:
738: /* Reset to step mode in case we were in trace mode */
739: debug_xt_item->mode = DEBUG_MODE_STEP;
740: } else {
741: /* This word requires execution of the debugger "Up"
742: * semantics. However we can't do this here since we
743: * are iterating through the debug list, and we need
744: * to change it. So we do it afterwards.
745: */
746: debug_xt_up = debug_xt_item;
747: }
748: }
749:
750: debug_xt_item = debug_xt_item->next;
751: }
752:
753: /* Execute debugger "Up" semantics if required */
754: if (debug_xt_up) {
755: /* Only add the parent word if it is not within the trampoline */
756: if (rstack[rstackcnt] != (cell)pointer2cell(&trampoline[1])) {
757: del_debug_xt(debug_xt_up->xt_docol);
758: add_debug_xt(findxtfromcell(rstack[rstackcnt]));
759:
760: fstrncpy(xtname, lfa2nfa(findxtfromcell(rstack[rstackcnt]) - sizeof(cell)), MAXNFALEN);
761: printf_console("\n[ Up to %s ] ", xtname);
762: } else {
763: fstrncpy(xtname, lfa2nfa(findxtfromcell(debug_xt_up->xt_docol) - sizeof(cell)), MAXNFALEN);
764: printf_console("\n[ Finished %s (Unable to go up, hit trampoline) ] ", xtname);
765:
766: del_debug_xt(debug_xt_up->xt_docol);
767: }
768:
769: debug_xt_up = NULL;
770: }
771:
772: PC = POPR();
773: }
774:
775: static inline void next_dbg(void)
776: {
777: struct debug_xt *debug_xt_item;
778: void (*tokenp) (void);
779:
780: PC += sizeof(ucell);
781:
782: /* If the PC lies within a debug range, run the source debugger */
783: debug_xt_item = debug_xt_list;
784: while (debug_xt_item->next) {
785: if (PC >= debug_xt_item->xt_docol && PC <= debug_xt_item->xt_semis &&
786: debug_xt_item->mode != DEBUG_MODE_STEPUP) {
787: do_source_dbg(debug_xt_item);
788: }
789:
790: debug_xt_item = debug_xt_item->next;
791: }
792:
793: dbg_interp_printk("next_dbg: PC is now %x\n", PC);
794:
795: /* Intercept DOCOL and SEMIS and redirect to debug versions */
796: if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOCOL) {
797: tokenp = docol_dbg;
798: tokenp();
799: } else if (read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))) == DOSEMIS) {
800: tokenp = semis_dbg;
801: tokenp();
802: } else {
803: /* Otherwise process as normal */
804: processxt(read_ucell(cell2pointer(read_ucell(cell2pointer(PC)))));
805: }
806: }
807:
808: static void
809: do_debug_xt(void)
810: {
811: ucell xt = POP();
812:
813: /* Add to the debug list */
814: if (add_debug_xt(xt)) {
815: /* Display debug banner */
816: printf_console(DEBUG_BANNER);
817:
818: /* Indicate change to debug mode */
819: interruptforth |= FORTH_INTSTAT_DBG;
820: }
821: }
822:
823: static void
824: do_debug_off(void)
825: {
826: /* Empty the debug xt linked list */
827: while (debug_xt_list->next != NULL) {
828: del_debug_xt(debug_xt_list->xt_docol);
829: }
830: }
831:
832: /*
833: * Forth primitives needed to set up
834: * all the words described in IEEE1275-1994.
835: */
836:
837: /*
838: * dup ( x -- x x )
839: */
840:
841: static void fdup(void)
842: {
843: const cell tmp = GETTOS();
844: PUSH(tmp);
845: }
846:
847:
848: /*
849: * 2dup ( x1 x2 -- x1 x2 x1 x2 )
850: */
851:
852: static void twodup(void)
853: {
854: cell tmp = GETITEM(1);
855: PUSH(tmp);
856: tmp = GETITEM(1);
857: PUSH(tmp);
858: }
859:
860:
861: /*
862: * ?dup ( x -- 0 | x x )
863: */
864:
865: static void isdup(void)
866: {
867: const cell tmp = GETTOS();
868: if (tmp)
869: PUSH(tmp);
870: }
871:
872:
873: /*
874: * over ( x y -- x y x )
875: */
876:
877: static void over(void)
878: {
879: const cell tmp = GETITEM(1);
880: PUSH(tmp);
881: }
882:
883:
884: /*
885: * 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
886: */
887:
888: static void twoover(void)
889: {
890: const cell tmp = GETITEM(3);
891: const cell tmp2 = GETITEM(2);
892: PUSH(tmp);
893: PUSH(tmp2);
894: }
895:
896: /*
897: * pick ( xu ... x1 x0 u -- xu ... x1 x0 xu )
898: */
899:
900: static void pick(void)
901: {
902: const cell u = POP();
903: if (dstackcnt >= u) {
904: ucell tmp = dstack[dstackcnt - u];
905: PUSH(tmp);
906: } else {
907: /* underrun */
908: }
909: }
910:
911:
912: /*
913: * drop ( x -- )
914: */
915:
916: static void drop(void)
917: {
918: POP();
919: }
920:
921: /*
922: * 2drop ( x1 x2 -- )
923: */
924:
925: static void twodrop(void)
926: {
927: POP();
928: POP();
929: }
930:
931:
932: /*
933: * nip ( x1 x2 -- x2 )
934: */
935:
936: static void nip(void)
937: {
938: const cell tmp = POP();
939: POP();
940: PUSH(tmp);
941: }
942:
943:
944: /*
945: * roll ( xu ... x1 x0 u -- xu-1... x1 x0 xu )
946: */
947:
948: static void roll(void)
949: {
950: const cell u = POP();
951: if (dstackcnt >= u) {
952: int i;
953: const cell xu = dstack[dstackcnt - u];
954: for (i = dstackcnt - u; i < dstackcnt; i++) {
955: dstack[i] = dstack[i + 1];
956: }
957: dstack[dstackcnt] = xu;
958: } else {
959: /* Stack underrun */
960: }
961: }
962:
963:
964: /*
965: * rot ( x1 x2 x3 -- x2 x3 x1 )
966: */
967:
968: static void rot(void)
969: {
970: const cell tmp = POP();
971: const cell tmp2 = POP();
972: const cell tmp3 = POP();
973: PUSH(tmp2);
974: PUSH(tmp);
975: PUSH(tmp3);
976: }
977:
978:
979: /*
980: * -rot ( x1 x2 x3 -- x3 x1 x2 )
981: */
982:
983: static void minusrot(void)
984: {
985: const cell tmp = POP();
986: const cell tmp2 = POP();
987: const cell tmp3 = POP();
988: PUSH(tmp);
989: PUSH(tmp3);
990: PUSH(tmp2);
991: }
992:
993:
994: /*
995: * swap ( x1 x2 -- x2 x1 )
996: */
997:
998: static void swap(void)
999: {
1000: const cell tmp = POP();
1001: const cell tmp2 = POP();
1002: PUSH(tmp);
1003: PUSH(tmp2);
1004: }
1005:
1006:
1007: /*
1008: * 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
1009: */
1010:
1011: static void twoswap(void)
1012: {
1013: const cell tmp = POP();
1014: const cell tmp2 = POP();
1015: const cell tmp3 = POP();
1016: const cell tmp4 = POP();
1017: PUSH(tmp2);
1018: PUSH(tmp);
1019: PUSH(tmp4);
1020: PUSH(tmp3);
1021: }
1022:
1023:
1024: /*
1025: * >r ( x -- ) (R: -- x )
1026: */
1027:
1028: static void tor(void)
1029: {
1030: ucell tmp = POP();
1031: #ifdef CONFIG_DEBUG_RSTACK
1032: printk(" >R: %x\n", tmp);
1033: #endif
1034: PUSHR(tmp);
1035: }
1036:
1037:
1038: /*
1039: * r> ( -- x ) (R: x -- )
1040: */
1041:
1042: static void rto(void)
1043: {
1044: ucell tmp = POPR();
1045: #ifdef CONFIG_DEBUG_RSTACK
1046: printk(" R>: %x\n", tmp);
1047: #endif
1048: PUSH(tmp);
1049: }
1050:
1051:
1052: /*
1053: * r@ ( -- x ) (R: x -- x )
1054: */
1055:
1056: static void rfetch(void)
1057: {
1058: PUSH(GETTORS());
1059: }
1060:
1061:
1062: /*
1063: * depth ( -- u )
1064: */
1065:
1066: static void depth(void)
1067: {
1068: const cell tmp = dstackcnt;
1069: PUSH(tmp);
1070: }
1071:
1072:
1073: /*
1074: * depth! ( ... u -- x1 x2 .. xu )
1075: */
1076:
1077: static void depthwrite(void)
1078: {
1079: ucell tmp = POP();
1080: dstackcnt = tmp;
1081: }
1082:
1083:
1084: /*
1085: * rdepth ( -- u )
1086: */
1087:
1088: static void rdepth(void)
1089: {
1090: const cell tmp = rstackcnt;
1091: PUSH(tmp);
1092: }
1093:
1094:
1095: /*
1096: * rdepth! ( u -- ) ( R: ... -- x1 x2 .. xu )
1097: */
1098:
1099: static void rdepthwrite(void)
1100: {
1101: ucell tmp = POP();
1102: rstackcnt = tmp;
1103: }
1104:
1105:
1106: /*
1107: * + ( nu1 nu2 -- sum )
1108: */
1109:
1110: static void plus(void)
1111: {
1112: cell tmp = POP() + POP();
1113: PUSH(tmp);
1114: }
1115:
1116:
1117: /*
1118: * - ( nu1 nu2 -- diff )
1119: */
1120:
1121: static void minus(void)
1122: {
1123: const cell nu2 = POP();
1124: const cell nu1 = POP();
1125: PUSH(nu1 - nu2);
1126: }
1127:
1128:
1129: /*
1130: * * ( nu1 nu2 -- prod )
1131: */
1132:
1133: static void mult(void)
1134: {
1135: const cell nu2 = POP();
1136: const cell nu1 = POP();
1137: PUSH(nu1 * nu2);
1138: }
1139:
1140:
1141: /*
1142: * u* ( u1 u2 -- prod )
1143: */
1144:
1145: static void umult(void)
1146: {
1147: const ucell tmp = (ucell) POP() * (ucell) POP();
1148: PUSH(tmp);
1149: }
1150:
1151:
1152: /*
1153: * mu/mod ( n1 n2 -- rem quot.l quot.h )
1154: */
1155:
1156: static void mudivmod(void)
1157: {
1158: const ucell b = POP();
1159: const ducell a = DPOP();
1160: #ifdef NEED_FAKE_INT128_T
1161: if (a.hi != 0) {
1162: fprintf(stderr, "mudivmod called (0x%016llx %016llx / 0x%016llx)\n",
1163: a.hi, a.lo, b);
1164: exit(-1);
1165: } else {
1166: ducell c;
1167:
1168: PUSH(a.lo % b);
1169: c.hi = 0;
1170: c.lo = a.lo / b;
1171: DPUSH(c);
1172: }
1173: #else
1174: PUSH(a % b);
1175: DPUSH(a / b);
1176: #endif
1177: }
1178:
1179:
1180: /*
1181: * abs ( n -- u )
1182: */
1183:
1184: static void forthabs(void)
1185: {
1186: const cell tmp = GETTOS();
1187: if (tmp < 0) {
1188: POP();
1189: PUSH(-tmp);
1190: }
1191: }
1192:
1193:
1194: /*
1195: * negate ( n1 -- n2 )
1196: */
1197:
1198: static void negate(void)
1199: {
1200: const cell tmp = POP();
1201: PUSH(-tmp);
1202: }
1203:
1204:
1205: /*
1206: * max ( n1 n2 -- n1|n2 )
1207: */
1208:
1209: static void max(void)
1210: {
1211: const cell tmp = POP();
1212: const cell tmp2 = POP();
1213: PUSH((tmp > tmp2) ? tmp : tmp2);
1214: }
1215:
1216:
1217: /*
1218: * min ( n1 n2 -- n1|n2 )
1219: */
1220:
1221: static void min(void)
1222: {
1223: const cell tmp = POP();
1224: const cell tmp2 = POP();
1225: PUSH((tmp < tmp2) ? tmp : tmp2);
1226: }
1227:
1228:
1229: /*
1230: * lshift ( x1 u -- x2 )
1231: */
1232:
1233: static void lshift(void)
1234: {
1235: const ucell u = POP();
1236: const ucell x1 = POP();
1237: PUSH(x1 << u);
1238: }
1239:
1240:
1241: /*
1242: * rshift ( x1 u -- x2 )
1243: */
1244:
1245: static void rshift(void)
1246: {
1247: const ucell u = POP();
1248: const ucell x1 = POP();
1249: PUSH(x1 >> u);
1250: }
1251:
1252:
1253: /*
1254: * >>a ( x1 u -- x2 ) ??
1255: */
1256:
1257: static void rshifta(void)
1258: {
1259: const cell u = POP();
1260: const cell x1 = POP();
1261: PUSH(x1 >> u);
1262: }
1263:
1264:
1265: /*
1266: * and ( x1 x2 -- x3 )
1267: */
1268:
1269: static void and(void)
1270: {
1271: const cell x1 = POP();
1272: const cell x2 = POP();
1273: PUSH(x1 & x2);
1274: }
1275:
1276:
1277: /*
1278: * or ( x1 x2 -- x3 )
1279: */
1280:
1281: static void or(void)
1282: {
1283: const cell x1 = POP();
1284: const cell x2 = POP();
1285: PUSH(x1 | x2);
1286: }
1287:
1288:
1289: /*
1290: * xor ( x1 x2 -- x3 )
1291: */
1292:
1293: static void xor(void)
1294: {
1295: const cell x1 = POP();
1296: const cell x2 = POP();
1297: PUSH(x1 ^ x2);
1298: }
1299:
1300:
1301: /*
1302: * invert ( x1 -- x2 )
1303: */
1304:
1305: static void invert(void)
1306: {
1307: const cell x1 = POP();
1308: PUSH(x1 ^ -1);
1309: }
1310:
1311:
1312: /*
1313: * d+ ( d1 d2 -- d.sum )
1314: */
1315:
1316: static void dplus(void)
1317: {
1318: const dcell d2 = DPOP();
1319: const dcell d1 = DPOP();
1320: #ifdef NEED_FAKE_INT128_T
1321: ducell c;
1322:
1323: if (d1.hi != 0 || d2.hi != 0) {
1324: fprintf(stderr, "dplus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
1325: d1.hi, d1.lo, d2.hi, d2.lo);
1326: exit(-1);
1327: }
1328: c.hi = 0;
1329: c.lo = d1.lo + d2.lo;
1330: DPUSH(c);
1331: #else
1332: DPUSH(d1 + d2);
1333: #endif
1334: }
1335:
1336:
1337: /*
1338: * d- ( d1 d2 -- d.diff )
1339: */
1340:
1341: static void dminus(void)
1342: {
1343: const dcell d2 = DPOP();
1344: const dcell d1 = DPOP();
1345: #ifdef NEED_FAKE_INT128_T
1346: ducell c;
1347:
1348: if (d1.hi != 0 || d2.hi != 0) {
1349: fprintf(stderr, "dminus called (0x%016llx %016llx + 0x%016llx %016llx)\n",
1350: d1.hi, d1.lo, d2.hi, d2.lo);
1351: exit(-1);
1352: }
1353: c.hi = 0;
1354: c.lo = d1.lo - d2.lo;
1355: DPUSH(c);
1356: #else
1357: DPUSH(d1 - d2);
1358: #endif
1359: }
1360:
1361:
1362: /*
1363: * m* ( ?? -- )
1364: */
1365:
1366: static void mmult(void)
1367: {
1368: const cell u2 = POP();
1369: const cell u1 = POP();
1370: #ifdef NEED_FAKE_INT128_T
1371: ducell c;
1372:
1373: if (0) { // XXX How to detect overflow?
1374: fprintf(stderr, "mmult called (%016llx * 0x%016llx)\n", u1, u2);
1375: exit(-1);
1376: }
1377: c.hi = 0;
1378: c.lo = u1 * u2;
1379: DPUSH(c);
1380: #else
1381: DPUSH((dcell) u1 * u2);
1382: #endif
1383: }
1384:
1385:
1386: /*
1387: * um* ( u1 u2 -- d.prod )
1388: */
1389:
1390: static void ummult(void)
1391: {
1392: const ucell u2 = POP();
1393: const ucell u1 = POP();
1394: #ifdef NEED_FAKE_INT128_T
1395: ducell c;
1396:
1397: if (0) { // XXX How to detect overflow?
1398: fprintf(stderr, "ummult called (%016llx * 0x%016llx)\n", u1, u2);
1399: exit(-1);
1400: }
1401: c.hi = 0;
1402: c.lo = u1 * u2;
1403: DPUSH(c);
1404: #else
1405: DPUSH((ducell) u1 * u2);
1406: #endif
1407: }
1408:
1409:
1410: /*
1411: * @ ( a-addr -- x )
1412: */
1413:
1414: static void fetch(void)
1415: {
1416: const ucell *aaddr = (ucell *)cell2pointer(POP());
1417: PUSH(read_ucell(aaddr));
1418: }
1419:
1420:
1421: /*
1422: * c@ ( addr -- byte )
1423: */
1424:
1425: static void cfetch(void)
1426: {
1427: const u8 *aaddr = (u8 *)cell2pointer(POP());
1428: PUSH(read_byte(aaddr));
1429: }
1430:
1431:
1432: /*
1433: * w@ ( waddr -- w )
1434: */
1435:
1436: static void wfetch(void)
1437: {
1438: const u16 *aaddr = (u16 *)cell2pointer(POP());
1439: PUSH(read_word(aaddr));
1440: }
1441:
1442:
1443: /*
1444: * l@ ( qaddr -- quad )
1445: */
1446:
1447: static void lfetch(void)
1448: {
1449: const u32 *aaddr = (u32 *)cell2pointer(POP());
1450: PUSH(read_long(aaddr));
1451: }
1452:
1453:
1454: /*
1455: * ! ( x a-addr -- )
1456: */
1457:
1458: static void store(void)
1459: {
1460: const ucell *aaddr = (ucell *)cell2pointer(POP());
1461: const ucell x = POP();
1462: #ifdef CONFIG_DEBUG_INTERNAL
1463: printk("!: %lx : %lx -> %lx\n", aaddr, read_ucell(aaddr), x);
1464: #endif
1465: write_ucell(aaddr,x);
1466: }
1467:
1468:
1469: /*
1470: * +! ( nu a-addr -- )
1471: */
1472:
1473: static void plusstore(void)
1474: {
1475: const ucell *aaddr = (ucell *)cell2pointer(POP());
1476: const cell nu = POP();
1477: write_cell(aaddr,read_cell(aaddr)+nu);
1478: }
1479:
1480:
1481: /*
1482: * c! ( byte addr -- )
1483: */
1484:
1485: static void cstore(void)
1486: {
1487: const u8 *aaddr = (u8 *)cell2pointer(POP());
1488: const ucell byte = POP();
1489: #ifdef CONFIG_DEBUG_INTERNAL
1490: printk("c!: %x = %x\n", aaddr, byte);
1491: #endif
1492: write_byte(aaddr, byte);
1493: }
1494:
1495:
1496: /*
1497: * w! ( w waddr -- )
1498: */
1499:
1500: static void wstore(void)
1501: {
1502: const u16 *aaddr = (u16 *)cell2pointer(POP());
1503: const u16 word = POP();
1504: write_word(aaddr, word);
1505: }
1506:
1507:
1508: /*
1509: * l! ( quad qaddr -- )
1510: */
1511:
1512: static void lstore(void)
1513: {
1514: const u32 *aaddr = (u32 *)cell2pointer(POP());
1515: const u32 longval = POP();
1516: write_long(aaddr, longval);
1517: }
1518:
1519:
1520: /*
1521: * = ( x1 x2 -- equal? )
1522: */
1523:
1524: static void equals(void)
1525: {
1526: cell tmp = (POP() == POP());
1527: PUSH(-tmp);
1528: }
1529:
1530:
1531: /*
1532: * > ( n1 n2 -- greater? )
1533: */
1534:
1535: static void greater(void)
1536: {
1537: cell tmp = ((cell) POP() < (cell) POP());
1538: PUSH(-tmp);
1539: }
1540:
1541:
1542: /*
1543: * < ( n1 n2 -- less? )
1544: */
1545:
1546: static void less(void)
1547: {
1548: cell tmp = ((cell) POP() > (cell) POP());
1549: PUSH(-tmp);
1550: }
1551:
1552:
1553: /*
1554: * u> ( u1 u2 -- unsigned-greater? )
1555: */
1556:
1557: static void ugreater(void)
1558: {
1559: cell tmp = ((ucell) POP() < (ucell) POP());
1560: PUSH(-tmp);
1561: }
1562:
1563:
1564: /*
1565: * u< ( u1 u2 -- unsigned-less? )
1566: */
1567:
1568: static void uless(void)
1569: {
1570: cell tmp = ((ucell) POP() > (ucell) POP());
1571: PUSH(-tmp);
1572: }
1573:
1574:
1575: /*
1576: * sp@ ( -- stack-pointer )
1577: */
1578:
1579: static void spfetch(void)
1580: {
1581: // FIXME this can only work if the stack pointer
1582: // is within range.
1583: ucell tmp = pointer2cell(&(dstack[dstackcnt]));
1584: PUSH(tmp);
1585: }
1586:
1587:
1588: /*
1589: * move ( src-addr dest-addr len -- )
1590: */
1591:
1592: static void fmove(void)
1593: {
1594: ucell count = POP();
1595: void *dest = (void *)cell2pointer(POP());
1596: const void *src = (const void *)cell2pointer(POP());
1597: memmove(dest, src, count);
1598: }
1599:
1600:
1601: /*
1602: * fill ( addr len byte -- )
1603: */
1604:
1605: static void ffill(void)
1606: {
1607: ucell value = POP();
1608: ucell count = POP();
1609: void *src = (void *)cell2pointer(POP());
1610: memset(src, value, count);
1611: }
1612:
1613:
1614: /*
1615: * unaligned-w@ ( addr -- w )
1616: */
1617:
1618: static void unalignedwordread(void)
1619: {
1620: const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
1621: PUSH(unaligned_read_word(addr));
1622: }
1623:
1624:
1625: /*
1626: * unaligned-w! ( w addr -- )
1627: */
1628:
1629: static void unalignedwordwrite(void)
1630: {
1631: const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
1632: u16 w = POP();
1633: unaligned_write_word(addr, w);
1634: }
1635:
1636:
1637: /*
1638: * unaligned-l@ ( addr -- quad )
1639: */
1640:
1641: static void unalignedlongread(void)
1642: {
1643: const unsigned char *addr = (const unsigned char *) cell2pointer(POP());
1644: PUSH(unaligned_read_long(addr));
1645: }
1646:
1647:
1648: /*
1649: * unaligned-l! ( quad addr -- )
1650: */
1651:
1652: static void unalignedlongwrite(void)
1653: {
1654: unsigned char *addr = (unsigned char *) cell2pointer(POP());
1655: u32 l = POP();
1656: unaligned_write_long(addr, l);
1657: }
1658:
1659: /*
1660: * here ( -- dictionary-pointer )
1661: */
1662:
1663: static void here(void)
1664: {
1665: PUSH(pointer2cell(dict) + dicthead);
1666: #ifdef CONFIG_DEBUG_INTERNAL
1667: printk("here: %x\n", pointer2cell(dict) + dicthead);
1668: #endif
1669: }
1670:
1671: /*
1672: * here! ( new-dict-pointer -- )
1673: */
1674:
1675: static void herewrite(void)
1676: {
1677: ucell tmp = POP(); /* converted pointer */
1678: dicthead = tmp - pointer2cell(dict);
1679: #ifdef CONFIG_DEBUG_INTERNAL
1680: printk("here!: new value: %x\n", tmp);
1681: #endif
1682:
1683: if (dictlimit && dicthead >= dictlimit) {
1684: printk("Dictionary space overflow:"
1685: " dicthead=" FMT_ucellx
1686: " dictlimit=" FMT_ucellx
1687: "\n",
1688: dicthead, dictlimit);
1689: }
1690: }
1691:
1692:
1693: /*
1694: * emit ( char -- )
1695: */
1696:
1697: static void emit(void)
1698: {
1699: cell tmp = POP();
1700: #ifndef FCOMPILER
1701: putchar(tmp);
1702: #else
1703: put_outputbyte(tmp);
1704: #endif
1705: }
1706:
1707:
1708: /*
1709: * key? ( -- pressed? )
1710: */
1711:
1712: static void iskey(void)
1713: {
1714: PUSH((cell) availchar());
1715: }
1716:
1717:
1718: /*
1719: * key ( -- char )
1720: */
1721:
1722: static void key(void)
1723: {
1724: while (!availchar());
1725: #ifdef FCOMPILER
1726: PUSH(get_inputbyte());
1727: #else
1728: PUSH(getchar());
1729: #endif
1730: }
1731:
1732:
1733: /*
1734: * ioc@ ( reg -- val )
1735: */
1736:
1737: static void iocfetch(void)
1738: {
1739: #ifndef FCOMPILER
1740: cell reg = POP();
1741: PUSH(inb(reg));
1742: #else
1743: (void)POP();
1744: PUSH(0);
1745: #endif
1746: }
1747:
1748:
1749: /*
1750: * iow@ ( reg -- val )
1751: */
1752:
1753: static void iowfetch(void)
1754: {
1755: #ifndef FCOMPILER
1756: cell reg = POP();
1757: PUSH(inw(reg));
1758: #else
1759: (void)POP();
1760: PUSH(0);
1761: #endif
1762: }
1763:
1764: /*
1765: * iol@ ( reg -- val )
1766: */
1767:
1768: static void iolfetch(void)
1769: {
1770: #ifndef FCOMPILER
1771: cell reg = POP();
1772: PUSH(inl(reg));
1773: #else
1774: (void)POP();
1775: PUSH(0);
1776: #endif
1777: }
1778:
1779:
1780: /*
1781: * ioc! ( val reg -- )
1782: */
1783:
1784: static void iocstore(void)
1785: {
1786: #ifndef FCOMPILER
1787: cell reg = POP();
1788: cell val = POP();
1789:
1790: outb(reg, val);
1791: #else
1792: (void)POP();
1793: (void)POP();
1794: #endif
1795: }
1796:
1797:
1798: /*
1799: * iow! ( val reg -- )
1800: */
1801:
1802: static void iowstore(void)
1803: {
1804: #ifndef FCOMPILER
1805: cell reg = POP();
1806: cell val = POP();
1807:
1808: outw(reg, val);
1809: #else
1810: (void)POP();
1811: (void)POP();
1812: #endif
1813: }
1814:
1815:
1816: /*
1817: * iol! ( val reg -- )
1818: */
1819:
1820: static void iolstore(void)
1821: {
1822: #ifndef FCOMPILER
1823: ucell reg = POP();
1824: ucell val = POP();
1825:
1826: outl(reg, val);
1827: #else
1828: (void)POP();
1829: (void)POP();
1830: #endif
1831: }
1832:
1833: /*
1834: * i ( -- i )
1835: */
1836:
1837: static void loop_i(void)
1838: {
1839: PUSH(rstack[rstackcnt]);
1840: }
1841:
1842: /*
1843: * j ( -- i )
1844: */
1845:
1846: static void loop_j(void)
1847: {
1848: PUSH(rstack[rstackcnt - 2]);
1849: }
1850:
1851: /* words[] is a function array of all native code functions used by
1852: * the dictionary, i.e. CFAs and primitives.
1853: * Any change here needs a matching change in the primitive word's
1854: * name list that is kept for bootstrapping in kernel/bootstrap.c
1855: *
1856: * NOTE: THIS LIST SHALL NOT CHANGE (EXCEPT MANDATORY ADDITIONS AT
1857: * THE END). ANY OTHER CHANGE WILL BREAK COMPATIBILITY TO OLDER
1858: * BINARY DICTIONARIES.
1859: */
1860: static forth_word * const words[] = {
1861: /*
1862: * CFAs and special words
1863: */
1864: semis,
1865: docol,
1866: lit,
1867: docon,
1868: dovar,
1869: dodefer,
1870: dodoes,
1871: dodo,
1872: doisdo,
1873: doloop,
1874: doplusloop,
1875: doival,
1876: doivar,
1877: doidefer,
1878:
1879: /*
1880: * primitives
1881: */
1882: fdup, /* dup */
1883: twodup, /* 2dup */
1884: isdup, /* ?dup */
1885: over, /* over */
1886: twoover, /* 2over */
1887: pick, /* pick */
1888: drop, /* drop */
1889: twodrop, /* 2drop */
1890: nip, /* nip */
1891: roll, /* roll */
1892: rot, /* rot */
1893: minusrot, /* -rot */
1894: swap, /* swap */
1895: twoswap, /* 2swap */
1896: tor, /* >r */
1897: rto, /* r> */
1898: rfetch, /* r@ */
1899: depth, /* depth */
1900: depthwrite, /* depth! */
1901: rdepth, /* rdepth */
1902: rdepthwrite, /* rdepth! */
1903: plus, /* + */
1904: minus, /* - */
1905: mult, /* * */
1906: umult, /* u* */
1907: mudivmod, /* mu/mod */
1908: forthabs, /* abs */
1909: negate, /* negate */
1910: max, /* max */
1911: min, /* min */
1912: lshift, /* lshift */
1913: rshift, /* rshift */
1914: rshifta, /* >>a */
1915: and, /* and */
1916: or, /* or */
1917: xor, /* xor */
1918: invert, /* invert */
1919: dplus, /* d+ */
1920: dminus, /* d- */
1921: mmult, /* m* */
1922: ummult, /* um* */
1923: fetch, /* @ */
1924: cfetch, /* c@ */
1925: wfetch, /* w@ */
1926: lfetch, /* l@ */
1927: store, /* ! */
1928: plusstore, /* +! */
1929: cstore, /* c! */
1930: wstore, /* w! */
1931: lstore, /* l! */
1932: equals, /* = */
1933: greater, /* > */
1934: less, /* < */
1935: ugreater, /* u> */
1936: uless, /* u< */
1937: spfetch, /* sp@ */
1938: fmove, /* move */
1939: ffill, /* fill */
1940: emit, /* emit */
1941: iskey, /* key? */
1942: key, /* key */
1943: execute, /* execute */
1944: here, /* here */
1945: herewrite, /* here! */
1946: dobranch, /* dobranch */
1947: docbranch, /* do?branch */
1948: unalignedwordread, /* unaligned-w@ */
1949: unalignedwordwrite, /* unaligned-w! */
1950: unalignedlongread, /* unaligned-l@ */
1951: unalignedlongwrite, /* unaligned-l! */
1952: iocfetch, /* ioc@ */
1953: iowfetch, /* iow@ */
1954: iolfetch, /* iol@ */
1955: iocstore, /* ioc! */
1956: iowstore, /* iow! */
1957: iolstore, /* iol! */
1958: loop_i, /* i */
1959: loop_j, /* j */
1960: call, /* call */
1961: sysdebug, /* sys-debug */
1962: do_include, /* $include */
1963: do_encode_file, /* $encode-file */
1964: do_debug_xt, /* (debug */
1965: do_debug_off, /* (debug-off) */
1966: };
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.