File:  [gforth] / gforth / Attic / engine.c
Revision 1.21: download - view: text, annotated - select for diffs
Thu Dec 15 12:35:14 1994 UTC (26 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Reimplemented [IF] [ELSE] [THEN] etc.
Corrected a bug concerning redefinitions in Kernal
Added config info for HP-PA
Added replacement for rint

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

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