[gforth] / gforth / Attic / engine.c  

gforth: gforth/Attic/engine.c

Diff for /gforth/Attic/engine.c between version 1.2 and 1.39

version 1.2, Wed Apr 20 17:12:00 1994 UTC version 1.39, Thu Feb 6 21:22:58 1997 UTC
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 "config.h"
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
 #include <string.h>  #include <string.h>
Line 13 
Line 30 
 #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"
   
 extern unlink(char *);  #ifndef SEEK_SET
 extern ftruncate(int, int);  /* should be defined in stdio.h, but some systems don't have it */
   #define SEEK_SET 0
   #endif
   
 typedef union {  #define IOR(flag)       ((flag)? -512-errno : 0)
   struct {  
 #ifdef BIG_ENDIAN  
     Cell high;  
     Cell low;  
 #else  
     Cell low;  
     Cell high;  
 #endif;  
   } cells;  
   DCell dcell;  
 } Double_Store;  
   
 typedef struct F83Name {  typedef struct F83Name {
   struct F83Name        *next;  /* the link field for old hands */    struct F83Name        *next;  /* the link field for old hands */
Line 43 
Line 56 
 #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 */  Cell *SP;
 #ifdef DIRECT_THREADED  Float *FP;
 #define NEXT1_P1  #if 0
 #define NEXT1_P2 ({goto *cfa;})  /* not used currently */
 #else  int emitcounter;
 #define NEXT1_P1 ({ca = *cfa;})  
 #define NEXT1_P2 ({goto *ca;})  
 #endif  #endif
 #define NEXT_P1 ({cfa = *ip++; NEXT1_P1;})  #define NULLC '\0'
   
 #define NEXT1 ({NEXT1_P1; NEXT1_P2;})  char *cstr(Char *from, UCell size, int clear)
 #define NEXT ({NEXT_P1; NEXT1_P2;})  /* 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;
   }
   
 #ifdef USE_TOS  char *tilde_cstr(Char *from, UCell size, int clear)
 #define IF_TOS(x) x  /* like cstr(), but perform tilde expansion on the string */
 #else  {
 #define IF_TOS(x)    char *s1,*s2;
 #define TOS (sp[0])    int s1_len, s2_len;
 #endif    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 {
       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);
     }
   }
   
 #ifdef USE_FTOS  
 #define IF_FTOS(x) x  #define NEWLINE '\n'
 #else  
 #define IF_FTOS(x)  #ifndef HAVE_RINT
 #define FTOS (fp[0])  #define rint(x) floor((x)+0.5)
 #endif  #endif
   
 #define DODOES  (symbols[3])  static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
   
 int emitcounter;  static Address up0=NULL;
 #define NULLC '\0'  
   
 #define cstr(to, from, size)\  /* if machine.h has not defined explicit registers, define them as implicit */
         {       memcpy(to, from, size);\  #ifndef IPREG
                 to[size]=NULLC;}  #define IPREG
 #define NEWLINE '\n'  #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
   
 static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};  /* 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 *ip, Cell *sp, Cell *rp, Float *fp)  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,
       /* 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"
       (Label)0
   };    };
 #ifndef DIRECT_THREADED  #ifdef CPU_DEP2
   Label ca;    CPU_DEP2
 #endif  #endif
   IF_TOS(register Cell TOS;)  
   IF_FTOS(Float FTOS;)  #ifdef DEBUG
 #ifdef CPU_DEP    fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
   CPU_DEP;            (unsigned)ip,(unsigned)sp,(unsigned)rp,
             (unsigned)fp,(unsigned)lp,(unsigned)up);
 #endif  #endif
   
   if (ip == NULL)    if (ip == NULL)
Line 111 
Line 233 
   
   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
   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
   */    */
   {    {
         DEF_CA
     Xt *current_ip = (Xt *)PFA1(cfa);      Xt *current_ip = (Xt *)PFA1(cfa);
     cfa = *current_ip;      cfa = *current_ip;
     NEXT1_P1;      NEXT1_P1;
     *--rp = (Cell)ip;      *--rp = (Cell)ip;
     ip = current_ip+1;      ip = current_ip+1;
   }  
   NEXT1_P2;    NEXT1_P2;
       }
   #endif
     }
   
  docon:   docon:
     {
       DOCFA;
 #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 147 
Line 282 
 #else  #else
   *--sp = *(Cell *)PFA1(cfa);    *--sp = *(Cell *)PFA1(cfa);
 #endif  #endif
     }
     NEXT_P0;
   NEXT;    NEXT;
   
  dovar:   dovar:
     {
       DOCFA;
 #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 159 
Line 298 
 #else  #else
   *--sp = (Cell)PFA1(cfa);    *--sp = (Cell)PFA1(cfa);
 #endif  #endif
     }
     NEXT_P0;
   NEXT;    NEXT;
   
   /* !! user? */   douser:
     {
       DOCFA;
   #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
     }
     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
       TOS += *(Cell*)PFA1(cfa);
     }
     NEXT_P0;
     NEXT;
   
  dodoes:   dodoes:
   /* this assumes the following structure:    /* this assumes the following structure:
Line 181 
Line 356 
      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
   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);      /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
     }
     NEXT_P0;
   NEXT;    NEXT;
   
 #include "primitives.i"  #include "primitives.i"

Generate output suitable for use with a patch program
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.39
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help