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