--- gforth/engine/engine.c	2001/02/24 13:44:39	1.27
+++ gforth/engine/engine.c	2007/12/31 17:34:59	1.104
@@ -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,2004,2005,2006,2007 Free Software Foundation, Inc.
 
   This file is part of Gforth.
 
@@ -19,7 +19,14 @@
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 */
 
+#if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING)
+#define USE_NO_TOS
+#else
+#define USE_TOS
+#endif
+
 #include "config.h"
+#include "forth.h"
 #include <ctype.h>
 #include <stdio.h>
 #include <string.h>
@@ -27,7 +34,6 @@
 #include <assert.h>
 #include <stdlib.h>
 #include <errno.h>
-#include "forth.h"
 #include "io.h"
 #include "threaded.h"
 #ifndef STANDALONE
@@ -39,6 +45,7 @@
 #include <unistd.h>
 #include <pwd.h>
 #include <dirent.h>
+#include <wchar.h>
 #include <sys/resource.h>
 #ifdef HAVE_FNMATCH_H
 #include <fnmatch.h>
@@ -46,7 +53,7 @@
 #include "fnmatch.h"
 #endif
 #else
-#include "systypes.h"
+/* #include <systypes.h> */
 #endif
 
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
@@ -59,37 +66,28 @@
 #include <dl.h>
 #endif
 
+#ifdef HAS_FFCALL
+#include <avcall.h>
+#include <callback.h>
+#endif
+
+#ifdef HAS_LIBFFI
+#include <ffi.h>
+#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,152 +95,63 @@ 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; 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);
-      user[i-1]='\0';
-      user_entry=getpwnam(user);
-    }
-    if (user_entry==NULL)
-      return cstr(from, size, clear);
-    s1 = user_entry->pw_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<d1.lo);
-  return d2;
-#endif
-}
-
 #define NEWLINE	'\n'
 
-#ifndef HAVE_RINT
-#define rint(x)	floor((x)+0.5)
-#endif
-
-#ifdef HAS_FILE
-static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif
-#ifndef O_TEXT
-#define O_TEXT 0
-#endif
-
-static int ufileattr[6]= {
-  O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
-  O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
-  O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
+/* These two flags control whether divisions are checked by software.
+   The CHECK_DIVISION_SW is for those cases where the event is a
+   division by zero or overflow on the C level, and might be reported
+   by hardware; we might check forr that in autoconf and set the
+   switch appropriately, but currently don't.  The CHECK_DIVISION flag
+   is for the other cases. */
+#ifdef GFORTH_DEBUGGING
+#define CHECK_DIVISION_SW 1
+#define CHECK_DIVISION 1
+#else
+#define CHECK_DIVISION_SW 0
+#define CHECK_DIVISION 0
 #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)
+#define vm_Cell2f(_cell,_x)		((_x)=(Bool)(_cell))
+#define vm_Cell2c(_cell,_x)		((_x)=(Char)(_cell))
+#define vm_Cell2n(_cell,_x)		((_x)=(Cell)(_cell))
+#define vm_Cell2w(_cell,_x)		((_x)=(Cell)(_cell))
+#define vm_Cell2u(_cell,_x)		((_x)=(UCell)(_cell))
+#define vm_Cell2a_(_cell,_x)		((_x)=(Cell *)(_cell))
+#define vm_Cell2c_(_cell,_x)		((_x)=(Char *)(_cell))
+#define vm_Cell2f_(_cell,_x)		((_x)=(Float *)(_cell))
+#define vm_Cell2df_(_cell,_x)		((_x)=(DFloat *)(_cell))
+#define vm_Cell2sf_(_cell,_x)		((_x)=(SFloat *)(_cell))
+#define vm_Cell2xt(_cell,_x)		((_x)=(Xt)(_cell))
+#define vm_Cell2f83name(_cell,_x)	((_x)=(struct F83Name *)(_cell))
+#define vm_Cell2longname(_cell,_x)	((_x)=(struct Longname *)(_cell))
+#define vm_Float2r(_float,_x)		(_x=_float)
 
 /* 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)
+#define vm_f2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_c2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_n2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_w2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_u2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_a_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_c_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_f_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_df_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_sf_2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_xt2Cell(_x,_cell)		((_cell)=(Cell)(_x))
+#define vm_f83name2Cell(_x,_cell)	((_cell)=(Cell)(_x))
+#define vm_longname2Cell(_x,_cell)	((_cell)=(Cell)(_x))
+#define vm_r2Float(_x,_float)		(_float=_x)
+
+#define vm_Cell2Cell(_x,_y)		(_y=_x)
+
+#ifdef NO_IP
+#define IMM_ARG(access,value)		(VARIANT(value))
+#else
+#define IMM_ARG(access,value)		(access)
+#endif
 
 /* if machine.h has not defined explicit registers, define them as implicit */
 #ifndef IPREG
@@ -260,6 +169,9 @@ static int ufileattr[6]= {
 #ifndef LPREG
 #define LPREG
 #endif
+#ifndef CAREG
+#define CAREG
+#endif
 #ifndef CFAREG
 #define CFAREG
 #endif
@@ -269,6 +181,27 @@ static int ufileattr[6]= {
 #ifndef TOSREG
 #define TOSREG
 #endif
+#ifndef spbREG
+#define spbREG
+#endif
+#ifndef spcREG
+#define spcREG
+#endif
+#ifndef spdREG
+#define spdREG
+#endif
+#ifndef speREG
+#define speREG
+#endif
+#ifndef spfREG
+#define spfREG
+#endif
+#ifndef spgREG
+#define spgREG
+#endif
+#ifndef sphREG
+#define sphREG
+#endif
 #ifndef FTOSREG
 #define FTOSREG
 #endif
@@ -277,42 +210,151 @@ static int ufileattr[6]= {
 # define CPU_DEP1 0
 #endif
 
-/* declare and compute cfa for certain threading variants */
-/* warning: this is nonsyntactical; it will not work in place of a statement */
-#ifndef GETCFA
-#define DOCFA
+/* instructions containing SUPER_END 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 DOCFA	Xt cfa; GETCFA(cfa)
+#define SUPER_END
+#endif
+#define SUPER_CONTINUE
+
+#ifdef ASMCOMMENT
+/* an individualized asm statement so that (hopefully) gcc's optimizer
+   does not do cross-jumping */
+#define asmcomment(string) asm(ASMCOMMENT string)
+#else
+/* we don't know how to do an asm comment, so we just do an empty asm */
+#define asmcomment(string) asm("")
 #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;
+#if DEBUG
+#define NAME(string) { saved_ip=ip; asmcomment(string); fprintf(stderr,"%08lx depth=%3ld tos=%016lx: "string"\n",(Cell)ip,sp0+3-sp,sp[0]);}
+#else /* !DEBUG */
+#define NAME(string) { saved_ip=ip; asm(""); }
+/* the asm here is to avoid reordering of following stuff above the
+   assignment; this is an old-style asm (no operands), and therefore
+   is treated like "asm volatile ..."; i.e., it prevents most
+   reorderings across itself.  We want the assignment above first,
+   because the stack loads may already cause a stack underflow. */
+#endif /* !DEBUG */
+#elif DEBUG
+#       define  NAME(string)    {Cell __depth=sp0+3-sp; int i; fprintf(stderr,"%08lx depth=%3ld: "string,(Cell)ip,sp0+3-sp); for (i=__depth-1; i>0; i--) fprintf(stderr, " $%lx",sp[i]); fprintf(stderr, " $%lx\n",spTOS); }
+#else
+#	define	NAME(string) asmcomment(string);
+#endif
+
+#ifdef DEBUG
+#define CFA_TO_NAME(__cfa) \
+      Cell len, i; \
+      char * name = __cfa; \
+      for(i=0; i<32; i+=sizeof(Cell)) { \
+        len = ((Cell*)name)[-1]; \
+        if(len < 0) { \
+	  len &= 0x1F; \
+          if((len+sizeof(Cell)) > i) break; \
+	} len = 0; \
+	name -= sizeof(Cell); \
+      }
+#endif
+
+#ifdef STANDALONE
+jmp_buf throw_jmp_buf;
+
+void throw(int code)
+{
+  longjmp(throw_jmp_buf,code); /* !! or use siglongjmp ? */
+}
 #endif
 
-Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
+#if defined(HAS_FFCALL) || defined(HAS_LIBFFI)
+#define SAVE_REGS IF_fpTOS(fp[0]=fpTOS); gforth_SP=sp; gforth_FP=fp; gforth_RP=rp; gforth_LP=lp;
+#define REST_REGS sp=gforth_SP; fp=gforth_FP; rp=gforth_RP; lp=gforth_LP; IF_fpTOS(fpTOS=fp[0]);
+#endif
+
+#if !defined(ENGINE)
+/* normal engine */
+#define VARIANT(v)	(v)
+#define JUMP(target)	goto I_noop
+#define LABEL(name) H_##name: asm(""); I_##name:
+#define LABEL3(name) J_##name: asm("");
+
+#elif ENGINE==2
+/* variant with padding between VM instructions for finding out
+   cross-inst jumps (for dynamic code) */
+#define gforth_engine gforth_engine2
+#define VARIANT(v)	(v)
+#define JUMP(target)	goto I_noop
+#define LABEL(name) H_##name: SKIP16; I_##name:
+/* the SKIP16 after LABEL3 is there, because the ARM gcc may place
+   some constants after the final branch, and may refer to them from
+   the code before label3.  Since we don't copy the constants, we have
+   to make sure that such code is recognized as non-relocatable. */
+#define LABEL3(name) J_##name: SKIP16;
+
+#elif ENGINE==3
+/* variant with different immediate arguments for finding out
+   immediate arguments (for native code) */
+#define gforth_engine gforth_engine3
+#define VARIANT(v)	((v)^0xffffffff)
+#define JUMP(target)	goto K_lit
+#define LABEL(name) H_##name: asm(""); I_##name:
+#define LABEL3(name) J_##name: asm("");
+#else
+#error illegal ENGINE value
+#endif /* ENGINE */
+
+/* the asm(""); is there to get a stop compiled on Itanium */
+#define LABEL2(name) K_##name: asm("");
+
+Label *gforth_engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
 /* executes code at ip, if ip!=NULL
    returns array of machine code labels (for use in a loader), if ip==NULL
 */
 {
 #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
+  register Label real_ca CAREG;
 #ifdef MORE_VARS
   MORE_VARS
 #endif
-  register Address up UPREG = UP;
-  IF_spTOS(register Cell spTOS TOSREG;)
+#ifdef HAS_FFCALL
+  av_alist alist;
+  extern va_alist gforth_clist;
+  float frv;
+  int irv;
+  double drv;
+  long long llrv;
+  void * prv;
+#endif
+#ifdef HAS_LIBFFI
+  extern void * gforth_ritem;
+  extern void ** gforth_clist;
+  extern void ffi_callback(ffi_cif * cif, void * resp, void ** args, Xt * ip);
+#endif
+  register Address up UPREG = gforth_UP;
+  register Cell MAYBE_UNUSED spTOS TOSREG;
+  register Cell MAYBE_UNUSED spb spbREG;
+  register Cell MAYBE_UNUSED spc spcREG;
+  register Cell MAYBE_UNUSED spd spdREG;
+  register Cell MAYBE_UNUSED spe speREG;
+  register Cell MAYBE_UNUSED spf speREG;
+  register Cell MAYBE_UNUSED spg speREG;
+  register Cell MAYBE_UNUSED sph speREG;
   IF_fpTOS(register Float fpTOS FTOSREG;)
 #if defined(DOUBLY_INDIRECT)
   static Label *symbols;
@@ -322,192 +364,99 @@ 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,
-#include "prim_lab.i"
-    (Label)0
+#define INST_ADDR(name) ((Label)&&I_##name)
+#include PRIM_LAB_I
+#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,
+    (Label)&&before_goto,
+    (Label)&&after_goto,
+/* just mention the H_ labels, so the SKIP16s are not optimized away */
+#define INST_ADDR(name) ((Label)&&H_##name)
+#include PRIM_LAB_I
+#undef INST_ADDR
   };
+#ifdef STANDALONE
+#define INST_ADDR(name) ((Label)&&I_##name)
+#include "image.i"
+#undef INST_ADDR
+#endif
 #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<DOESJUMP+1; i++)
-      symbols[i] = (Label)routines[i];
+      xts[i] = symbols[i] = (Label)routines[i];
     for (; routines[i]!=0; i++) {
       if (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) */
+#ifdef STANDALONE
+    return image;
+#else
     return symbols;
+#endif
   }
 
-  IF_spTOS(spTOS = sp[0]);
+#if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
+  sp += STACK_CACHE_DEFAULT-1;
+  /* some of those registers are dead, but its simpler to initialize them all */  spTOS = sp[0];
+  spb = sp[-1];
+  spc = sp[-2];
+  spd = sp[-3];
+  spe = sp[-4];
+  spf = sp[-5];
+  spg = sp[-6];
+  sph = sp[-7];
+#endif
+
   IF_fpTOS(fpTOS = fp[0]);
 /*  prep_terminal(); */
+#ifdef NO_IP
+  goto *(*(Label *)ip0);
+  before_goto:
+  goto *real_ca;
+  after_goto:;
+#else
   SET_IP(ip);
-  NEXT;
-
+  SUPER_END; /* count the first block, too */
+  FIRST_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));
-    NEXT;
-#else
-    /* this one is important, so we help the compiler optimizing */
-    {
-      DEF_CA
-      rp[-1] = (Cell)ip;
-      SET_IP((Xt *)PFA1(cfa));
-      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
-    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));
-    /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/
-  }
-  NEXT;
+#include PRIM_I
+  after_last: return (Label *)0;
+  /*needed only to get the length of the last primitive */
 
-#include "prim.i"
+  return (Label *)0;
 }