--- gforth/engine/engine.c	1999/01/08 16:58:31	1.10
+++ gforth/engine/engine.c	2001/02/27 21:17:11	1.28
@@ -1,6 +1,6 @@
 /* Gforth virtual machine (aka inner interpreter)
 
-  Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+  Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
 
   This file is part of Gforth.
 
@@ -16,7 +16,7 @@
 
   You should have received a copy of the GNU General Public License
   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"
@@ -38,6 +38,13 @@
 #include <sys/time.h>
 #include <unistd.h>
 #include <pwd.h>
+#include <dirent.h>
+#include <sys/resource.h>
+#ifdef HAVE_FNMATCH_H
+#include <fnmatch.h>
+#else
+#include "fnmatch.h"
+#endif
 #else
 #include "systypes.h"
 #endif
@@ -65,10 +72,15 @@ struct F83Name {
   char		name[0];
 };
 
-/* are macros for setting necessary? */
 #define F83NAME_COUNT(np)	((np)->countetc & 0x1f)
-#define F83NAME_SMUDGE(np)	(((np)->countetc & 0x40) != 0)
-#define F83NAME_IMMEDIATE(np)	(((np)->countetc & 0x20) != 0)
+
+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;
@@ -80,6 +92,11 @@ int emitcounter;
 #endif
 #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)
 /* return a C-string corresponding to the Forth string ( FROM SIZE ).
@@ -132,6 +149,8 @@ char *tilde_cstr(Char *from, UCell size,
     UCell 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];
       memcpy(user,from+1,i-1);
@@ -156,6 +175,19 @@ char *tilde_cstr(Char *from, UCell size,
 }
 #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'
 
 #ifndef HAVE_RINT
@@ -163,7 +195,7 @@ char *tilde_cstr(Char *from, UCell size,
 #endif
 
 #ifdef HAS_FILE
-static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
+static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
 
 #ifndef O_BINARY
 #define O_BINARY 0
@@ -173,10 +205,44 @@ static char* fileattr[6]={"r","rb","r+",
 #endif
 
 static int ufileattr[6]= {
-  O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,
-  O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,
-  O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };
-#endif
+  O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
+  O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
+  O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
+#endif
+
+/* conversion on fetch */
+
+#define vm_Cell2f(x)		((Bool)(x))
+#define vm_Cell2c(x)		((Char)(x))
+#define vm_Cell2n(x)		((Cell)x)
+#define vm_Cell2w(x)		((Cell)x)
+#define vm_Cell2u(x)		((UCell)(x))
+#define vm_Cell2a_(x)		((Cell *)(x))
+#define vm_Cell2c_(x)		((Char *)(x))
+#define vm_Cell2f_(x)		((Float *)(x))
+#define vm_Cell2df_(x)		((DFloat *)(x))
+#define vm_Cell2sf_(x)		((SFloat *)(x))
+#define vm_Cell2xt(x)		((Xt)(x))
+#define vm_Cell2f83name(x)	((struct F83Name *)(x))
+#define vm_Cell2longname(x)	((struct Longname *)(x))
+#define vm_Float2r(x)	(x)
+
+/* conversion on store */
+
+#define vm_f2Cell(x)		((Cell)(x))
+#define vm_c2Cell(x)		((Cell)(x))
+#define vm_n2Cell(x)		((Cell)(x))
+#define vm_w2Cell(x)		((Cell)(x))
+#define vm_u2Cell(x)		((Cell)(x))
+#define vm_a_2Cell(x)		((Cell)(x))
+#define vm_c_2Cell(x)		((Cell)(x))
+#define vm_f_2Cell(x)		((Cell)(x))
+#define vm_df_2Cell(x)		((Cell)(x))
+#define vm_sf_2Cell(x)		((Cell)(x))
+#define vm_xt2Cell(x)		((Cell)(x))
+#define vm_f83name2Cell(x)	((Cell)(x))
+#define vm_longname2Cell(x)	((Cell)(x))
+#define vm_r2Float(x)	(x)
 
 /* if machine.h has not defined explicit registers, define them as implicit */
 #ifndef IPREG
@@ -213,12 +279,25 @@ static int ufileattr[6]= {
 
 /* declare and compute cfa for certain threading variants */
 /* warning: this is nonsyntactical; it will not work in place of a statement */
-#ifdef CFA_NEXT
+#ifndef GETCFA
 #define DOCFA
 #else
 #define DOCFA	Xt cfa; GETCFA(cfa)
 #endif
 
+/* instructions containing these must be the last instruction of a
+   super-instruction (e.g., branches, EXECUTE, and other instructions
+   ending the basic block). Instructions containing SET_IP get this
+   automatically, so you usually don't have to write it.  If you have
+   to write it, write it after IP points to the next instruction.
+   Used for profiling.  Don't write it in a word containing SET_IP, or
+   the following block will be counted twice. */
+#ifdef VM_PROFILING
+#define SUPER_END  vm_count_block(IP)
+#else
+#define SUPER_END
+#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 
@@ -242,14 +321,19 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef CFA_NEXT
   register Xt cfa CFAREG;
 #endif
+#ifdef MORE_VARS
+  MORE_VARS
+#endif
   register Address up UPREG = UP;
-  IF_TOS(register Cell TOS TOSREG;)
-  IF_FTOS(register Float FTOS FTOSREG;)
+  IF_spTOS(register Cell spTOS TOSREG;)
+  IF_fpTOS(register Float fpTOS FTOSREG;)
 #if defined(DOUBLY_INDIRECT)
   static Label *symbols;
   static void *routines[]= {
+#define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
 #else /* !defined(DOUBLY_INDIRECT) */
   static Label symbols[]= {
+#define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
 #endif /* !defined(DOUBLY_INDIRECT) */
     (Label)&&docol,
     (Label)&&docon,
@@ -278,7 +362,6 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 
   if (ip == NULL) {
 #if defined(DOUBLY_INDIRECT)
-#define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
 #define CODE_OFFSET (22*sizeof(Cell))
     int i;
     Cell code_offset = offset_image? CODE_OFFSET : 0;
@@ -290,19 +373,21 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
       if (i>=MAX_SYMBOLS) {
 	fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
 	exit(1);
+      }
+      symbols[i] = &routines[i];
     }
-    symbols[i] = &routines[i];
-  }
 #endif /* defined(DOUBLY_INDIRECT) */
-  return symbols;
-}
+    return symbols;
+  }
 
-  IF_TOS(TOS = sp[0]);
-  IF_FTOS(FTOS = fp[0]);
+  IF_spTOS(spTOS = sp[0]);
+  IF_fpTOS(fpTOS = fp[0]);
 /*  prep_terminal(); */
-  NEXT_P0;
+  SET_IP(ip);
+  SUPER_END; /* count the first block, too */
   NEXT;
 
+
 #ifdef CPU_DEP3
   CPU_DEP3
 #endif
@@ -316,22 +401,19 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef CISC_NEXT
     /* this is the simple version */
     *--rp = (Cell)ip;
-    ip = (Xt *)PFA1(cfa);
-    NEXT_P0;
+    SET_IP((Xt *)PFA1(cfa));
+    SUPER_END;
     NEXT;
 #else
-    /* 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
-       */
+    /* this one is important, so we help the compiler optimizing */
     {
       DEF_CA
-      Xt *current_ip = (Xt *)PFA1(cfa);
-      cfa = *current_ip;
-      NEXT1_P1;
-      *--rp = (Cell)ip;
-      ip = current_ip+1;
-      NEXT1_P2;
+      rp[-1] = (Cell)ip;
+      SET_IP((Xt *)PFA1(cfa));
+      SUPER_END;
+      NEXT_P1;
+      rp--;
+      NEXT_P2;
     }
 #endif
   }
@@ -343,8 +425,8 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif
 #ifdef USE_TOS
-    *sp-- = TOS;
-    TOS = *(Cell *)PFA1(cfa);
+    *sp-- = spTOS;
+    spTOS = *(Cell *)PFA1(cfa);
 #else
     *--sp = *(Cell *)PFA1(cfa);
 #endif
@@ -359,8 +441,8 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
 #ifdef USE_TOS
-    *sp-- = TOS;
-    TOS = (Cell)PFA1(cfa);
+    *sp-- = spTOS;
+    spTOS = (Cell)PFA1(cfa);
 #else
     *--sp = (Cell)PFA1(cfa);
 #endif
@@ -375,8 +457,8 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
 #ifdef USE_TOS
-    *sp-- = TOS;
-    TOS = (Cell)(up+*(Cell*)PFA1(cfa));
+    *sp-- = spTOS;
+    spTOS = (Cell)(up+*(Cell*)PFA1(cfa));
 #else
     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
 #endif
@@ -390,6 +472,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef DEBUG
     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif
+    SUPER_END;
     EXEC(*(Xt *)PFA1(cfa));
   }
 
@@ -399,7 +482,7 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 #ifdef DEBUG
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif
-    TOS += *(Cell*)PFA1(cfa); 
+    spTOS += *(Cell*)PFA1(cfa);
   }
   NEXT_P0;
   NEXT;
@@ -432,16 +515,16 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *
 #endif
     *--rp = (Cell)ip;
     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
-    ip = DOES_CODE1(cfa);
 #ifdef USE_TOS
-    *sp-- = TOS;
-    TOS = (Cell)PFA(cfa);
+    *sp-- = spTOS;
+    spTOS = (Cell)PFA(cfa);
 #else
     *--sp = (Cell)PFA(cfa);
 #endif
-    /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
+    SET_IP(DOES_CODE1(cfa));
+    SUPER_END;
+    /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
   }
-  NEXT_P0;
   NEXT;
 
 #include "prim.i"