Annotation of gforth/engine.c, revision 1.30
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.25 anton 17: #include <errno.h>
1.27 anton 18: #include <pwd.h>
1.1 anton 19: #include "forth.h"
20: #include "io.h"
1.30 ! pazsan 21: #include "threading.h"
1.1 anton 22:
1.20 anton 23: #ifndef SEEK_SET
24: /* should be defined in stdio.h, but some systems don't have it */
25: #define SEEK_SET 0
26: #endif
27:
1.25 anton 28: #define IOR(flag) ((flag)? -512-errno : 0)
29:
1.1 anton 30: typedef union {
31: struct {
1.20 anton 32: #ifdef WORDS_BIGENDIAN
1.1 anton 33: Cell high;
34: Cell low;
35: #else
36: Cell low;
37: Cell high;
38: #endif;
39: } cells;
40: DCell dcell;
41: } Double_Store;
42:
43: typedef struct F83Name {
44: struct F83Name *next; /* the link field for old hands */
45: char countetc;
46: Char name[0];
47: } F83Name;
48:
49: /* are macros for setting necessary? */
50: #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
51: #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
52: #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
53:
54: #ifdef USE_TOS
55: #define IF_TOS(x) x
56: #else
57: #define IF_TOS(x)
58: #define TOS (sp[0])
59: #endif
60:
61: #ifdef USE_FTOS
62: #define IF_FTOS(x) x
63: #else
64: #define IF_FTOS(x)
65: #define FTOS (fp[0])
66: #endif
67:
1.25 anton 68: Cell *SP;
69: Float *FP;
1.1 anton 70: int emitcounter;
71: #define NULLC '\0'
72:
1.14 anton 73: char *cstr(Char *from, UCell size, int clear)
74: /* if clear is true, scratch can be reused, otherwise we want more of
75: the same */
76: {
77: static char *scratch=NULL;
78: static unsigned scratchsize=0;
79: static char *nextscratch;
80: char *oldnextscratch;
81:
82: if (clear)
83: nextscratch=scratch;
84: if (scratch==NULL) {
85: scratch=malloc(size+1);
86: nextscratch=scratch;
87: scratchsize=size;
88: }
89: else if (nextscratch+size>scratch+scratchsize) {
90: char *oldscratch=scratch;
91: scratch = realloc(scratch, (nextscratch-scratch)+size+1);
92: nextscratch=scratch+(nextscratch-oldscratch);
93: scratchsize=size;
94: }
95: memcpy(nextscratch,from,size);
96: nextscratch[size]='\0';
97: oldnextscratch = nextscratch;
98: nextscratch += size+1;
99: return oldnextscratch;
100: }
1.27 anton 101:
102: char *tilde_cstr(Char *from, UCell size, int clear)
103: /* like cstr(), but perform tilde expansion on the string */
104: {
105: char *s1,*s2;
106: int s1_len, s2_len;
107: struct passwd *getpwnam (), *user_entry;
108:
109: if (size<1 || from[0]!='~')
110: return cstr(from, size, clear);
111: if (size<2 || from[1]=='/') {
112: s1 = (char *)getenv ("HOME");
113: s2 = from+1;
114: s2_len = size-1;
115: } else {
116: int i;
117: for (i=1; i<size && from[i]!='/'; i++)
118: ;
119: {
120: char user[i];
121: memcpy(user,from+1,i-1);
122: user[i-1]='\0';
123: user_entry=getpwnam(user);
124: }
125: if (user_entry==NULL)
126: return cstr(from, size, clear);
127: s1 = user_entry->pw_dir;
128: s2 = from+i;
129: s2_len = size-i;
130: }
131: s1_len = strlen(s1);
132: if (s1_len>1 && s1[s1_len-1]=='/')
133: s1_len--;
134: {
135: char path[s1_len+s2_len];
136: memcpy(path,s1,s1_len);
137: memcpy(path+s1_len,s2,s2_len);
138: return cstr(path,s1_len+s2_len,clear);
139: }
140: }
141:
1.13 pazsan 142:
1.1 anton 143: #define NEWLINE '\n'
144:
1.21 pazsan 145: #ifndef HAVE_RINT
146: #define rint(x) floor((x)+0.5)
147: #endif
1.13 pazsan 148:
1.26 anton 149: static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
1.6 pazsan 150:
1.11 pazsan 151: static Address up0=NULL;
152:
1.15 anton 153: /* if machine.h has not defined explicit registers, define them as implicit */
154: #ifndef IPREG
155: #define IPREG
156: #endif
157: #ifndef SPREG
158: #define SPREG
159: #endif
160: #ifndef RPREG
161: #define RPREG
162: #endif
163: #ifndef FPREG
164: #define FPREG
165: #endif
166: #ifndef LPREG
167: #define LPREG
168: #endif
169: #ifndef CFAREG
170: #define CFAREG
171: #endif
172: #ifndef UPREG
173: #define UPREG
174: #endif
175: #ifndef TOSREG
176: #define TOSREG
177: #endif
178: #ifndef FTOSREG
179: #define FTOSREG
180: #endif
1.13 pazsan 181:
1.15 anton 182: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
1.1 anton 183: /* executes code at ip, if ip!=NULL
184: returns array of machine code labels (for use in a loader), if ip==NULL
185: */
1.15 anton 186: {
187: register Xt *ip IPREG = ip0;
188: register Cell *sp SPREG = sp0;
189: register Cell *rp RPREG = rp0;
190: register Float *fp FPREG = fp0;
191: register Address lp LPREG = lp0;
1.30 ! pazsan 192: #ifdef CFA_NEXT
1.15 anton 193: register Xt cfa CFAREG;
1.30 ! pazsan 194: #endif
1.15 anton 195: register Address up UPREG = up0;
196: IF_TOS(register Cell TOS TOSREG;)
197: IF_FTOS(register Float FTOS FTOSREG;)
1.1 anton 198: static Label symbols[]= {
199: &&docol,
200: &&docon,
201: &&dovar,
1.4 pazsan 202: &&douser,
1.12 anton 203: &&dodefer,
1.29 anton 204: &&dofield,
1.1 anton 205: &&dodoes,
1.6 pazsan 206: &&dodoes, /* dummy for does handler address */
1.1 anton 207: #include "prim_labels.i"
208: };
209: #ifdef CPU_DEP
210: CPU_DEP;
211: #endif
212:
1.16 pazsan 213: #ifdef DEBUG
214: fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
1.19 anton 215: (unsigned)ip,(unsigned)sp,(unsigned)rp,
216: (unsigned)fp,(unsigned)lp,(unsigned)up);
1.16 pazsan 217: #endif
218:
1.1 anton 219: if (ip == NULL)
220: return symbols;
1.10 anton 221:
1.1 anton 222: IF_TOS(TOS = sp[0]);
223: IF_FTOS(FTOS = fp[0]);
1.28 pazsan 224: /* prep_terminal(); */
1.23 anton 225: NEXT_P0;
1.1 anton 226: NEXT;
227:
228: docol:
1.30 ! pazsan 229: #ifndef CFA_NEXT
! 230: {
! 231: Xt cfa; GETCFA(cfa);
! 232: #endif
1.1 anton 233: #ifdef DEBUG
1.30 ! pazsan 234: fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
1.1 anton 235: #endif
1.15 anton 236: #ifdef CISC_NEXT
1.1 anton 237: /* this is the simple version */
238: *--rp = (Cell)ip;
239: ip = (Xt *)PFA1(cfa);
1.23 anton 240: NEXT_P0;
1.1 anton 241: NEXT;
1.15 anton 242: #else
1.1 anton 243: /* this one is important, so we help the compiler optimizing
244: The following version may be better (for scheduling), but probably has
245: problems with code fields employing calls and delay slots
246: */
247: {
1.4 pazsan 248: DEF_CA
1.1 anton 249: Xt *current_ip = (Xt *)PFA1(cfa);
250: cfa = *current_ip;
251: NEXT1_P1;
252: *--rp = (Cell)ip;
253: ip = current_ip+1;
1.3 pazsan 254: NEXT1_P2;
1.1 anton 255: }
1.15 anton 256: #endif
1.30 ! pazsan 257: #ifndef CFA_NEXT
! 258: }
! 259: #endif
1.23 anton 260:
1.1 anton 261: docon:
1.30 ! pazsan 262: #ifndef CFA_NEXT
! 263: {
! 264: Xt cfa; GETCFA(cfa);
! 265: #endif
1.1 anton 266: #ifdef DEBUG
1.30 ! pazsan 267: fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
1.1 anton 268: #endif
269: #ifdef USE_TOS
270: *sp-- = TOS;
271: TOS = *(Cell *)PFA1(cfa);
272: #else
273: *--sp = *(Cell *)PFA1(cfa);
274: #endif
1.30 ! pazsan 275: #ifndef CFA_NEXT
! 276: }
! 277: #endif
1.23 anton 278: NEXT_P0;
1.1 anton 279: NEXT;
280:
281: dovar:
1.30 ! pazsan 282: #ifndef CFA_NEXT
! 283: {
! 284: Xt cfa; GETCFA(cfa);
! 285: #endif
1.1 anton 286: #ifdef DEBUG
1.30 ! pazsan 287: fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
1.1 anton 288: #endif
289: #ifdef USE_TOS
290: *sp-- = TOS;
291: TOS = (Cell)PFA1(cfa);
292: #else
293: *--sp = (Cell)PFA1(cfa);
294: #endif
1.30 ! pazsan 295: #ifndef CFA_NEXT
! 296: }
! 297: #endif
1.23 anton 298: NEXT_P0;
1.1 anton 299: NEXT;
300:
1.4 pazsan 301: douser:
1.30 ! pazsan 302: #ifndef CFA_NEXT
! 303: {
! 304: Xt cfa; GETCFA(cfa);
! 305: #endif
1.4 pazsan 306: #ifdef DEBUG
1.30 ! pazsan 307: fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
1.4 pazsan 308: #endif
309: #ifdef USE_TOS
310: *sp-- = TOS;
1.5 anton 311: TOS = (Cell)(up+*(Cell*)PFA1(cfa));
1.4 pazsan 312: #else
1.5 anton 313: *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
1.4 pazsan 314: #endif
1.30 ! pazsan 315: #ifndef CFA_NEXT
! 316: }
! 317: #endif
1.23 anton 318: NEXT_P0;
1.4 pazsan 319: NEXT;
320:
1.12 anton 321: dodefer:
1.30 ! pazsan 322: #ifndef CFA_NEXT
! 323: {
! 324: Xt cfa; GETCFA(cfa);
! 325: #endif
1.12 anton 326: #ifdef DEBUG
1.30 ! pazsan 327: fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
! 328: #endif
! 329: EXEC(*(Xt *)PFA1(cfa));
! 330: #ifndef CFA_NEXT
! 331: }
1.12 anton 332: #endif
1.24 pazsan 333:
1.29 anton 334: dofield:
1.30 ! pazsan 335: #ifndef CFA_NEXT
! 336: {
! 337: Xt cfa; GETCFA(cfa);
! 338: #endif
1.24 pazsan 339: #ifdef DEBUG
1.30 ! pazsan 340: fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
1.24 pazsan 341: #endif
342: TOS += *(Cell*)PFA1(cfa);
1.30 ! pazsan 343: #ifndef CFA_NEXT
! 344: }
! 345: #endif
1.24 pazsan 346: NEXT_P0;
347: NEXT;
1.12 anton 348:
1.1 anton 349: dodoes:
350: /* this assumes the following structure:
351: defining-word:
352:
353: ...
354: DOES>
355: (possible padding)
356: possibly handler: jmp dodoes
357: (possible branch delay slot(s))
358: Forth code after DOES>
359:
360: defined word:
361:
362: cfa: address of or jump to handler OR
363: address of or jump to dodoes, address of DOES-code
364: pfa:
365:
366: */
1.30 ! pazsan 367: #ifndef CFA_NEXT
! 368: {
! 369: Xt cfa; GETCFA(cfa);
! 370:
! 371: /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
! 372: #endif
1.1 anton 373: #ifdef DEBUG
1.30 ! pazsan 374: fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
1.16 pazsan 375: fflush(stderr);
1.1 anton 376: #endif
377: *--rp = (Cell)ip;
378: /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
1.13 pazsan 379: ip = DOES_CODE1(cfa);
1.1 anton 380: #ifdef USE_TOS
381: *sp-- = TOS;
382: TOS = (Cell)PFA(cfa);
383: #else
384: *--sp = (Cell)PFA(cfa);
1.30 ! pazsan 385: #endif
! 386: #ifndef CFA_NEXT
! 387: /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
! 388: }
1.1 anton 389: #endif
1.23 anton 390: NEXT_P0;
1.1 anton 391: NEXT;
1.16 pazsan 392:
1.1 anton 393: #include "primitives.i"
394: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>