--- gforth/engine/engine.c 2001/12/09 19:12:46 1.33
+++ gforth/engine/engine.c 2003/08/22 08:08:46 1.66
@@ -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
+
+#ifdef HAS_FFCALL
+#define SAVE_REGS IF_spTOS(sp[0]=spTOS); IF_fpTOS(fp[0]=fpTOS); SP=sp; FP=fp; RP=rp; LP=lp;
+#define REST_REGS sp=SP; fp=FP; rp=RP; lp=LP; IF_spTOS(spTOS=sp[0]); IF_fpTOS(fpTOS=fp[0]);
+#endif
+
+#if !defined(ENGINE)
+/* normal engine */
+#define VARIANT(v) (v)
+#define JUMP(target) goto I_noop
+#define LABEL(name) J_##name: asm(""); I_##name:
+
+#elif ENGINE==2
+/* variant with padding between VM instructions for finding out
+ cross-inst jumps (for dynamic code) */
+#define engine engine2
+#define VARIANT(v) (v)
+#define JUMP(target) goto I_noop
+#define LABEL(name) J_##name: SKIP16; I_##name:
+#define IN_ENGINE2
+
+#elif ENGINE==3
+/* variant with different immediate arguments for finding out
+ immediate arguments (for native code) */
+#define engine engine3
+#define VARIANT(v) ((v)^0xffffffff)
+#define JUMP(target) goto K_lit
+#define LABEL(name) J_##name: asm(""); I_##name:
+#else
+#error illegal ENGINE value
+#endif /* ENGINE */
+
+#define LABEL2(name) K_##name:
Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
/* executes code at ip, if ip!=NULL
@@ -329,18 +241,27 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
*/
{
#ifndef GFORTH_DEBUGGING
- register Xt *ip IPREG;
register Cell *rp RPREG;
#endif
+#ifndef NO_IP
+ register Xt *ip IPREG = ip0;
+#endif
register Cell *sp SPREG = sp0;
register Float *fp FPREG = fp0;
register Address lp LPREG = lp0;
-#ifdef CFA_NEXT
register Xt cfa CFAREG;
-#endif
#ifdef MORE_VARS
MORE_VARS
#endif
+#ifdef HAS_FFCALL
+ av_alist alist;
+ extern va_alist clist;
+ float frv;
+ int irv;
+ double drv;
+ long long llrv;
+ void * prv;
+#endif
register Address up UPREG = UP;
IF_spTOS(register Cell spTOS TOSREG;)
IF_fpTOS(register Float fpTOS FTOSREG;)
@@ -352,46 +273,47 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
static Label symbols[]= {
#define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
#endif /* !defined(DOUBLY_INDIRECT) */
- (Label)&&docol,
- (Label)&&docon,
- (Label)&&dovar,
- (Label)&&douser,
- (Label)&&dodefer,
- (Label)&&dofield,
- (Label)&&dodoes,
- /* the following entry is normally unused;
- it's there because its index indicates a does-handler */
- CPU_DEP1,
+#define INST_ADDR(name) ((Label)&&I_##name)
#include "prim_lab.i"
- (Label)0
+#undef INST_ADDR
+ (Label)0,
+#define INST_ADDR(name) ((Label)&&K_##name)
+#include "prim_lab.i"
+#undef INST_ADDR
+#define INST_ADDR(name) ((Label)&&J_##name)
+#include "prim_lab.i"
+#undef INST_ADDR
+ (Label)&&after_last
};
#ifdef CPU_DEP2
CPU_DEP2
#endif
- ip = ip0;
rp = rp0;
#ifdef DEBUG
fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
- (unsigned)ip,(unsigned)sp,(unsigned)rp,
+ (unsigned)ip0,(unsigned)sp,(unsigned)rp,
(unsigned)fp,(unsigned)lp,(unsigned)up);
#endif
- if (ip == NULL) {
+ if (ip0 == NULL) {
#if defined(DOUBLY_INDIRECT)
-#define CODE_OFFSET (22*sizeof(Cell))
+#define CODE_OFFSET (26*sizeof(Cell))
+#define XT_OFFSET (22*sizeof(Cell))
int i;
Cell code_offset = offset_image? CODE_OFFSET : 0;
+ Cell xt_offset = offset_image? XT_OFFSET : 0;
symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
+ xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
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,150 +322,19 @@ 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
#endif
-
- docol:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
-#ifdef CISC_NEXT
- /* this is the simple version */
- *--rp = (Cell)ip;
- SET_IP((Xt *)PFA1(cfa));
- SUPER_END;
- NEXT;
-#else
- /* this one is important, so we help the compiler optimizing */
- {
- DEF_CA
- rp[-1] = (Cell)ip;
- SET_IP((Xt *)PFA1(cfa));
- SUPER_END;
- NEXT_P1;
- rp--;
- NEXT_P2;
- }
-#endif
- }
-
- docon:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = *(Cell *)PFA1(cfa);
-#else
- *--sp = *(Cell *)PFA1(cfa);
-#endif
- }
- NEXT_P0;
- NEXT;
-
- dovar:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)PFA1(cfa);
-#else
- *--sp = (Cell)PFA1(cfa);
-#endif
- }
- NEXT_P0;
- NEXT;
-
- douser:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)(up+*(Cell*)PFA1(cfa));
-#else
- *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
-#endif
- }
- NEXT_P0;
- NEXT;
-
- dodefer:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
-#endif
- SUPER_END;
- EXEC(*(Xt *)PFA1(cfa));
- }
-
- dofield:
- {
- DOCFA;
-#ifdef DEBUG
- fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
-#endif
- spTOS += *(Cell*)PFA1(cfa);
- }
- NEXT_P0;
- NEXT;
-
- dodoes:
- /* this assumes the following structure:
- defining-word:
-
- ...
- DOES>
- (possible padding)
- possibly handler: jmp dodoes
- (possible branch delay slot(s))
- Forth code after DOES>
-
- defined word:
-
- cfa: address of or jump to handler OR
- address of or jump to dodoes, address of DOES-code
- pfa:
-
- */
- {
- 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));
- fflush(stderr);
-#endif
- *--rp = (Cell)ip;
- /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
-#ifdef USE_TOS
- *sp-- = spTOS;
- spTOS = (Cell)PFA(cfa);
-#else
- *--sp = (Cell)PFA(cfa);
-#endif
- SET_IP(DOES_CODE1(cfa));
- SUPER_END;
- /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
- }
- NEXT;
-#define LABEL(name) I_##name
#include "prim.i"
+ after_last: return (Label *)0;
+ /*needed only to get the length of the last primitive */
}