Return to engine.c CVS log

Up to [gforth] / gforth

?DUP-IF and ?DUP-0=-IF are now supported by primitives
added primitives EMIT-FILE, STDOUT, STDERR
EMIT and TYPE now work through file words
added some code for the BUGGY_LONG_LONG case (not yet complete)
eliminated D! and D@
made DMIN, DMAX, DABS high-level
added compat/control.fs (?DUP-IF etc.)

    1: /* Gforth virtual machine (aka inner interpreter)
    2: 
    3:   Copyright (C) 1995 Free Software Foundation, Inc.
    4: 
    5:   This file is part of Gforth.
    6: 
    7:   Gforth is free software; you can redistribute it and/or
    8:   modify it under the terms of the GNU General Public License
    9:   as published by the Free Software Foundation; either version 2
   10:   of the License, or (at your option) any later version.
   11: 
   12:   This program is distributed in the hope that it will be useful,
   13:   but WITHOUT ANY WARRANTY; without even the implied warranty of
   14:   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15:   GNU General Public License for more details.
   16: 
   17:   You should have received a copy of the GNU General Public License
   18:   along with this program; if not, write to the Free Software
   19:   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: */
   21: 
   22: #include "config.h"
   23: #include <ctype.h>
   24: #include <stdio.h>
   25: #include <string.h>
   26: #include <math.h>
   27: #include <sys/types.h>
   28: #include <sys/stat.h>
   29: #include <fcntl.h>
   30: #include <assert.h>
   31: #include <stdlib.h>
   32: #include <time.h>
   33: #include <sys/time.h>
   34: #include <unistd.h>
   35: #include <errno.h>
   36: #include <pwd.h>
   37: #include "forth.h"
   38: #include "io.h"
   39: #include "threading.h"
   40: 
   41: #ifndef SEEK_SET
   42: /* should be defined in stdio.h, but some systems don't have it */
   43: #define SEEK_SET 0
   44: #endif
   45: 
   46: #define IOR(flag)	((flag)? -512-errno : 0)
   47: 
   48: typedef union {
   49:   struct {
   50: #ifdef WORDS_BIGENDIAN
   51:     Cell high;
   52:     UCell low;
   53: #else
   54:     UCell low;
   55:     Cell high;
   56: #endif;
   57:   } cells;
   58:   DCell dcell;
   59: } Double_Store;
   60: 
   61: typedef struct F83Name {
   62:   struct F83Name	*next;  /* the link field for old hands */
   63:   char			countetc;
   64:   Char			name[0];
   65: } F83Name;
   66: 
   67: /* are macros for setting necessary? */
   68: #define F83NAME_COUNT(np)	((np)->countetc & 0x1f)
   69: #define F83NAME_SMUDGE(np)	(((np)->countetc & 0x40) != 0)
   70: #define F83NAME_IMMEDIATE(np)	(((np)->countetc & 0x20) != 0)
   71: 
   72: #ifdef USE_TOS
   73: #define IF_TOS(x) x
   74: #else
   75: #define IF_TOS(x)
   76: #define TOS (sp[0])
   77: #endif
   78: 
   79: #ifdef USE_FTOS
   80: #define IF_FTOS(x) x
   81: #else
   82: #define IF_FTOS(x)
   83: #define FTOS (fp[0])
   84: #endif
   85: 
   86: Cell *SP;
   87: Float *FP;
   88: #if 0
   89: /* not used currently */
   90: int emitcounter;
   91: #endif
   92: #define NULLC '\0'
   93: 
   94: char *cstr(Char *from, UCell size, int clear)
   95: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
   96:    the C-string lives until the next call of cstr with CLEAR being true */
   97: {
   98:   static struct cstr_buffer {
   99:     char *buffer;
  100:     size_t size;
  101:   } *buffers=NULL;
  102:   static int nbuffers=0;
  103:   static int used=0;
  104:   struct cstr_buffer *b;
  105: 
  106:   if (buffers==NULL)
  107:     buffers=malloc(0);
  108:   if (clear)
  109:     used=0;
  110:   if (used>=nbuffers) {
  111:     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
  112:     buffers[used]=(struct cstr_buffer){malloc(0),0};
  113:     nbuffers=used+1;
  114:   }
  115:   b=&buffers[used];
  116:   if (size+1 > b->size) {
  117:     b->buffer = realloc(b->buffer,size+1);
  118:     b->size = size+1;
  119:   }
  120:   memcpy(b->buffer,from,size);
  121:   b->buffer[size]='\0';
  122:   used++;
  123:   return b->buffer;
  124: }
  125: 
  126: char *tilde_cstr(Char *from, UCell size, int clear)
  127: /* like cstr(), but perform tilde expansion on the string */
  128: {
  129:   char *s1,*s2;
  130:   int s1_len, s2_len;
  131:   struct passwd *getpwnam (), *user_entry;
  132: 
  133:   if (size<1 || from[0]!='~')
  134:     return cstr(from, size, clear);
  135:   if (size<2 || from[1]=='/') {
  136:     s1 = (char *)getenv ("HOME");
  137:     s2 = from+1;
  138:     s2_len = size-1;
  139:   } else {
  140:     int i;
  141:     for (i=1; i<size && from[i]!='/'; i++)
  142:       ;
  143:     {
  144:       char user[i];
  145:       memcpy(user,from+1,i-1);
  146:       user[i-1]='\0';
  147:       user_entry=getpwnam(user);
  148:     }
  149:     if (user_entry==NULL)
  150:       return cstr(from, size, clear);
  151:     s1 = user_entry->pw_dir;
  152:     s2 = from+i;
  153:     s2_len = size-i;
  154:   }
  155:   s1_len = strlen(s1);
  156:   if (s1_len>1 && s1[s1_len-1]=='/')
  157:     s1_len--;
  158:   {
  159:     char path[s1_len+s2_len];
  160:     memcpy(path,s1,s1_len);
  161:     memcpy(path+s1_len,s2,s2_len);
  162:     return cstr(path,s1_len+s2_len,clear);
  163:   }
  164: }
  165:    
  166: 
  167: #define NEWLINE	'\n'
  168: 
  169: #ifndef HAVE_RINT
  170: #define rint(x)	floor((x)+0.5)
  171: #endif
  172: 
  173: static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
  174: 
  175: static Address up0=NULL;
  176: 
  177: /* if machine.h has not defined explicit registers, define them as implicit */
  178: #ifndef IPREG
  179: #define IPREG
  180: #endif
  181: #ifndef SPREG
  182: #define SPREG
  183: #endif
  184: #ifndef RPREG
  185: #define RPREG
  186: #endif
  187: #ifndef FPREG
  188: #define FPREG
  189: #endif
  190: #ifndef LPREG
  191: #define LPREG
  192: #endif
  193: #ifndef CFAREG
  194: #define CFAREG
  195: #endif
  196: #ifndef UPREG
  197: #define UPREG
  198: #endif
  199: #ifndef TOSREG
  200: #define TOSREG
  201: #endif
  202: #ifndef FTOSREG
  203: #define FTOSREG
  204: #endif
  205: 
  206: /* declare and compute cfa for certain threading variants */
  207: /* warning: this is nonsyntactical; it will not work in place of a statement */
  208: #ifdef CFA_NEXT
  209: #define DOCFA
  210: #else
  211: #define DOCFA	Xt cfa; GETCFA(cfa)
  212: #endif
  213: 
  214: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
  215: /* executes code at ip, if ip!=NULL
  216:    returns array of machine code labels (for use in a loader), if ip==NULL
  217: */
  218: {
  219:   register Xt *ip IPREG = ip0;
  220:   register Cell *sp SPREG = sp0;
  221:   register Cell *rp RPREG = rp0;
  222:   register Float *fp FPREG = fp0;
  223:   register Address lp LPREG = lp0;
  224: #ifdef CFA_NEXT
  225:   register Xt cfa CFAREG;
  226: #endif
  227:   register Address up UPREG = up0;
  228:   IF_TOS(register Cell TOS TOSREG;)
  229:   IF_FTOS(register Float FTOS FTOSREG;)
  230:   static Label symbols[]= {
  231:     &&docol,
  232:     &&docon,
  233:     &&dovar,
  234:     &&douser,
  235:     &&dodefer,
  236:     &&dofield,
  237:     &&dodoes,
  238:     /* the following entry is normally unused;
  239:        it's there because its index indicates a does-handler */
  240: #ifdef CPU_DEP1
  241:     CPU_DEP1,
  242: #else
  243:     (Label)0,
  244: #endif
  245: #include "prim_labels.i"
  246:   };
  247: #ifdef CPU_DEP2
  248:   CPU_DEP2
  249: #endif
  250: 
  251: #ifdef DEBUG
  252:   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
  253:           (unsigned)ip,(unsigned)sp,(unsigned)rp,
  254: 	  (unsigned)fp,(unsigned)lp,(unsigned)up);
  255: #endif
  256: 
  257:   if (ip == NULL)
  258:     return symbols;
  259: 
  260:   IF_TOS(TOS = sp[0]);
  261:   IF_FTOS(FTOS = fp[0]);
  262: /*  prep_terminal(); */
  263:   NEXT_P0;
  264:   NEXT;
  265: 
  266: #ifdef CPU_DEP3
  267:   CPU_DEP3
  268: #endif
  269:   
  270:  docol:
  271:   {
  272:     DOCFA;
  273: #ifdef DEBUG
  274:     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  275: #endif
  276: #ifdef CISC_NEXT
  277:     /* this is the simple version */
  278:     *--rp = (Cell)ip;
  279:     ip = (Xt *)PFA1(cfa);
  280:     NEXT_P0;
  281:     NEXT;
  282: #else
  283:     /* this one is important, so we help the compiler optimizing
  284:        The following version may be better (for scheduling), but probably has
  285:        problems with code fields employing calls and delay slots
  286:        */
  287:     {
  288:       DEF_CA
  289:       Xt *current_ip = (Xt *)PFA1(cfa);
  290:       cfa = *current_ip;
  291:       NEXT1_P1;
  292:       *--rp = (Cell)ip;
  293:       ip = current_ip+1;
  294:       NEXT1_P2;
  295:     }
  296: #endif
  297:   }
  298: 
  299:  docon:
  300:   {
  301:     DOCFA;
  302: #ifdef DEBUG
  303:     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  304: #endif
  305: #ifdef USE_TOS
  306:     *sp-- = TOS;
  307:     TOS = *(Cell *)PFA1(cfa);
  308: #else
  309:     *--sp = *(Cell *)PFA1(cfa);
  310: #endif
  311:   }
  312:   NEXT_P0;
  313:   NEXT;
  314:   
  315:  dovar:
  316:   {
  317:     DOCFA;
  318: #ifdef DEBUG
  319:     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  320: #endif
  321: #ifdef USE_TOS
  322:     *sp-- = TOS;
  323:     TOS = (Cell)PFA1(cfa);
  324: #else
  325:     *--sp = (Cell)PFA1(cfa);
  326: #endif
  327:   }
  328:   NEXT_P0;
  329:   NEXT;
  330:   
  331:  douser:
  332:   {
  333:     DOCFA;
  334: #ifdef DEBUG
  335:     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  336: #endif
  337: #ifdef USE_TOS
  338:     *sp-- = TOS;
  339:     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
  340: #else
  341:     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
  342: #endif
  343:   }
  344:   NEXT_P0;
  345:   NEXT;
  346:   
  347:  dodefer:
  348:   {
  349:     DOCFA;
  350: #ifdef DEBUG
  351:     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
  352: #endif
  353:     EXEC(*(Xt *)PFA1(cfa));
  354:   }
  355: 
  356:  dofield:
  357:   {
  358:     DOCFA;
  359: #ifdef DEBUG
  360:     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
  361: #endif
  362:     TOS += *(Cell*)PFA1(cfa); 
  363:   }
  364:   NEXT_P0;
  365:   NEXT;
  366: 
  367:  dodoes:
  368:   /* this assumes the following structure:
  369:      defining-word:
  370:      
  371:      ...
  372:      DOES>
  373:      (possible padding)
  374:      possibly handler: jmp dodoes
  375:      (possible branch delay slot(s))
  376:      Forth code after DOES>
  377:      
  378:      defined word:
  379:      
  380:      cfa: address of or jump to handler OR
  381:           address of or jump to dodoes, address of DOES-code
  382:      pfa:
  383:      
  384:      */
  385:   {
  386:     DOCFA;
  387: 
  388:     /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
  389: #ifdef DEBUG
  390:     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
  391:     fflush(stderr);
  392: #endif
  393:     *--rp = (Cell)ip;
  394:     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
  395:     ip = DOES_CODE1(cfa);
  396: #ifdef USE_TOS
  397:     *sp-- = TOS;
  398:     TOS = (Cell)PFA(cfa);
  399: #else
  400:     *--sp = (Cell)PFA(cfa);
  401: #endif
  402:     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
  403:   }
  404:   NEXT_P0;
  405:   NEXT;
  406: 
  407: #include "primitives.i"
  408: }