Annotation of gforth/engine.c, revision 1.21

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: 
1.20      anton      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: 
1.1       anton      24: typedef union {
                     25:   struct {
1.20      anton      26: #ifdef WORDS_BIGENDIAN
1.1       anton      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: 
1.14      anton      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
1.1       anton      54: #ifdef DIRECT_THREADED
1.14      anton      55: #define NEXT1_P2 ({goto *cfa;})
1.1       anton      56: #else
1.14      anton      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 */
1.1       anton      73: 
1.14      anton      74: #define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})
                     75: #define NEXT ({DEF_CA NEXT_P1; NEXT_P2;})
1.1       anton      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: 
1.14      anton      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: }
1.13      pazsan    122: 
1.1       anton     123: #define NEWLINE        '\n'
                    124: 
1.21    ! pazsan    125: #ifndef HAVE_RINT
        !           126: #define rint(x)        floor((x)+0.5)
        !           127: #endif
1.13      pazsan    128: 
1.1       anton     129: static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
1.6       pazsan    130: 
1.11      pazsan    131: static Address up0=NULL;
                    132: 
1.15      anton     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
1.13      pazsan    161: 
1.15      anton     162: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
1.1       anton     163: /* executes code at ip, if ip!=NULL
                    164:    returns array of machine code labels (for use in a loader), if ip==NULL
                    165: */
1.15      anton     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;)
1.1       anton     176:   static Label symbols[]= {
                    177:     &&docol,
                    178:     &&docon,
                    179:     &&dovar,
1.4       pazsan    180:     &&douser,
1.12      anton     181:     &&dodefer,
1.1       anton     182:     &&dodoes,
1.6       pazsan    183:     &&dodoes,  /* dummy for does handler address */
1.1       anton     184: #include "prim_labels.i"
                    185:   };
                    186: #ifdef CPU_DEP
                    187:   CPU_DEP;
                    188: #endif
                    189: 
1.16      pazsan    190: #ifdef DEBUG
                    191:   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
1.19      anton     192:           (unsigned)ip,(unsigned)sp,(unsigned)rp,
                    193:          (unsigned)fp,(unsigned)lp,(unsigned)up);
1.16      pazsan    194: #endif
                    195: 
1.1       anton     196:   if (ip == NULL)
                    197:     return symbols;
1.10      anton     198: 
1.1       anton     199:   IF_TOS(TOS = sp[0]);
                    200:   IF_FTOS(FTOS = fp[0]);
                    201:   prep_terminal();
                    202:   NEXT;
                    203:   
                    204:  docol:
                    205: #ifdef DEBUG
1.16      pazsan    206:   fprintf(stderr,"%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.1       anton     207: #endif
1.15      anton     208: #ifdef CISC_NEXT
1.1       anton     209:   /* this is the simple version */
                    210:   *--rp = (Cell)ip;
                    211:   ip = (Xt *)PFA1(cfa);
                    212:   NEXT;
1.15      anton     213: #else
1.1       anton     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:   {
1.4       pazsan    219:     DEF_CA
1.1       anton     220:     Xt *current_ip = (Xt *)PFA1(cfa);
                    221:     cfa = *current_ip;
                    222:     NEXT1_P1;
                    223:     *--rp = (Cell)ip;
                    224:     ip = current_ip+1;
1.3       pazsan    225:     NEXT1_P2;
1.1       anton     226:   }
1.15      anton     227: #endif
1.1       anton     228:   
                    229:  docon:
                    230: #ifdef DEBUG
1.16      pazsan    231:   fprintf(stderr,"%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));
1.1       anton     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
1.16      pazsan    243:   fprintf(stderr,"%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.1       anton     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:   
1.4       pazsan    255:  douser:
                    256: #ifdef DEBUG
1.16      pazsan    257:   fprintf(stderr,"%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.4       pazsan    258: #endif
                    259: #ifdef USE_TOS
                    260:   *sp-- = TOS;
1.5       anton     261:   TOS = (Cell)(up+*(Cell*)PFA1(cfa));
1.4       pazsan    262: #else
1.5       anton     263:   *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
1.4       pazsan    264: #endif
                    265:   NEXT;
                    266:   
1.12      anton     267:  dodefer:
                    268: #ifdef DEBUG
1.16      pazsan    269:   fprintf(stderr,"%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
1.12      anton     270: #endif
                    271:   cfa = *(Xt *)PFA1(cfa);
                    272:   NEXT1;
                    273: 
1.1       anton     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
1.17      anton     293:   fprintf(stderr,"%08x/%08x: does: %08x\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
1.16      pazsan    294:   fflush(stderr);
1.1       anton     295: #endif
                    296:   *--rp = (Cell)ip;
                    297:   /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
1.13      pazsan    298:   ip = DOES_CODE1(cfa);
1.1       anton     299: #ifdef USE_TOS
                    300:   *sp-- = TOS;
                    301:   TOS = (Cell)PFA(cfa);
                    302: #else
                    303:   *--sp = (Cell)PFA(cfa);
                    304: #endif
                    305:   NEXT;
1.16      pazsan    306: 
1.1       anton     307: #include "primitives.i"
                    308: }

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