Diff for /gforth/engine/engine.c between versions 1.11 and 1.113

version 1.11, 1999/02/06 22:28:24 version 1.113, 2010/12/31 18:09:02
Line 1 Line 1
 /* Gforth virtual machine (aka inner interpreter)  /* Gforth virtual machine (aka inner interpreter)
   
   Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2010 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
   Gforth is free software; you can redistribute it and/or    Gforth is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License    modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2    as published by the Free Software Foundation, either version 3
   of the License, or (at your option) any later version.    of the License, or (at your option) any later version.
   
   This program is distributed in the hope that it will be useful,    This program is distributed in the hope that it will be useful,
Line 15 Line 15
   GNU General Public License for more details.    GNU General Public License for more details.
   
   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, see http://www.gnu.org/licenses/.
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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 "config.h"
   #include "forth.h"
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
 #include <string.h>  #include <string.h>
Line 27 Line 33
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
 #include <errno.h>  #include <errno.h>
 #include "forth.h"  
 #include "io.h"  #include "io.h"
 #include "threaded.h"  #include "threaded.h"
 #ifndef STANDALONE  #ifndef STANDALONE
Line 38 Line 43
 #include <sys/time.h>  #include <sys/time.h>
 #include <unistd.h>  #include <unistd.h>
 #include <pwd.h>  #include <pwd.h>
   #include <dirent.h>
   #ifdef HAVE_WCHAR_H
   #include <wchar.h>
   #endif
   #include <sys/resource.h>
   #ifdef HAVE_FNMATCH_H
   #include <fnmatch.h>
   #else
   #include "fnmatch.h"
   #endif
 #else  #else
 #include "systypes.h"  /* #include <systypes.h> */
 #endif  #endif
   
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
Line 52 Line 67
 #include <dl.h>  #include <dl.h>
 #endif  #endif
   
   #ifdef HAS_FFCALL
   #include <avcall.h>
   #include <callback.h>
   #endif
   
 #ifndef SEEK_SET  #ifndef SEEK_SET
 /* should be defined in stdio.h, but some systems don't have it */  /* should be defined in stdio.h, but some systems don't have it */
 #define SEEK_SET 0  #define SEEK_SET 0
 #endif  #endif
   
 #define IOR(flag)       ((flag)? -512-errno : 0)  #ifndef HAVE_FSEEKO
   #define fseeko fseek
   #endif
   
 struct F83Name {  #ifndef HAVE_FTELLO
   struct F83Name *next;  /* the link field for old hands */  #define ftello ftell
   char          countetc;  
   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)  
   
 Cell *SP;  
 Float *FP;  
 Address UP=NULL;  
   
 #if 0  
 /* not used currently */  
 int emitcounter;  
 #endif  #endif
 #define NULLC '\0'  
   
 #ifdef HAS_FILE  #define NULLC '\0'
 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)  #ifdef MEMCMP_AS_SUBROUTINE
 /* like cstr(), but perform tilde expansion on the string */  extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
 {  #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
   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++)  
       ;  
     {  
       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  #endif
   
 #define NEWLINE '\n'  #define NEWLINE '\n'
   
 #ifndef HAVE_RINT  /* These two flags control whether divisions are checked by software.
 #define rint(x) floor((x)+0.5)     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  #endif
   
 #ifdef HAS_FILE  /* conversion on fetch */
 static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};  
   
 #ifndef O_BINARY  #define vm_Cell2f(_cell,_x)             ((_x)=(Bool)(_cell))
 #define O_BINARY 0  #define vm_Cell2c(_cell,_x)             ((_x)=(Char)(_cell))
 #endif  #define vm_Cell2n(_cell,_x)             ((_x)=(Cell)(_cell))
 #ifndef O_TEXT  #define vm_Cell2w(_cell,_x)             ((_x)=(Cell)(_cell))
 #define O_TEXT 0  #define vm_Cell2u(_cell,_x)             ((_x)=(UCell)(_cell))
 #endif  #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)             ((_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)
   
 static int ufileattr[6]= {  #ifdef NO_IP
   O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,  #define IMM_ARG(access,value)           (VARIANT(value))
   O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,  #else
   O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };  #define IMM_ARG(access,value)           (access)
 #endif  #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 */
Line 194  static int ufileattr[6]= { Line 166  static int ufileattr[6]= {
 #ifndef LPREG  #ifndef LPREG
 #define LPREG  #define LPREG
 #endif  #endif
   #ifndef CAREG
   #define CAREG
   #endif
 #ifndef CFAREG  #ifndef CFAREG
 #define CFAREG  #define CFAREG
 #endif  #endif
Line 203  static int ufileattr[6]= { Line 178  static int ufileattr[6]= {
 #ifndef TOSREG  #ifndef TOSREG
 #define TOSREG  #define TOSREG
 #endif  #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  #ifndef FTOSREG
 #define FTOSREG  #define FTOSREG
 #endif  #endif
Line 211  static int ufileattr[6]= { Line 207  static int ufileattr[6]= {
 # define CPU_DEP1 0  # define CPU_DEP1 0
 #endif  #endif
   
 /* declare and compute cfa for certain threading variants */  /* instructions containing SUPER_END must be the last instruction of a
 /* warning: this is nonsyntactical; it will not work in place of a statement */     super-instruction (e.g., branches, EXECUTE, and other instructions
 #ifdef CFA_NEXT     ending the basic block). Instructions containing SET_IP get this
 #define DOCFA     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
   #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  #else
 #define DOCFA   Xt cfa; GETCFA(cfa)  /* we don't know how to do an asm comment, so we just do an empty asm */
   #define asmcomment(string) asm("")
 #endif  #endif
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
 /* define some VM registers as global variables, so they survive exceptions;  #if DEBUG
    global register variables are not up to the task (according to the   #define NAME(string) { saved_ip=ip; asmcomment(string); fprintf(stderr,"%08lx depth=%3ld tos=%016lx: "string"\n",(Cell)ip,sp0+3-sp,sp[0]);}
    GNU C manual) */  #else /* !DEBUG */
 Xt *ip;  #define NAME(string) { saved_ip=ip; asm(""); }
 Cell *rp;  /* 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  #endif
   
 Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)  #ifdef STANDALONE
   jmp_buf throw_jmp_buf;
   
   void throw(int code)
   {
     longjmp(throw_jmp_buf,code); /* !! or use siglongjmp ? */
   }
   #endif
   
   #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 sr_proto)
 /* 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
 */  */
 {  {
 #ifndef GFORTH_DEBUGGING  #if defined(GFORTH_DEBUGGING)
   register Xt *ip IPREG;  #if defined(GLOBALS_NONRELOC)
     register saved_regs *saved_regs_p TOSREG = saved_regs_p0;
   #endif /* defined(GLOBALS_NONRELOC) */
   #else /* !defined(GFORTH_DEBUGGING) */
   register Cell *rp RPREG;    register Cell *rp RPREG;
   #endif /* !defined(GFORTH_DEBUGGING) */
   #ifndef NO_IP
     register Xt *ip IPREG = ip0;
 #endif  #endif
   register Cell *sp SPREG = sp0;    register Cell *sp SPREG = sp0;
   register Float *fp FPREG = fp0;    register Float *fp FPREG = fp0;
   register Address lp LPREG = lp0;    register Address lp LPREG = lp0;
 #ifdef CFA_NEXT  
   register Xt cfa CFAREG;    register Xt cfa CFAREG;
 #endif    register Label real_ca CAREG;
 #ifdef MORE_VARS  #ifdef MORE_VARS
   MORE_VARS    MORE_VARS
 #endif  #endif
   register Address up UPREG = UP;  #ifdef HAS_FFCALL
   IF_TOS(register Cell TOS TOSREG;)    av_alist alist;
   IF_FTOS(register Float FTOS FTOSREG;)    extern va_alist gforth_clist;
     float frv;
     int irv;
     double drv;
     long long llrv;
     void * prv;
   #endif
     register Address up UPREG = gforth_UP;
   #if !defined(GFORTH_DEBUGGING)
     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 spfREG;
     register Cell MAYBE_UNUSED spg spgREG;
     register Cell MAYBE_UNUSED sph sphREG;
     IF_fpTOS(register Float fpTOS FTOSREG;)
   #endif /* !defined(GFORTH_DEBUGGING) */
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
   static Label *symbols;    static Label *symbols;
   static void *routines[]= {    static void *routines[]= {
   #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
 #else /* !defined(DOUBLY_INDIRECT) */  #else /* !defined(DOUBLY_INDIRECT) */
   static Label symbols[]= {    static Label symbols[]= {
   #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0]))
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
     (Label)&&docol,  #define INST_ADDR(name) ((Label)&&I_##name)
     (Label)&&docon,  #include PRIM_LAB_I
     (Label)&&dovar,  #undef INST_ADDR
     (Label)&&douser,      (Label)0,
     (Label)&&dodefer,  #define INST_ADDR(name) ((Label)&&K_##name)
     (Label)&&dofield,  #include PRIM_LAB_I
     (Label)&&dodoes,  #undef INST_ADDR
     /* the following entry is normally unused;  #define INST_ADDR(name) ((Label)&&J_##name)
        it's there because its index indicates a does-handler */  #include PRIM_LAB_I
     CPU_DEP1,  #undef INST_ADDR
 #include "prim_lab.i"      (Label)&&after_last,
     (Label)0      (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  #ifdef CPU_DEP2
   CPU_DEP2    CPU_DEP2
 #endif  #endif
   
   ip = ip0;  
   rp = rp0;    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)ip0,(unsigned)sp,(unsigned)rp,
           (unsigned)fp,(unsigned)lp,(unsigned)up);            (unsigned)fp,(unsigned)lp,(unsigned)up);
 #endif  #endif
   
   if (ip == NULL) {    if (ip0 == NULL) {
 #if defined(DOUBLY_INDIRECT)  #if defined(DOUBLY_INDIRECT)
 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))  #define CODE_OFFSET (26*sizeof(Cell))
 #define CODE_OFFSET (22*sizeof(Cell))  #define XT_OFFSET (22*sizeof(Cell))
     int i;      int i;
     Cell code_offset = offset_image? CODE_OFFSET : 0;      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);      symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
     for (i=0; i<DOESJUMP+1; i++)      xts = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+XT_OFFSET)+xt_offset);
       symbols[i] = (Label)routines[i];      for (i=0; i<DOER_MAX+1; i++)
         xts[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 %ld primitives\n",(long)MAX_SYMBOLS);
         exit(1);          exit(1);
         }
         xts[i] = symbols[i] = &routines[i];
     }      }
     symbols[i] = &routines[i];  
   }  
 #endif /* defined(DOUBLY_INDIRECT) */  #endif /* defined(DOUBLY_INDIRECT) */
   return symbols;  #ifdef STANDALONE
 }      return image;
   
   IF_TOS(TOS = sp[0]);  
   IF_FTOS(FTOS = fp[0]);  
 /*  prep_terminal(); */  
   SET_IP(ip);  
   NEXT;  
   
   
 #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-- = TOS;  
     TOS = *(Cell *)PFA1(cfa);  
 #else  #else
     *--sp = *(Cell *)PFA1(cfa);      return symbols;
 #endif  #endif
   }    }
   NEXT_P0;  
   NEXT;  #if !(defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
       sp += STACK_CACHE_DEFAULT-1;
  dovar:    /* some of those registers are dead, but its simpler to initialize them all */  spTOS = sp[0];
   {    spb = sp[-1];
     DOCFA;    spc = sp[-2];
 #ifdef DEBUG    spd = sp[-3];
     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));    spe = sp[-4];
 #endif    spf = sp[-5];
 #ifdef USE_TOS    spg = sp[-6];
     *sp-- = TOS;    sph = sp[-7];
     TOS = (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  #endif
 #ifdef USE_TOS  
     *sp-- = TOS;    IF_fpTOS(fpTOS = fp[0]);
     TOS = (Cell)(up+*(Cell*)PFA1(cfa));  /*  prep_terminal(); */
   #ifdef NO_IP
     goto *(*(Label *)ip0);
     before_goto:
     goto *real_ca;
     after_goto:;
 #else  #else
     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));    SET_IP(ip);
 #endif    SUPER_END; /* count the first block, too */
   }    FIRST_NEXT;
   NEXT_P0;  
   NEXT;  
     
  dodefer:  
   {  
     DOCFA;  
 #ifdef DEBUG  
     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));  
 #endif  #endif
     EXEC(*(Xt *)PFA1(cfa));  
   }  
   
  dofield:  #ifdef CPU_DEP3
   {    CPU_DEP3
     DOCFA;  
 #ifdef DEBUG  
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));  
 #endif  #endif
     TOS += *(Cell*)PFA1(cfa);  
   }  
   NEXT_P0;  
   NEXT;  
   
  dodoes:  #include PRIM_I
   /* this assumes the following structure:    after_last: return (Label *)0;
      defining-word:    /*needed only to get the length of the last primitive */
        
      ...  
      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-- = TOS;  
     TOS = (Cell)PFA(cfa);  
 #else  
     *--sp = (Cell)PFA(cfa);  
 #endif  
     SET_IP(DOES_CODE1(cfa));  
     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/  
   }  
   NEXT;  
   
 #include "prim.i"    return (Label *)0;
 }  }

Removed from v.1.11  
changed lines
  Added in v.1.113


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