Diff for /gforth/Attic/engine.c between versions 1.22 and 1.35

version 1.22, 1995/01/10 18:57:42 version 1.35, 1996/02/09 17:34:08
Line 1 Line 1
 /*  /* Gforth virtual machine (aka inner interpreter)
   Copyright 1992 by the ANSI figForth Development Group  
     Copyright (C) 1995 Free Software Foundation, Inc.
   
     This file is part of Gforth.
   
     Gforth is free software; you can redistribute it and/or
     modify it under the terms of the GNU General Public License
     as published by the Free Software Foundation; either version 2
     of the License, or (at your option) any later version.
   
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
   
     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.
 */  */
   
   #include "config.h"
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
 #include <string.h>  #include <string.h>
Line 14 Line 32
 #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 "forth.h"  #include "forth.h"
 #include "io.h"  #include "io.h"
   #include "threading.h"
   
 #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)
   
 typedef union {  typedef union {
   struct {    struct {
 #ifdef WORDS_BIGENDIAN  #ifdef WORDS_BIGENDIAN
     Cell high;      Cell high;
     Cell low;      UCell low;
 #else  #else
     Cell low;      UCell low;
     Cell high;      Cell high;
 #endif;  #endif;
   } cells;    } cells;
Line 46  typedef struct F83Name { Line 69  typedef struct F83Name {
 #define F83NAME_SMUDGE(np)      (((np)->countetc & 0x40) != 0)  #define F83NAME_SMUDGE(np)      (((np)->countetc & 0x40) != 0)
 #define F83NAME_IMMEDIATE(np)   (((np)->countetc & 0x20) != 0)  #define F83NAME_IMMEDIATE(np)   (((np)->countetc & 0x20) != 0)
   
 /* NEXT and NEXT1 are split into several parts to help scheduling,  
    unless CISC_NEXT is defined */  
 #ifdef CISC_NEXT  
 #define NEXT1_P1  
 #define NEXT_P1  
 #define DEF_CA  
 #ifdef DIRECT_THREADED  
 #define NEXT1_P2 ({goto *cfa;})  
 #else  
 #define NEXT1_P2 ({goto **cfa;})  
 #endif /* DIRECT_THREADED */  
 #define NEXT_P2 ({cfa = *ip++; NEXT1_P2;})  
 #else /* CISC_NEXT */  
 #ifdef DIRECT_THREADED  
 #define NEXT1_P1  
 #define NEXT1_P2 ({goto *cfa;})  
 #define DEF_CA  
 #else /* DIRECT_THREADED */  
 #define NEXT1_P1 ({ca = *cfa;})  
 #define NEXT1_P2 ({goto *ca;})  
 #define DEF_CA  Label ca;  
 #endif /* DIRECT_THREADED */  
 #define NEXT_P1 ({cfa=*ip++; NEXT1_P1;})  
 #define NEXT_P2 NEXT1_P2  
 #endif /* CISC_NEXT */  
   
 #define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})  
 #define NEXT ({DEF_CA NEXT_P1; NEXT_P2;})  
   
 #ifdef USE_TOS  #ifdef USE_TOS
 #define IF_TOS(x) x  #define IF_TOS(x) x
 #else  #else
Line 89  typedef struct F83Name { Line 83  typedef struct F83Name {
 #define FTOS (fp[0])  #define FTOS (fp[0])
 #endif  #endif
   
   Cell *SP;
   Float *FP;
   #if 0
   /* not used currently */
 int emitcounter;  int emitcounter;
   #endif
 #define NULLC '\0'  #define NULLC '\0'
   
 char *cstr(Char *from, UCell size, int clear)  char *cstr(Char *from, UCell size, int clear)
 /* if clear is true, scratch can be reused, otherwise we want more of  /* return a C-string corresponding to the Forth string ( FROM SIZE ).
    the same */     the C-string lives until the next call of cstr with CLEAR being true */
 {  {
   static char *scratch=NULL;    static struct cstr_buffer {
   static unsigned scratchsize=0;      char *buffer;
   static char *nextscratch;      size_t size;
   char *oldnextscratch;    } *buffers=NULL;
     static int nbuffers=0;
     static int used=0;
     struct cstr_buffer *b;
   
     if (buffers==NULL)
       buffers=malloc(0);
   if (clear)    if (clear)
     nextscratch=scratch;      used=0;
   if (scratch==NULL) {    if (used>=nbuffers) {
     scratch=malloc(size+1);      buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
     nextscratch=scratch;      buffers[used]=(struct cstr_buffer){malloc(0),0};
     scratchsize=size;      nbuffers=used+1;
   }    }
   else if (nextscratch+size>scratch+scratchsize) {    b=&buffers[used];
     char *oldscratch=scratch;    if (size+1 > b->size) {
     scratch = realloc(scratch, (nextscratch-scratch)+size+1);      b->buffer = realloc(b->buffer,size+1);
     nextscratch=scratch+(nextscratch-oldscratch);      b->size = size+1;
     scratchsize=size;    }
   }    memcpy(b->buffer,from,size);
   memcpy(nextscratch,from,size);    b->buffer[size]='\0';
   nextscratch[size]='\0';    used++;
   oldnextscratch = nextscratch;    return b->buffer;
   nextscratch += size+1;  }
   return oldnextscratch;  
   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");
       s2 = from+1;
       s2_len = size-1;
     } else {
       int 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);
     }
 }  }
      
   
 #define NEWLINE '\n'  #define NEWLINE '\n'
   
Line 127  char *cstr(Char *from, UCell size, int c Line 170  char *cstr(Char *from, UCell size, int c
 #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+","w+b"};  static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
   
 static Address up0=NULL;  static Address up0=NULL;
   
Line 160  static Address up0=NULL; Line 203  static Address up0=NULL;
 #define FTOSREG  #define FTOSREG
 #endif  #endif
   
   /* declare and compute cfa for certain threading variants */
   /* warning: this is nonsyntactical; it will not work in place of a statement */
   #ifdef CFA_NEXT
   #define DOCFA
   #else
   #define DOCFA   Xt cfa; GETCFA(cfa)
   #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
Line 170  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 221  Label *engine(Xt *ip0, Cell *sp0, Cell *
   register Cell *rp RPREG = rp0;    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
   register Xt cfa CFAREG;    register Xt cfa CFAREG;
   #endif
   register Address up UPREG = up0;    register Address up UPREG = up0;
   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 180  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 233  Label *engine(Xt *ip0, Cell *sp0, Cell *
     &&dovar,      &&dovar,
     &&douser,      &&douser,
     &&dodefer,      &&dodefer,
       &&dofield,
     &&dodoes,      &&dodoes,
     &&dodoes,  /* dummy for does handler address */      /* the following entry is normally unused;
          it's there because its index indicates a does-handler */
   #ifdef CPU_DEP1
       CPU_DEP1,
   #else
       (Label)0,
   #endif
 #include "prim_labels.i"  #include "prim_labels.i"
   };    };
 #ifdef CPU_DEP  #ifdef CPU_DEP2
   CPU_DEP;    CPU_DEP2
 #endif  #endif
   
 #ifdef DEBUG  #ifdef DEBUG
Line 199  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 259  Label *engine(Xt *ip0, Cell *sp0, Cell *
   
   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;
   NEXT;    NEXT;
   
   #ifdef CPU_DEP3
     CPU_DEP3
   #endif
       
  docol:   docol:
     {
       DOCFA;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef CISC_NEXT  #ifdef CISC_NEXT
   /* this is the simple version */      /* this is the simple version */
   *--rp = (Cell)ip;  
   ip = (Xt *)PFA1(cfa);  
   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  
   */  
   {  
     DEF_CA  
     Xt *current_ip = (Xt *)PFA1(cfa);  
     cfa = *current_ip;  
     NEXT1_P1;  
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     ip = current_ip+1;      ip = (Xt *)PFA1(cfa);
     NEXT1_P2;      NEXT_P0;
   }      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
          */
       {
         DEF_CA
         Xt *current_ip = (Xt *)PFA1(cfa);
         cfa = *current_ip;
         NEXT1_P1;
         *--rp = (Cell)ip;
         ip = current_ip+1;
         NEXT1_P2;
       }
 #endif  #endif
       }
   
  docon:   docon:
     {
       DOCFA;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));      fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
   *sp-- = TOS;      *sp-- = TOS;
   TOS = *(Cell *)PFA1(cfa);      TOS = *(Cell *)PFA1(cfa);
 #else  #else
   *--sp = *(Cell *)PFA1(cfa);      *--sp = *(Cell *)PFA1(cfa);
 #endif  #endif
     }
     NEXT_P0;
   NEXT;    NEXT;
       
  dovar:   dovar:
     {
       DOCFA;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
   *sp-- = TOS;      *sp-- = TOS;
   TOS = (Cell)PFA1(cfa);      TOS = (Cell)PFA1(cfa);
 #else  #else
   *--sp = (Cell)PFA1(cfa);      *--sp = (Cell)PFA1(cfa);
 #endif  #endif
     }
     NEXT_P0;
   NEXT;    NEXT;
       
   /* !! user? */  
     
  douser:   douser:
     {
       DOCFA;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef USE_TOS  #ifdef USE_TOS
   *sp-- = TOS;      *sp-- = TOS;
   TOS = (Cell)(up+*(Cell*)PFA1(cfa));      TOS = (Cell)(up+*(Cell*)PFA1(cfa));
 #else  #else
   *--sp = (Cell)(up+*(Cell*)PFA1(cfa));      *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
 #endif  #endif
     }
     NEXT_P0;
   NEXT;    NEXT;
       
  dodefer:   dodefer:
     {
       DOCFA;
 #ifdef DEBUG  #ifdef DEBUG
   fprintf(stderr,"%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));      fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
 #endif  #endif
   cfa = *(Xt *)PFA1(cfa);      EXEC(*(Xt *)PFA1(cfa));
   NEXT1;    }
   
    dofield:
     {
       DOCFA;
   #ifdef DEBUG
       fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
   #endif
       TOS += *(Cell*)PFA1(cfa); 
     }
     NEXT_P0;
     NEXT;
   
  dodoes:   dodoes:
   /* this assumes the following structure:    /* this assumes the following structure:
Line 290  Label *engine(Xt *ip0, Cell *sp0, Cell * Line 382  Label *engine(Xt *ip0, Cell *sp0, Cell *
      pfa:       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  #ifdef DEBUG
   fprintf(stderr,"%08x/%08x: does: %08x\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));      fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
   fflush(stderr);      fflush(stderr);
 #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);      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
       /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
     }
     NEXT_P0;
   NEXT;    NEXT;
   
 #include "primitives.i"  #include "primitives.i"

Removed from v.1.22  
changed lines
  Added in v.1.35


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