Return to engine.c CVS log

Up to [gforth] / gforth

fixed bug in resize ("0 n resize" is now equivalent to "n allocate")
added primitives call-c and strerror
most primitives producing iors now produce error numbers derived from OS error
  numbers (EAGAIN and its kin)
.error now prints OS error messages for OS-derived error numbers.
primitives working with ferror now call clearerr
added a bit of documentation to glocals.fs to satisfy TeX
added definition of CC to Makefile.in again

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