Annotation of gforth/engine.c, revision 1.19

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

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