1: /*
2: Copyright 1992 by the ANSI figForth Development Group
3: */
4:
5: #include <ctype.h>
6: #include <stdio.h>
7: #include <string.h>
8: #include <math.h>
9: #include <sys/types.h>
10: #include <sys/stat.h>
11: #include <fcntl.h>
12: #include <assert.h>
13: #include <stdlib.h>
14: #include <time.h>
15: #include <sys/time.h>
16: #include "forth.h"
17: #include "io.h"
18:
19: typedef union {
20: struct {
21: #ifdef BIG_ENDIAN
22: Cell high;
23: Cell low;
24: #else
25: Cell low;
26: Cell high;
27: #endif;
28: } cells;
29: DCell dcell;
30: } Double_Store;
31:
32: typedef struct F83Name {
33: struct F83Name *next; /* the link field for old hands */
34: char countetc;
35: Char name[0];
36: } F83Name;
37:
38: /* are macros for setting necessary? */
39: #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
40: #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
41: #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
42:
43: /* NEXT and NEXT1 are split into several parts to help scheduling,
44: unless CISC_NEXT is defined */
45: #ifdef CISC_NEXT
46: #define NEXT1_P1
47: #define NEXT_P1
48: #define DEF_CA
49: #ifdef DIRECT_THREADED
50: #define NEXT1_P2 ({goto *cfa;})
51: #else
52: #define NEXT1_P2 ({goto **cfa;})
53: #endif /* DIRECT_THREADED */
54: #define NEXT_P2 ({cfa = *ip++; NEXT1_P2;})
55: #else /* CISC_NEXT */
56: #ifdef DIRECT_THREADED
57: #define NEXT1_P1
58: #define NEXT1_P2 ({goto *cfa;})
59: #define DEF_CA
60: #else /* DIRECT_THREADED */
61: #define NEXT1_P1 ({ca = *cfa;})
62: #define NEXT1_P2 ({goto *ca;})
63: #define DEF_CA Label ca;
64: #endif /* DIRECT_THREADED */
65: #define NEXT_P1 ({cfa=*ip++; NEXT1_P1;})
66: #define NEXT_P2 NEXT1_P2
67: #endif /* CISC_NEXT */
68:
69: #define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})
70: #define NEXT ({DEF_CA NEXT_P1; NEXT_P2;})
71:
72: #ifdef USE_TOS
73: #define IF_TOS(x) x
74: #else
75: #define IF_TOS(x)
76: #define TOS (sp[0])
77: #endif
78:
79: #ifdef USE_FTOS
80: #define IF_FTOS(x) x
81: #else
82: #define IF_FTOS(x)
83: #define FTOS (fp[0])
84: #endif
85:
86: int emitcounter;
87: #define NULLC '\0'
88:
89: char *cstr(Char *from, UCell size, int clear)
90: /* if clear is true, scratch can be reused, otherwise we want more of
91: the same */
92: {
93: static char *scratch=NULL;
94: static unsigned scratchsize=0;
95: static char *nextscratch;
96: char *oldnextscratch;
97:
98: if (clear)
99: nextscratch=scratch;
100: if (scratch==NULL) {
101: scratch=malloc(size+1);
102: nextscratch=scratch;
103: scratchsize=size;
104: }
105: else if (nextscratch+size>scratch+scratchsize) {
106: char *oldscratch=scratch;
107: scratch = realloc(scratch, (nextscratch-scratch)+size+1);
108: nextscratch=scratch+(nextscratch-oldscratch);
109: scratchsize=size;
110: }
111: memcpy(nextscratch,from,size);
112: nextscratch[size]='\0';
113: oldnextscratch = nextscratch;
114: nextscratch += size+1;
115: return oldnextscratch;
116: }
117:
118: #define NEWLINE '\n'
119:
120:
121: static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
122:
123: static Address up0=NULL;
124:
125: /* if machine.h has not defined explicit registers, define them as implicit */
126: #ifndef IPREG
127: #define IPREG
128: #endif
129: #ifndef SPREG
130: #define SPREG
131: #endif
132: #ifndef RPREG
133: #define RPREG
134: #endif
135: #ifndef FPREG
136: #define FPREG
137: #endif
138: #ifndef LPREG
139: #define LPREG
140: #endif
141: #ifndef CFAREG
142: #define CFAREG
143: #endif
144: #ifndef UPREG
145: #define UPREG
146: #endif
147: #ifndef TOSREG
148: #define TOSREG
149: #endif
150: #ifndef FTOSREG
151: #define FTOSREG
152: #endif
153:
154: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
155: /* executes code at ip, if ip!=NULL
156: returns array of machine code labels (for use in a loader), if ip==NULL
157: */
158: {
159: register Xt *ip IPREG = ip0;
160: register Cell *sp SPREG = sp0;
161: register Cell *rp RPREG = rp0;
162: register Float *fp FPREG = fp0;
163: register Address lp LPREG = lp0;
164: register Xt cfa CFAREG;
165: register Address up UPREG = up0;
166: IF_TOS(register Cell TOS TOSREG;)
167: IF_FTOS(register Float FTOS FTOSREG;)
168: static Label symbols[]= {
169: &&docol,
170: &&docon,
171: &&dovar,
172: &&douser,
173: &&dodefer,
174: &&dodoes,
175: &&dodoes, /* dummy for does handler address */
176: #include "prim_labels.i"
177: };
178: #ifdef CPU_DEP
179: CPU_DEP;
180: #endif
181:
182: #ifdef DEBUG
183: fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
184: ip,sp,rp,fp,lp,up);
185: #endif
186:
187: if (ip == NULL)
188: return symbols;
189:
190: IF_TOS(TOS = sp[0]);
191: IF_FTOS(FTOS = fp[0]);
192: prep_terminal();
193: NEXT;
194:
195: docol:
196: #ifdef DEBUG
197: fprintf(stderr,"%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
198: #endif
199: #ifdef CISC_NEXT
200: /* this is the simple version */
201: *--rp = (Cell)ip;
202: ip = (Xt *)PFA1(cfa);
203: NEXT;
204: #else
205: /* this one is important, so we help the compiler optimizing
206: The following version may be better (for scheduling), but probably has
207: problems with code fields employing calls and delay slots
208: */
209: {
210: DEF_CA
211: Xt *current_ip = (Xt *)PFA1(cfa);
212: cfa = *current_ip;
213: NEXT1_P1;
214: *--rp = (Cell)ip;
215: ip = current_ip+1;
216: NEXT1_P2;
217: }
218: #endif
219:
220: docon:
221: #ifdef DEBUG
222: fprintf(stderr,"%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));
223: #endif
224: #ifdef USE_TOS
225: *sp-- = TOS;
226: TOS = *(Cell *)PFA1(cfa);
227: #else
228: *--sp = *(Cell *)PFA1(cfa);
229: #endif
230: NEXT;
231:
232: dovar:
233: #ifdef DEBUG
234: fprintf(stderr,"%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
235: #endif
236: #ifdef USE_TOS
237: *sp-- = TOS;
238: TOS = (Cell)PFA1(cfa);
239: #else
240: *--sp = (Cell)PFA1(cfa);
241: #endif
242: NEXT;
243:
244: /* !! user? */
245:
246: douser:
247: #ifdef DEBUG
248: fprintf(stderr,"%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
249: #endif
250: #ifdef USE_TOS
251: *sp-- = TOS;
252: TOS = (Cell)(up+*(Cell*)PFA1(cfa));
253: #else
254: *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
255: #endif
256: NEXT;
257:
258: dodefer:
259: #ifdef DEBUG
260: fprintf(stderr,"%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
261: #endif
262: cfa = *(Xt *)PFA1(cfa);
263: NEXT1;
264:
265: dodoes:
266: /* this assumes the following structure:
267: defining-word:
268:
269: ...
270: DOES>
271: (possible padding)
272: possibly handler: jmp dodoes
273: (possible branch delay slot(s))
274: Forth code after DOES>
275:
276: defined word:
277:
278: cfa: address of or jump to handler OR
279: address of or jump to dodoes, address of DOES-code
280: pfa:
281:
282: */
283: #ifdef DEBUG
284: fprintf(stderr,"%08x/%08x: does: %08x\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
285: fflush(stderr);
286: #endif
287: *--rp = (Cell)ip;
288: /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
289: ip = DOES_CODE1(cfa);
290: #ifdef USE_TOS
291: *sp-- = TOS;
292: TOS = (Cell)PFA(cfa);
293: #else
294: *--sp = (Cell)PFA(cfa);
295: #endif
296: NEXT;
297:
298: #include "primitives.i"
299: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to engine.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth