File:  [gforth] / gforth / Attic / engine.c
Revision 1.24: download - view: text, annotated - select for diffs
Thu Feb 23 20:17:18 1995 UTC (26 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added structure support in kernal
fixed bug on dictionary expand (512 wordlist limit)

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

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