Diff for /gforth/Attic/engine.c between versions 1.3 and 1.31

version 1.3, 1994/05/03 19:10:34 version 1.31, 1995/11/07 18:06:37
Line 1 Line 1
 /*  /* Gforth virtual machine (aka inner interpreter)
   $Id$  
   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 <ctype.h>  #include <ctype.h>
Line 13 Line 29
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
 #include <time.h>  #include <time.h>
   #include <sys/time.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
   /* should be defined in stdio.h, but some systems don't have it */
   #define SEEK_SET 0
   #endif
   
 extern unlink(char *);  #define IOR(flag)       ((flag)? -512-errno : 0)
 extern ftruncate(int, int);  
   
 typedef union {  typedef union {
   struct {    struct {
 #ifdef BIG_ENDIAN  #ifdef WORDS_BIGENDIAN
     Cell high;      Cell high;
     Cell low;      Cell low;
 #else  #else
Line 43  typedef struct F83Name { Line 68  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 */  
 #ifdef DIRECT_THREADED  
 #define NEXT1_P1   
 #define NEXT1_P2 ({goto *cfa;})  
 #else  
 #define NEXT1_P1 ({ca = *cfa;})  
 #define NEXT1_P2 ({goto *ca;})  
 #endif  
 #define NEXT_P1 ({cfa = *ip++; NEXT1_P1;})  
   
 #define NEXT1 ({Label ca; NEXT1_P1; NEXT1_P2;})  
 #define NEXT ({Label ca; NEXT_P1; NEXT1_P2;})  
   
 #ifdef USE_TOS  #ifdef USE_TOS
 #define IF_TOS(x) x  #define IF_TOS(x) x
 #else  #else
Line 70  typedef struct F83Name { Line 82  typedef struct F83Name {
 #define FTOS (fp[0])  #define FTOS (fp[0])
 #endif  #endif
   
 #define DODOES  (symbols[3])  Cell *SP;
   Float *FP;
 int emitcounter;  int emitcounter;
 #define NULLC '\0'  #define NULLC '\0'
   
 #define cstr(to,from,size)\  char *cstr(Char *from, UCell size, int clear)
         {       memcpy(to,from,size);\  /* if clear is true, scratch can be reused, otherwise we want more of
                 to[size]=NULLC;}     the same */
   {
     static char *scratch=NULL;
     static unsigned scratchsize=0;
     static char *nextscratch;
     char *oldnextscratch;
   
     if (clear)
       nextscratch=scratch;
     if (scratch==NULL) {
       scratch=malloc(size+1);
       nextscratch=scratch;
       scratchsize=size;
     }
     else if (nextscratch+size>scratch+scratchsize) {
       char *oldscratch=scratch;
       scratch = realloc(scratch, (nextscratch-scratch)+size+1);
       nextscratch=scratch+(nextscratch-oldscratch);
       scratchsize=size;
     }
     memcpy(nextscratch,from,size);
     nextscratch[size]='\0';
     oldnextscratch = nextscratch;
     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'
   
 static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};  #ifndef HAVE_RINT
   #define rint(x) floor((x)+0.5)
   #endif
   
 Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp)  static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
   
   static Address up0=NULL;
   
   /* if machine.h has not defined explicit registers, define them as implicit */
   #ifndef IPREG
   #define IPREG
   #endif
   #ifndef SPREG
   #define SPREG
   #endif
   #ifndef RPREG
   #define RPREG
   #endif
   #ifndef FPREG
   #define FPREG
   #endif
   #ifndef LPREG
   #define LPREG
   #endif
   #ifndef CFAREG
   #define CFAREG
   #endif
   #ifndef UPREG
   #define UPREG
   #endif
   #ifndef TOSREG
   #define TOSREG
   #endif
   #ifndef FTOSREG
   #define FTOSREG
   #endif
   
   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
    This is very preliminary, as the bootstrap architecture is not yet decided  
 */  */
 {  {
   Xt cfa;    register Xt *ip IPREG = ip0;
   Address lp=NULL;    register Cell *sp SPREG = sp0;
     register Cell *rp RPREG = rp0;
     register Float *fp FPREG = fp0;
     register Address lp LPREG = lp0;
   #ifdef CFA_NEXT
     register Xt cfa CFAREG;
   #endif
     register Address up UPREG = up0;
     IF_TOS(register Cell TOS TOSREG;)
     IF_FTOS(register Float FTOS FTOSREG;)
   static Label symbols[]= {    static Label symbols[]= {
     &&docol,      &&docol,
     &&docon,      &&docon,
     &&dovar,      &&dovar,
       &&douser,
       &&dodefer,
       &&dofield,
     &&dodoes,      &&dodoes,
       &&dodoes,  /* dummy for does handler address */
 #include "prim_labels.i"  #include "prim_labels.i"
   };    };
 #ifndef DIRECT_THREADED  
 /*  Label ca; */  
 #endif  
   IF_TOS(register Cell TOS;)  
   IF_FTOS(Float FTOS;)  
 #ifdef CPU_DEP  #ifdef CPU_DEP
   CPU_DEP;    CPU_DEP;
 #endif  #endif
   
   #ifdef DEBUG
     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
             (unsigned)ip,(unsigned)sp,(unsigned)rp,
             (unsigned)fp,(unsigned)lp,(unsigned)up);
   #endif
   
   if (ip == NULL)    if (ip == NULL)
     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;
   NEXT;    NEXT;
       
  docol:   docol:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
 #ifdef DEBUG  #ifdef DEBUG
   printf("col: %x\n",(Cell)PFA1(cfa));    fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
 #endif  #endif
 #ifdef undefined  #ifdef CISC_NEXT
   /* this is the simple version */    /* this is the simple version */
   *--rp = (Cell)ip;    *--rp = (Cell)ip;
   ip = (Xt *)PFA1(cfa);    ip = (Xt *)PFA1(cfa);
     NEXT_P0;
   NEXT;    NEXT;
 #endif  #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       The following version may be better (for scheduling), but probably has
      problems with code fields employing calls and delay slots       problems with code fields employing calls and delay slots
   */    */
   {    {
     Label ca;      DEF_CA
     Xt *current_ip = (Xt *)PFA1(cfa);      Xt *current_ip = (Xt *)PFA1(cfa);
     cfa = *current_ip;      cfa = *current_ip;
     NEXT1_P1;      NEXT1_P1;
Line 137  Label *engine(Xt *ip, Cell *sp, Cell *rp Line 270  Label *engine(Xt *ip, Cell *sp, Cell *rp
     ip = current_ip+1;      ip = current_ip+1;
     NEXT1_P2;      NEXT1_P2;
   }    }
     #endif
   #ifndef CFA_NEXT
     }
   #endif
   
  docon:   docon:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
 #ifdef DEBUG  #ifdef DEBUG
   printf("con: %x\n",*(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;
Line 148  Label *engine(Xt *ip, Cell *sp, Cell *rp Line 289  Label *engine(Xt *ip, Cell *sp, Cell *rp
 #else  #else
   *--sp = *(Cell *)PFA1(cfa);    *--sp = *(Cell *)PFA1(cfa);
 #endif  #endif
   #ifndef CFA_NEXT
     }
   #endif
     NEXT_P0;
   NEXT;    NEXT;
       
  dovar:   dovar:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
 #ifdef DEBUG  #ifdef DEBUG
   printf("var: %x\n",(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;
Line 160  Label *engine(Xt *ip, Cell *sp, Cell *rp Line 309  Label *engine(Xt *ip, Cell *sp, Cell *rp
 #else  #else
   *--sp = (Cell)PFA1(cfa);    *--sp = (Cell)PFA1(cfa);
 #endif  #endif
   #ifndef CFA_NEXT
     }
   #endif
     NEXT_P0;
   NEXT;    NEXT;
       
   /* !! user? */   douser:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
   #ifdef DEBUG
     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
   #endif
   #ifdef USE_TOS
     *sp-- = TOS;
     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
   #else
     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
   #endif
   #ifndef CFA_NEXT
     }
   #endif
     NEXT_P0;
     NEXT;
       
    dodefer:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
   #ifdef DEBUG
     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
   #endif
     EXEC(*(Xt *)PFA1(cfa));
   #ifndef CFA_NEXT
     }
   #endif
   
    dofield:
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   #endif
   #ifdef DEBUG
     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
   #endif
     TOS += *(Cell*)PFA1(cfa); 
   #ifndef CFA_NEXT
     }
   #endif
     NEXT_P0;
     NEXT;
   
  dodoes:   dodoes:
   /* this assumes the following structure:    /* this assumes the following structure:
      defining-word:       defining-word:
Line 182  Label *engine(Xt *ip, Cell *sp, Cell *rp Line 381  Label *engine(Xt *ip, Cell *sp, Cell *rp
      pfa:       pfa:
             
      */       */
   #ifndef CFA_NEXT
     {
       Xt cfa; GETCFA(cfa);
   
   /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
   #endif
 #ifdef DEBUG  #ifdef DEBUG
   printf("does: %x\n",(Cell)PFA(cfa));    fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
     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);
 #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
   ip = DOES_CODE1(cfa);  #ifndef CFA_NEXT
   /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
     }
   #endif
     NEXT_P0;
   NEXT;    NEXT;
     
 #include "primitives.i"  #include "primitives.i"
 }  }

Removed from v.1.3  
changed lines
  Added in v.1.31


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