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