Diff for /gforth/engine/engine.c between versions 1.2 and 1.23

version 1.2, 1998/03/21 21:37:50 version 1.23, 2000/09/23 15:47:07
Line 1 Line 1
 /* Gforth virtual machine (aka inner interpreter)  /* Gforth virtual machine (aka inner interpreter)
   
   Copyright (C) 1995 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 16 Line 16
   
   You should have received a copy of the GNU General Public License    You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software    along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 */  */
   
 #include "config.h"  #include "config.h"
Line 24 Line 24
 #include <stdio.h>  #include <stdio.h>
 #include <string.h>  #include <string.h>
 #include <math.h>  #include <math.h>
   #include <assert.h>
   #include <stdlib.h>
   #include <errno.h>
   #include "forth.h"
   #include "io.h"
   #include "threaded.h"
   #ifndef STANDALONE
 #include <sys/types.h>  #include <sys/types.h>
 #include <sys/stat.h>  #include <sys/stat.h>
 #include <fcntl.h>  #include <fcntl.h>
 #include <assert.h>  
 #include <stdlib.h>  
 #include <time.h>  #include <time.h>
 #include <sys/time.h>  #include <sys/time.h>
 #include <unistd.h>  #include <unistd.h>
 #include <errno.h>  
 #include <pwd.h>  #include <pwd.h>
 #include "forth.h"  #include <dirent.h>
 #include "io.h"  #include <sys/resource.h>
 #include "threaded.h"  #ifdef HAVE_FNMATCH_H
   #include <fnmatch.h>
   #else
   #include "fnmatch.h"
   #endif
   #else
   #include "systypes.h"
   #endif
   
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
 #include <dlfcn.h>  #include <dlfcn.h>
 #endif  #endif
   #if defined(_WIN32)
   #include <windows.h>
   #endif
 #ifdef hpux  #ifdef hpux
 #include <dl.h>  #include <dl.h>
 #endif  #endif
Line 52 Line 66
   
 #define IOR(flag)       ((flag)? -512-errno : 0)  #define IOR(flag)       ((flag)? -512-errno : 0)
   
 typedef struct F83Name {  struct F83Name {
   struct F83Name        *next;  /* the link field for old hands */    struct F83Name *next;  /* the link field for old hands */
   char                  countetc;    char          countetc;
   Char                  name[0];    char          name[0];
 } F83Name;  };
   
 /* are macros for setting necessary? */  /* are macros for setting necessary? */
 #define F83NAME_COUNT(np)       ((np)->countetc & 0x1f)  #define F83NAME_COUNT(np)       ((np)->countetc & 0x1f)
Line 73  int emitcounter; Line 87  int emitcounter;
 #endif  #endif
 #define NULLC '\0'  #define NULLC '\0'
   
   #ifdef MEMCMP_AS_SUBROUTINE
   extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
   #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
   #endif
   
   #ifdef HAS_FILE
 char *cstr(Char *from, UCell size, int clear)  char *cstr(Char *from, UCell size, int clear)
 /* return a C-string corresponding to the Forth string ( FROM SIZE ).  /* 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 */     the C-string lives until the next call of cstr with CLEAR being true */
Line 124  char *tilde_cstr(Char *from, UCell size, Line 144  char *tilde_cstr(Char *from, UCell size,
     UCell i;      UCell i;
     for (i=1; i<size && from[i]!='/'; i++)      for (i=1; i<size && from[i]!='/'; i++)
       ;        ;
       if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
         return cstr(from+3, size<3?0:size-3,clear);
     {      {
       char user[i];        char user[i];
       memcpy(user,from+1,i-1);        memcpy(user,from+1,i-1);
Line 146  char *tilde_cstr(Char *from, UCell size, Line 168  char *tilde_cstr(Char *from, UCell size,
     return cstr(path,s1_len+s2_len,clear);      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<d1.lo);
     return d2;
   #endif
   }
   
 #define NEWLINE '\n'  #define NEWLINE '\n'
   
Line 154  char *tilde_cstr(Char *from, UCell size, Line 189  char *tilde_cstr(Char *from, UCell size,
 #define rint(x) floor((x)+0.5)  #define rint(x) floor((x)+0.5)
 #endif  #endif
   
 static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};  #ifdef HAS_FILE
   static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
   
 #ifndef O_BINARY  #ifndef O_BINARY
 #define O_BINARY 0  #define O_BINARY 0
Line 164  static char* fileattr[6]={"r","rb","r+", Line 200  static char* fileattr[6]={"r","rb","r+",
 #endif  #endif
   
 static int ufileattr[6]= {  static int ufileattr[6]= {
   O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,    O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
   O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,    O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
   O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };    O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
   #endif
   
 /* if machine.h has not defined explicit registers, define them as implicit */  /* if machine.h has not defined explicit registers, define them as implicit */
 #ifndef IPREG  #ifndef IPREG
Line 203  static int ufileattr[6]= { Line 240  static int ufileattr[6]= {
   
 /* declare and compute cfa for certain threading variants */  /* declare and compute cfa for certain threading variants */
 /* warning: this is nonsyntactical; it will not work in place of a statement */  /* warning: this is nonsyntactical; it will not work in place of a statement */
 #ifdef CFA_NEXT  #ifndef GETCFA
 #define DOCFA  #define DOCFA
 #else  #else
 #define DOCFA   Xt cfa; GETCFA(cfa)  #define DOCFA   Xt cfa; GETCFA(cfa)
 #endif  #endif
   
   #ifdef GFORTH_DEBUGGING
   /* define some VM registers as global variables, so they survive exceptions;
      global register variables are not up to the task (according to the 
      GNU C manual) */
   Xt *ip;
   Cell *rp;
   #endif
   
 Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)  Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
 /* executes code at ip, if ip!=NULL  /* executes code at ip, if ip!=NULL
    returns array of machine code labels (for use in a loader), if ip==NULL     returns array of machine code labels (for use in a loader), if ip==NULL
 */  */
 {  {
   register Xt *ip IPREG = ip0;  #ifndef GFORTH_DEBUGGING
     register Xt *ip IPREG;
     register Cell *rp RPREG;
   #endif
   register Cell *sp SPREG = sp0;    register Cell *sp SPREG = sp0;
   register Cell *rp RPREG = rp0;  
   register Float *fp FPREG = fp0;    register Float *fp FPREG = fp0;
   register Address lp LPREG = lp0;    register Address lp LPREG = lp0;
 #ifdef CFA_NEXT  #ifdef CFA_NEXT
   register Xt cfa CFAREG;    register Xt cfa CFAREG;
 #endif  #endif
   #ifdef MORE_VARS
     MORE_VARS
   #endif
   register Address up UPREG = UP;    register Address up UPREG = UP;
   IF_TOS(register Cell TOS TOSREG;)    IF_TOS(register Cell TOS TOSREG;)
   IF_FTOS(register Float FTOS FTOSREG;)    IF_FTOS(register Float FTOS FTOSREG;)
Line 231  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 281  Label *engine(Xt *ip0, Cell *sp0, Cell *
 #else /* !defined(DOUBLY_INDIRECT) */  #else /* !defined(DOUBLY_INDIRECT) */
   static Label symbols[]= {    static Label symbols[]= {
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
     &&docol,      (Label)&&docol,
     &&docon,      (Label)&&docon,
     &&dovar,      (Label)&&dovar,
     &&douser,      (Label)&&douser,
     &&dodefer,      (Label)&&dodefer,
     &&dofield,      (Label)&&dofield,
     &&dodoes,      (Label)&&dodoes,
     /* the following entry is normally unused;      /* the following entry is normally unused;
        it's there because its index indicates a does-handler */         it's there because its index indicates a does-handler */
     CPU_DEP1,      CPU_DEP1,
 #include "prim_lab.i"  #include "prim_lab.i"
     0      (Label)0
   };    };
 #ifdef CPU_DEP2  #ifdef CPU_DEP2
   CPU_DEP2    CPU_DEP2
 #endif  #endif
   
     ip = ip0;
     rp = rp0;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",    fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
           (unsigned)ip,(unsigned)sp,(unsigned)rp,            (unsigned)ip,(unsigned)sp,(unsigned)rp,
Line 256  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 308  Label *engine(Xt *ip0, Cell *sp0, Cell *
   
   if (ip == NULL) {    if (ip == NULL) {
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
 #define MAX_SYMBOLS 1000  #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
   #define CODE_OFFSET (22*sizeof(Cell))
     int i;      int i;
     Cell code_offset = offset_image? 22*sizeof(Cell) : 0;      Cell code_offset = offset_image? CODE_OFFSET : 0;
   
     symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+code_offset)+code_offset);      symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
     for (i=0; i<DOESJUMP+1; i++)      for (i=0; i<DOESJUMP+1; i++)
       symbols[i] = (Label)routines[i];        symbols[i] = (Label)routines[i];
     for (; routines[i]!=0; i++) {      for (; routines[i]!=0; i++) {
       if (i>=MAX_SYMBOLS) {        if (i>=MAX_SYMBOLS) {
         fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);          fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
         exit(1);          exit(1);
         }
         symbols[i] = &routines[i];
     }      }
     symbols[i] = &routines[i];  
   }  
 #endif /* defined(DOUBLY_INDIRECT) */  #endif /* defined(DOUBLY_INDIRECT) */
   return symbols;      return symbols;
 }    }
   
   IF_TOS(TOS = sp[0]);    IF_TOS(TOS = sp[0]);
   IF_FTOS(FTOS = fp[0]);    IF_FTOS(FTOS = fp[0]);
 /*  prep_terminal(); */  /*  prep_terminal(); */
   NEXT_P0;    SET_IP(ip);
   NEXT;    NEXT;
   
   
 #ifdef CPU_DEP3  #ifdef CPU_DEP3
   CPU_DEP3    CPU_DEP3
 #endif  #endif
Line 293  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 347  Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef CISC_NEXT  #ifdef CISC_NEXT
     /* this is the simple version */      /* this is the simple version */
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     ip = (Xt *)PFA1(cfa);      SET_IP((Xt *)PFA1(cfa));
     NEXT_P0;  
     NEXT;      NEXT;
 #else  #else
     /* this one is important, so we help the compiler optimizing      /* this one is important, so we help the compiler optimizing */
        The following version may be better (for scheduling), but probably has  
        problems with code fields employing calls and delay slots  
        */  
     {      {
       DEF_CA        DEF_CA
       Xt *current_ip = (Xt *)PFA1(cfa);        rp[-1] = (Cell)ip;
       cfa = *current_ip;        SET_IP((Xt *)PFA1(cfa));
       NEXT1_P1;        NEXT_P1;
       *--rp = (Cell)ip;        rp--;
       ip = current_ip+1;        NEXT_P2;
       NEXT1_P2;  
     }      }
 #endif  #endif
   }    }
Line 376  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 425  Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef DEBUG  #ifdef DEBUG
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
     TOS += *(Cell*)PFA1(cfa);       TOS += *(Cell*)PFA1(cfa);
   }    }
   NEXT_P0;    NEXT_P0;
   NEXT;    NEXT;
Line 409  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 458  Label *engine(Xt *ip0, Cell *sp0, Cell *
 #endif  #endif
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */      /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
     ip = DOES_CODE1(cfa);  
 #ifdef USE_TOS  #ifdef USE_TOS
     *sp-- = TOS;      *sp-- = TOS;
     TOS = (Cell)PFA(cfa);      TOS = (Cell)PFA(cfa);
 #else  #else
     *--sp = (Cell)PFA(cfa);      *--sp = (Cell)PFA(cfa);
 #endif  #endif
       SET_IP(DOES_CODE1(cfa));
     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/      /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
   }    }
   NEXT_P0;  
   NEXT;    NEXT;
   
 #include "prim.i"  #include "prim.i"

Removed from v.1.2  
changed lines
  Added in v.1.23


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>