Annotation of gforth/engine.c, revision 1.30

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

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