--- gforth/engine/engine.c 2001/12/01 20:33:14 1.32
+++ gforth/engine/engine.c 2003/08/15 14:07:04 1.64
@@ -1,6 +1,6 @@
/* Gforth virtual machine (aka inner interpreter)
- Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
+ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
This file is part of Gforth.
@@ -59,37 +59,24 @@
#include
#endif
+#ifdef HAS_FFCALL
+#include
+#include
+#endif
+
#ifndef SEEK_SET
/* should be defined in stdio.h, but some systems don't have it */
#define SEEK_SET 0
#endif
-#define IOR(flag) ((flag)? -512-errno : 0)
+#ifndef HAVE_FSEEKO
+#define fseeko fseek
+#endif
-struct F83Name {
- struct F83Name *next; /* the link field for old hands */
- char countetc;
- char name[0];
-};
-
-#define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
-
-struct Longname {
- struct Longname *next; /* the link field for old hands */
- Cell countetc;
- char name[0];
-};
-
-#define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<3)>>3))
-
-Cell *SP;
-Float *FP;
-Address UP=NULL;
-
-#if 0
-/* not used currently */
-int emitcounter;
+#ifndef HAVE_FTELLO
+#define ftello ftell
#endif
+
#define NULLC '\0'
#ifdef MEMCMP_AS_SUBROUTINE
@@ -97,155 +84,49 @@ extern int gforth_memcmp(const char * s1
#define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
#endif
-#ifdef HAS_FILE
-char *cstr(Char *from, UCell size, int clear)
-/* return a C-string corresponding to the Forth string ( FROM SIZE ).
- the C-string lives until the next call of cstr with CLEAR being true */
-{
- static struct cstr_buffer {
- char *buffer;
- size_t size;
- } *buffers=NULL;
- static int nbuffers=0;
- static int used=0;
- struct cstr_buffer *b;
-
- if (buffers==NULL)
- buffers=malloc(0);
- if (clear)
- used=0;
- if (used>=nbuffers) {
- buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
- buffers[used]=(struct cstr_buffer){malloc(0),0};
- nbuffers=used+1;
- }
- b=&buffers[used];
- if (size+1 > b->size) {
- b->buffer = realloc(b->buffer,size+1);
- b->size = size+1;
- }
- memcpy(b->buffer,from,size);
- b->buffer[size]='\0';
- used++;
- return b->buffer;
-}
-
-char *tilde_cstr(Char *from, UCell size, int clear)
-/* like cstr(), but perform tilde expansion on the string */
-{
- char *s1,*s2;
- int s1_len, s2_len;
- struct passwd *getpwnam (), *user_entry;
-
- if (size<1 || from[0]!='~')
- return cstr(from, size, clear);
- if (size<2 || from[1]=='/') {
- s1 = (char *)getenv ("HOME");
- if(s1 == NULL)
- s1 = "";
- s2 = from+1;
- s2_len = size-1;
- } else {
- UCell i;
- for (i=1; ipw_dir;
- s2 = from+i;
- s2_len = size-i;
- }
- s1_len = strlen(s1);
- if (s1_len>1 && s1[s1_len-1]=='/')
- s1_len--;
- {
- char path[s1_len+s2_len];
- memcpy(path,s1,s1_len);
- memcpy(path+s1_len,s2,s2_len);
- return cstr(path,s1_len+s2_len,clear);
- }
-}
-#endif
-
-DCell timeval2us(struct timeval *tvp)
-{
-#ifndef BUGGY_LONG_LONG
- return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
-#else
- DCell d2;
- DCell d1=mmul(tvp->tv_sec,1000000);
- d2.lo = d1.lo+tvp->tv_usec;
- d2.hi = d1.hi + (d2.lo i) break; \
+ } len = 0; \
+ name -= sizeof(Cell); \
+ }
#endif
-Xt *primtable(Label symbols[], Cell size)
-{
-#ifdef DIRECT_THREADED
- return symbols;
-#else /* !defined(DIRECT_THREADED) */
- Xt *xts = (Xt *)malloc(size*sizeof(Xt));
- Cell i;
-
- for (i=0; i=MAX_SYMBOLS) {
- fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
+ fprintf(stderr,"gforth-ditc: more than %ld primitives\n",(long)MAX_SYMBOLS);
exit(1);
}
- symbols[i] = &routines[i];
+ xts[i] = symbols[i] = &routines[i];
}
#endif /* defined(DOUBLY_INDIRECT) */
return symbols;
@@ -400,10 +320,13 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
IF_spTOS(spTOS = sp[0]);
IF_fpTOS(fpTOS = fp[0]);
/* prep_terminal(); */
+#ifdef NO_IP
+ goto *(*(Label *)ip0);
+#else
SET_IP(ip);
SUPER_END; /* count the first block, too */
NEXT;
-
+#endif
#ifdef CPU_DEP3
CPU_DEP3
@@ -411,9 +334,16 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
docol:
{
- DOCFA;
+#ifdef NO_IP
+ *--rp = next_code;
+ goto **(Label *)PFA1(cfa);
+#else
#ifdef DEBUG
- fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
+ {
+ CFA_TO_NAME(cfa);
+ fprintf(stderr,"%08lx: col: %08lx %.*s\n",(Cell)ip,(Cell)PFA1(cfa),
+ len,name);
+ }
#endif
#ifdef CISC_NEXT
/* this is the simple version */
@@ -433,11 +363,11 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
NEXT_P2;
}
#endif
+#endif
}
docon:
{
- DOCFA;
#ifdef DEBUG
fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
#endif
@@ -448,12 +378,15 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
*--sp = *(Cell *)PFA1(cfa);
#endif
}
+#ifdef NO_IP
+ goto *next_code;
+#else
NEXT_P0;
NEXT;
+#endif
dovar:
{
- DOCFA;
#ifdef DEBUG
fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
@@ -464,12 +397,15 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
*--sp = (Cell)PFA1(cfa);
#endif
}
+#ifdef NO_IP
+ goto *next_code;
+#else
NEXT_P0;
NEXT;
+#endif
douser:
{
- DOCFA;
#ifdef DEBUG
fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
@@ -480,12 +416,15 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
*--sp = (Cell)(up+*(Cell*)PFA1(cfa));
#endif
}
+#ifdef NO_IP
+ goto *next_code;
+#else
NEXT_P0;
NEXT;
+#endif
dodefer:
{
- DOCFA;
#ifdef DEBUG
fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
#endif
@@ -495,14 +434,17 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
dofield:
{
- DOCFA;
#ifdef DEBUG
fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
spTOS += *(Cell*)PFA1(cfa);
}
+#ifdef NO_IP
+ goto *next_code;
+#else
NEXT_P0;
NEXT;
+#endif
dodoes:
/* this assumes the following structure:
@@ -522,9 +464,14 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
pfa:
*/
+#ifdef NO_IP
+ *--rp = next_code;
+ IF_spTOS(spTOS = sp[0]);
+ sp--;
+ spTOS = (Cell)PFA(cfa);
+ goto **(Label *)DOES_CODE1(cfa);
+#else
{
- DOCFA;
-
/* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
#ifdef DEBUG
fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
@@ -543,6 +490,9 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
/* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
}
NEXT;
+#endif
#include "prim.i"
+ after_last: return (Label *)0;
+ /*needed only to get the length of the last primitive */
}