Annotation of gforth/engine.c, revision 1.33

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

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