1: /* Gforth virtual machine (aka inner interpreter)
2:
3: Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
4:
5: This file is part of Gforth.
6:
7: Gforth is free software; you can redistribute it and/or
8: modify it under the terms of the GNU General Public License
9: as published by the Free Software Foundation; either version 2
10: of the License, or (at your option) any later version.
11:
12: This program is distributed in the hope that it will be useful,
13: but WITHOUT ANY WARRANTY; without even the implied warranty of
14: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: GNU General Public License for more details.
16:
17: You should have received a copy of the GNU General Public License
18: along with this program; if not, write to the Free Software
19: Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20: */
21:
22: #include "config.h"
23: #include <ctype.h>
24: #include <stdio.h>
25: #include <string.h>
26: #include <math.h>
27: #include <assert.h>
28: #include <stdlib.h>
29: #include <errno.h>
30: #include "forth.h"
31: #include "io.h"
32: #include "threaded.h"
33: #ifndef STANDALONE
34: #include <sys/types.h>
35: #include <sys/stat.h>
36: #include <fcntl.h>
37: #include <time.h>
38: #include <sys/time.h>
39: #include <unistd.h>
40: #include <pwd.h>
41: #include <dirent.h>
42: #else
43: #include "systypes.h"
44: #endif
45:
46: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
47: #include <dlfcn.h>
48: #endif
49: #if defined(_WIN32)
50: #include <windows.h>
51: #endif
52: #ifdef hpux
53: #include <dl.h>
54: #endif
55:
56: #ifndef SEEK_SET
57: /* should be defined in stdio.h, but some systems don't have it */
58: #define SEEK_SET 0
59: #endif
60:
61: #define IOR(flag) ((flag)? -512-errno : 0)
62:
63: struct F83Name {
64: struct F83Name *next; /* the link field for old hands */
65: char countetc;
66: char name[0];
67: };
68:
69: /* are macros for setting necessary? */
70: #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
71: #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
72: #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
73:
74: Cell *SP;
75: Float *FP;
76: Address UP=NULL;
77:
78: #if 0
79: /* not used currently */
80: int emitcounter;
81: #endif
82: #define NULLC '\0'
83:
84: #ifdef MEMCMP_AS_SUBROUTINE
85: extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
86: #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
87: #endif
88:
89: #ifdef HAS_FILE
90: char *cstr(Char *from, UCell size, int clear)
91: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
92: the C-string lives until the next call of cstr with CLEAR being true */
93: {
94: static struct cstr_buffer {
95: char *buffer;
96: size_t size;
97: } *buffers=NULL;
98: static int nbuffers=0;
99: static int used=0;
100: struct cstr_buffer *b;
101:
102: if (buffers==NULL)
103: buffers=malloc(0);
104: if (clear)
105: used=0;
106: if (used>=nbuffers) {
107: buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
108: buffers[used]=(struct cstr_buffer){malloc(0),0};
109: nbuffers=used+1;
110: }
111: b=&buffers[used];
112: if (size+1 > b->size) {
113: b->buffer = realloc(b->buffer,size+1);
114: b->size = size+1;
115: }
116: memcpy(b->buffer,from,size);
117: b->buffer[size]='\0';
118: used++;
119: return b->buffer;
120: }
121:
122: char *tilde_cstr(Char *from, UCell size, int clear)
123: /* like cstr(), but perform tilde expansion on the string */
124: {
125: char *s1,*s2;
126: int s1_len, s2_len;
127: struct passwd *getpwnam (), *user_entry;
128:
129: if (size<1 || from[0]!='~')
130: return cstr(from, size, clear);
131: if (size<2 || from[1]=='/') {
132: s1 = (char *)getenv ("HOME");
133: if(s1 == NULL)
134: s1 = "";
135: s2 = from+1;
136: s2_len = size-1;
137: } else {
138: UCell i;
139: for (i=1; i<size && from[i]!='/'; i++)
140: ;
141: if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
142: return cstr(from+3, size<3?0:size-3,clear);
143: {
144: char user[i];
145: memcpy(user,from+1,i-1);
146: user[i-1]='\0';
147: user_entry=getpwnam(user);
148: }
149: if (user_entry==NULL)
150: return cstr(from, size, clear);
151: s1 = user_entry->pw_dir;
152: s2 = from+i;
153: s2_len = size-i;
154: }
155: s1_len = strlen(s1);
156: if (s1_len>1 && s1[s1_len-1]=='/')
157: s1_len--;
158: {
159: char path[s1_len+s2_len];
160: memcpy(path,s1,s1_len);
161: memcpy(path+s1_len,s2,s2_len);
162: return cstr(path,s1_len+s2_len,clear);
163: }
164: }
165: #endif
166:
167: #define NEWLINE '\n'
168:
169: #ifndef HAVE_RINT
170: #define rint(x) floor((x)+0.5)
171: #endif
172:
173: #ifdef HAS_FILE
174: static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
175:
176: #ifndef O_BINARY
177: #define O_BINARY 0
178: #endif
179: #ifndef O_TEXT
180: #define O_TEXT 0
181: #endif
182:
183: static int ufileattr[6]= {
184: O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
185: O_RDWR |O_BINARY, O_RDWR |O_BINARY,
186: O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
187: #endif
188:
189: /* if machine.h has not defined explicit registers, define them as implicit */
190: #ifndef IPREG
191: #define IPREG
192: #endif
193: #ifndef SPREG
194: #define SPREG
195: #endif
196: #ifndef RPREG
197: #define RPREG
198: #endif
199: #ifndef FPREG
200: #define FPREG
201: #endif
202: #ifndef LPREG
203: #define LPREG
204: #endif
205: #ifndef CFAREG
206: #define CFAREG
207: #endif
208: #ifndef UPREG
209: #define UPREG
210: #endif
211: #ifndef TOSREG
212: #define TOSREG
213: #endif
214: #ifndef FTOSREG
215: #define FTOSREG
216: #endif
217:
218: #ifndef CPU_DEP1
219: # define CPU_DEP1 0
220: #endif
221:
222: /* declare and compute cfa for certain threading variants */
223: /* warning: this is nonsyntactical; it will not work in place of a statement */
224: #ifndef GETCFA
225: #define DOCFA
226: #else
227: #define DOCFA Xt cfa; GETCFA(cfa)
228: #endif
229:
230: #ifdef GFORTH_DEBUGGING
231: /* define some VM registers as global variables, so they survive exceptions;
232: global register variables are not up to the task (according to the
233: GNU C manual) */
234: Xt *ip;
235: Cell *rp;
236: #endif
237:
238: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
239: /* executes code at ip, if ip!=NULL
240: returns array of machine code labels (for use in a loader), if ip==NULL
241: */
242: {
243: #ifndef GFORTH_DEBUGGING
244: register Xt *ip IPREG;
245: register Cell *rp RPREG;
246: #endif
247: register Cell *sp SPREG = sp0;
248: register Float *fp FPREG = fp0;
249: register Address lp LPREG = lp0;
250: #ifdef CFA_NEXT
251: register Xt cfa CFAREG;
252: #endif
253: #ifdef MORE_VARS
254: MORE_VARS
255: #endif
256: register Address up UPREG = UP;
257: IF_TOS(register Cell TOS TOSREG;)
258: IF_FTOS(register Float FTOS FTOSREG;)
259: #if defined(DOUBLY_INDIRECT)
260: static Label *symbols;
261: static void *routines[]= {
262: #else /* !defined(DOUBLY_INDIRECT) */
263: static Label symbols[]= {
264: #endif /* !defined(DOUBLY_INDIRECT) */
265: (Label)&&docol,
266: (Label)&&docon,
267: (Label)&&dovar,
268: (Label)&&douser,
269: (Label)&&dodefer,
270: (Label)&&dofield,
271: (Label)&&dodoes,
272: /* the following entry is normally unused;
273: it's there because its index indicates a does-handler */
274: CPU_DEP1,
275: #include "prim_lab.i"
276: (Label)0
277: };
278: #ifdef CPU_DEP2
279: CPU_DEP2
280: #endif
281:
282: ip = ip0;
283: rp = rp0;
284: #ifdef DEBUG
285: fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
286: (unsigned)ip,(unsigned)sp,(unsigned)rp,
287: (unsigned)fp,(unsigned)lp,(unsigned)up);
288: #endif
289:
290: if (ip == NULL) {
291: #if defined(DOUBLY_INDIRECT)
292: #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
293: #define CODE_OFFSET (22*sizeof(Cell))
294: int i;
295: Cell code_offset = offset_image? CODE_OFFSET : 0;
296:
297: symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
298: for (i=0; i<DOESJUMP+1; i++)
299: symbols[i] = (Label)routines[i];
300: for (; routines[i]!=0; i++) {
301: if (i>=MAX_SYMBOLS) {
302: fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
303: exit(1);
304: }
305: symbols[i] = &routines[i];
306: }
307: #endif /* defined(DOUBLY_INDIRECT) */
308: return symbols;
309: }
310:
311: IF_TOS(TOS = sp[0]);
312: IF_FTOS(FTOS = fp[0]);
313: /* prep_terminal(); */
314: SET_IP(ip);
315: NEXT;
316:
317:
318: #ifdef CPU_DEP3
319: CPU_DEP3
320: #endif
321:
322: docol:
323: {
324: DOCFA;
325: #ifdef DEBUG
326: fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
327: #endif
328: #ifdef CISC_NEXT
329: /* this is the simple version */
330: *--rp = (Cell)ip;
331: SET_IP((Xt *)PFA1(cfa));
332: NEXT;
333: #else
334: /* this one is important, so we help the compiler optimizing */
335: {
336: DEF_CA
337: rp[-1] = (Cell)ip;
338: SET_IP((Xt *)PFA1(cfa));
339: NEXT_P1;
340: rp--;
341: NEXT_P2;
342: }
343: #endif
344: }
345:
346: docon:
347: {
348: DOCFA;
349: #ifdef DEBUG
350: fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
351: #endif
352: #ifdef USE_TOS
353: *sp-- = TOS;
354: TOS = *(Cell *)PFA1(cfa);
355: #else
356: *--sp = *(Cell *)PFA1(cfa);
357: #endif
358: }
359: NEXT_P0;
360: NEXT;
361:
362: dovar:
363: {
364: DOCFA;
365: #ifdef DEBUG
366: fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
367: #endif
368: #ifdef USE_TOS
369: *sp-- = TOS;
370: TOS = (Cell)PFA1(cfa);
371: #else
372: *--sp = (Cell)PFA1(cfa);
373: #endif
374: }
375: NEXT_P0;
376: NEXT;
377:
378: douser:
379: {
380: DOCFA;
381: #ifdef DEBUG
382: fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
383: #endif
384: #ifdef USE_TOS
385: *sp-- = TOS;
386: TOS = (Cell)(up+*(Cell*)PFA1(cfa));
387: #else
388: *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
389: #endif
390: }
391: NEXT_P0;
392: NEXT;
393:
394: dodefer:
395: {
396: DOCFA;
397: #ifdef DEBUG
398: fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
399: #endif
400: EXEC(*(Xt *)PFA1(cfa));
401: }
402:
403: dofield:
404: {
405: DOCFA;
406: #ifdef DEBUG
407: fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
408: #endif
409: TOS += *(Cell*)PFA1(cfa);
410: }
411: NEXT_P0;
412: NEXT;
413:
414: dodoes:
415: /* this assumes the following structure:
416: defining-word:
417:
418: ...
419: DOES>
420: (possible padding)
421: possibly handler: jmp dodoes
422: (possible branch delay slot(s))
423: Forth code after DOES>
424:
425: defined word:
426:
427: cfa: address of or jump to handler OR
428: address of or jump to dodoes, address of DOES-code
429: pfa:
430:
431: */
432: {
433: DOCFA;
434:
435: /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
436: #ifdef DEBUG
437: fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
438: fflush(stderr);
439: #endif
440: *--rp = (Cell)ip;
441: /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
442: #ifdef USE_TOS
443: *sp-- = TOS;
444: TOS = (Cell)PFA(cfa);
445: #else
446: *--sp = (Cell)PFA(cfa);
447: #endif
448: SET_IP(DOES_CODE1(cfa));
449: /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
450: }
451: NEXT;
452:
453: #include "prim.i"
454: }
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 / engine