File:  [gforth] / gforth / Attic / engine.c
Revision 1.30: download - view: text, annotated - select for diffs
Thu Oct 26 22:48:39 1995 UTC (25 years, 11 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Changed threading ifdefs.
Requires debugging !!!!!!
Perhaps change concepts with LONG_LATENCY
on RISCs.
Added sokoban.fs as a nice little game.

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

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