File:  [gforth] / gforth / Attic / engine.c
Revision 1.31: download - view: text, annotated - select for diffs
Tue Nov 7 18:06:37 1995 UTC (25 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added copyright headers
changes to loadfilename & co. to make savesystem transparent to
 assertions and ~~

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

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