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