Annotation of gforth/engine/engine.c, revision 1.1

1.1     ! 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.
        !            20: */
        !            21: 
        !            22: #include "config.h"
        !            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>
        !            32: #include <time.h>
        !            33: #include <sys/time.h>
        !            34: #include <unistd.h>
        !            35: #include <errno.h>
        !            36: #include <pwd.h>
        !            37: #include "forth.h"
        !            38: #include "io.h"
        !            39: #include "threaded.h"
        !            40: 
        !            41: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
        !            42: #include <dlfcn.h>
        !            43: #endif
        !            44: #ifdef hpux
        !            45: #include <dl.h>
        !            46: #endif
        !            47: 
        !            48: #ifndef SEEK_SET
        !            49: /* should be defined in stdio.h, but some systems don't have it */
        !            50: #define SEEK_SET 0
        !            51: #endif
        !            52: 
        !            53: #define IOR(flag)      ((flag)? -512-errno : 0)
        !            54: 
        !            55: typedef struct F83Name {
        !            56:   struct F83Name       *next;  /* the link field for old hands */
        !            57:   char                 countetc;
        !            58:   Char                 name[0];
        !            59: } F83Name;
        !            60: 
        !            61: /* are macros for setting necessary? */
        !            62: #define F83NAME_COUNT(np)      ((np)->countetc & 0x1f)
        !            63: #define F83NAME_SMUDGE(np)     (((np)->countetc & 0x40) != 0)
        !            64: #define F83NAME_IMMEDIATE(np)  (((np)->countetc & 0x20) != 0)
        !            65: 
        !            66: Cell *SP;
        !            67: Float *FP;
        !            68: Address UP=NULL;
        !            69: 
        !            70: #if 0
        !            71: /* not used currently */
        !            72: int emitcounter;
        !            73: #endif
        !            74: #define NULLC '\0'
        !            75: 
        !            76: char *cstr(Char *from, UCell size, int clear)
        !            77: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
        !            78:    the C-string lives until the next call of cstr with CLEAR being true */
        !            79: {
        !            80:   static struct cstr_buffer {
        !            81:     char *buffer;
        !            82:     size_t size;
        !            83:   } *buffers=NULL;
        !            84:   static int nbuffers=0;
        !            85:   static int used=0;
        !            86:   struct cstr_buffer *b;
        !            87: 
        !            88:   if (buffers==NULL)
        !            89:     buffers=malloc(0);
        !            90:   if (clear)
        !            91:     used=0;
        !            92:   if (used>=nbuffers) {
        !            93:     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
        !            94:     buffers[used]=(struct cstr_buffer){malloc(0),0};
        !            95:     nbuffers=used+1;
        !            96:   }
        !            97:   b=&buffers[used];
        !            98:   if (size+1 > b->size) {
        !            99:     b->buffer = realloc(b->buffer,size+1);
        !           100:     b->size = size+1;
        !           101:   }
        !           102:   memcpy(b->buffer,from,size);
        !           103:   b->buffer[size]='\0';
        !           104:   used++;
        !           105:   return b->buffer;
        !           106: }
        !           107: 
        !           108: char *tilde_cstr(Char *from, UCell size, int clear)
        !           109: /* like cstr(), but perform tilde expansion on the string */
        !           110: {
        !           111:   char *s1,*s2;
        !           112:   int s1_len, s2_len;
        !           113:   struct passwd *getpwnam (), *user_entry;
        !           114: 
        !           115:   if (size<1 || from[0]!='~')
        !           116:     return cstr(from, size, clear);
        !           117:   if (size<2 || from[1]=='/') {
        !           118:     s1 = (char *)getenv ("HOME");
        !           119:     if(s1 == NULL)
        !           120:       s1 = "";
        !           121:     s2 = from+1;
        !           122:     s2_len = size-1;
        !           123:   } else {
        !           124:     UCell i;
        !           125:     for (i=1; i<size && from[i]!='/'; i++)
        !           126:       ;
        !           127:     {
        !           128:       char user[i];
        !           129:       memcpy(user,from+1,i-1);
        !           130:       user[i-1]='\0';
        !           131:       user_entry=getpwnam(user);
        !           132:     }
        !           133:     if (user_entry==NULL)
        !           134:       return cstr(from, size, clear);
        !           135:     s1 = user_entry->pw_dir;
        !           136:     s2 = from+i;
        !           137:     s2_len = size-i;
        !           138:   }
        !           139:   s1_len = strlen(s1);
        !           140:   if (s1_len>1 && s1[s1_len-1]=='/')
        !           141:     s1_len--;
        !           142:   {
        !           143:     char path[s1_len+s2_len];
        !           144:     memcpy(path,s1,s1_len);
        !           145:     memcpy(path+s1_len,s2,s2_len);
        !           146:     return cstr(path,s1_len+s2_len,clear);
        !           147:   }
        !           148: }
        !           149:    
        !           150: 
        !           151: #define NEWLINE        '\n'
        !           152: 
        !           153: #ifndef HAVE_RINT
        !           154: #define rint(x)        floor((x)+0.5)
        !           155: #endif
        !           156: 
        !           157: static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
        !           158: 
        !           159: #ifndef O_BINARY
        !           160: #define O_BINARY 0
        !           161: #endif
        !           162: #ifndef O_TEXT
        !           163: #define O_TEXT 0
        !           164: #endif
        !           165: 
        !           166: static int ufileattr[6]= {
        !           167:   O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,
        !           168:   O_RDWR  |O_TEXT, O_RDWR  |O_BINARY,
        !           169:   O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };
        !           170: 
        !           171: /* if machine.h has not defined explicit registers, define them as implicit */
        !           172: #ifndef IPREG
        !           173: #define IPREG
        !           174: #endif
        !           175: #ifndef SPREG
        !           176: #define SPREG
        !           177: #endif
        !           178: #ifndef RPREG
        !           179: #define RPREG
        !           180: #endif
        !           181: #ifndef FPREG
        !           182: #define FPREG
        !           183: #endif
        !           184: #ifndef LPREG
        !           185: #define LPREG
        !           186: #endif
        !           187: #ifndef CFAREG
        !           188: #define CFAREG
        !           189: #endif
        !           190: #ifndef UPREG
        !           191: #define UPREG
        !           192: #endif
        !           193: #ifndef TOSREG
        !           194: #define TOSREG
        !           195: #endif
        !           196: #ifndef FTOSREG
        !           197: #define FTOSREG
        !           198: #endif
        !           199: 
        !           200: #ifndef CPU_DEP1
        !           201: # define CPU_DEP1 0
        !           202: #endif
        !           203: 
        !           204: /* declare and compute cfa for certain threading variants */
        !           205: /* warning: this is nonsyntactical; it will not work in place of a statement */
        !           206: #ifdef CFA_NEXT
        !           207: #define DOCFA
        !           208: #else
        !           209: #define DOCFA  Xt cfa; GETCFA(cfa)
        !           210: #endif
        !           211: 
        !           212: Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
        !           213: /* executes code at ip, if ip!=NULL
        !           214:    returns array of machine code labels (for use in a loader), if ip==NULL
        !           215: */
        !           216: {
        !           217:   register Xt *ip IPREG = ip0;
        !           218:   register Cell *sp SPREG = sp0;
        !           219:   register Cell *rp RPREG = rp0;
        !           220:   register Float *fp FPREG = fp0;
        !           221:   register Address lp LPREG = lp0;
        !           222: #ifdef CFA_NEXT
        !           223:   register Xt cfa CFAREG;
        !           224: #endif
        !           225:   register Address up UPREG = UP;
        !           226:   IF_TOS(register Cell TOS TOSREG;)
        !           227:   IF_FTOS(register Float FTOS FTOSREG;)
        !           228: #if defined(DOUBLY_INDIRECT)
        !           229:   static Label *symbols;
        !           230:   static void *routines[]= {
        !           231: #else /* !defined(DOUBLY_INDIRECT) */
        !           232:   static Label symbols[]= {
        !           233: #endif /* !defined(DOUBLY_INDIRECT) */
        !           234:     &&docol,
        !           235:     &&docon,
        !           236:     &&dovar,
        !           237:     &&douser,
        !           238:     &&dodefer,
        !           239:     &&dofield,
        !           240:     &&dodoes,
        !           241:     /* the following entry is normally unused;
        !           242:        it's there because its index indicates a does-handler */
        !           243:     CPU_DEP1,
        !           244: #include "prim_lab.i"
        !           245:     0
        !           246:   };
        !           247: #ifdef CPU_DEP2
        !           248:   CPU_DEP2
        !           249: #endif
        !           250: 
        !           251: #ifdef DEBUG
        !           252:   fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
        !           253:           (unsigned)ip,(unsigned)sp,(unsigned)rp,
        !           254:          (unsigned)fp,(unsigned)lp,(unsigned)up);
        !           255: #endif
        !           256: 
        !           257:   if (ip == NULL) {
        !           258: #if defined(DOUBLY_INDIRECT)
        !           259: #define MAX_SYMBOLS 1000
        !           260:     int i;
        !           261:     Cell code_offset = offset_image? 11*sizeof(Cell) : 0;
        !           262: 
        !           263:     symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+code_offset)+code_offset);
        !           264:     for (i=0; i<DOESJUMP+1; i++)
        !           265:       symbols[i] = (Label)routines[i];
        !           266:     for (; routines[i]!=0; i++) {
        !           267:       if (i>=MAX_SYMBOLS) {
        !           268:        fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
        !           269:        exit(1);
        !           270:     }
        !           271:     symbols[i] = &routines[i];
        !           272:   }
        !           273: #endif /* defined(DOUBLY_INDIRECT) */
        !           274:   return symbols;
        !           275: }
        !           276: 
        !           277:   IF_TOS(TOS = sp[0]);
        !           278:   IF_FTOS(FTOS = fp[0]);
        !           279: /*  prep_terminal(); */
        !           280:   NEXT_P0;
        !           281:   NEXT;
        !           282: 
        !           283: #ifdef CPU_DEP3
        !           284:   CPU_DEP3
        !           285: #endif
        !           286:   
        !           287:  docol:
        !           288:   {
        !           289:     DOCFA;
        !           290: #ifdef DEBUG
        !           291:     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
        !           292: #endif
        !           293: #ifdef CISC_NEXT
        !           294:     /* this is the simple version */
        !           295:     *--rp = (Cell)ip;
        !           296:     ip = (Xt *)PFA1(cfa);
        !           297:     NEXT_P0;
        !           298:     NEXT;
        !           299: #else
        !           300:     /* this one is important, so we help the compiler optimizing
        !           301:        The following version may be better (for scheduling), but probably has
        !           302:        problems with code fields employing calls and delay slots
        !           303:        */
        !           304:     {
        !           305:       DEF_CA
        !           306:       Xt *current_ip = (Xt *)PFA1(cfa);
        !           307:       cfa = *current_ip;
        !           308:       NEXT1_P1;
        !           309:       *--rp = (Cell)ip;
        !           310:       ip = current_ip+1;
        !           311:       NEXT1_P2;
        !           312:     }
        !           313: #endif
        !           314:   }
        !           315: 
        !           316:  docon:
        !           317:   {
        !           318:     DOCFA;
        !           319: #ifdef DEBUG
        !           320:     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
        !           321: #endif
        !           322: #ifdef USE_TOS
        !           323:     *sp-- = TOS;
        !           324:     TOS = *(Cell *)PFA1(cfa);
        !           325: #else
        !           326:     *--sp = *(Cell *)PFA1(cfa);
        !           327: #endif
        !           328:   }
        !           329:   NEXT_P0;
        !           330:   NEXT;
        !           331:   
        !           332:  dovar:
        !           333:   {
        !           334:     DOCFA;
        !           335: #ifdef DEBUG
        !           336:     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
        !           337: #endif
        !           338: #ifdef USE_TOS
        !           339:     *sp-- = TOS;
        !           340:     TOS = (Cell)PFA1(cfa);
        !           341: #else
        !           342:     *--sp = (Cell)PFA1(cfa);
        !           343: #endif
        !           344:   }
        !           345:   NEXT_P0;
        !           346:   NEXT;
        !           347:   
        !           348:  douser:
        !           349:   {
        !           350:     DOCFA;
        !           351: #ifdef DEBUG
        !           352:     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
        !           353: #endif
        !           354: #ifdef USE_TOS
        !           355:     *sp-- = TOS;
        !           356:     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
        !           357: #else
        !           358:     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
        !           359: #endif
        !           360:   }
        !           361:   NEXT_P0;
        !           362:   NEXT;
        !           363:   
        !           364:  dodefer:
        !           365:   {
        !           366:     DOCFA;
        !           367: #ifdef DEBUG
        !           368:     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
        !           369: #endif
        !           370:     EXEC(*(Xt *)PFA1(cfa));
        !           371:   }
        !           372: 
        !           373:  dofield:
        !           374:   {
        !           375:     DOCFA;
        !           376: #ifdef DEBUG
        !           377:     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
        !           378: #endif
        !           379:     TOS += *(Cell*)PFA1(cfa); 
        !           380:   }
        !           381:   NEXT_P0;
        !           382:   NEXT;
        !           383: 
        !           384:  dodoes:
        !           385:   /* this assumes the following structure:
        !           386:      defining-word:
        !           387:      
        !           388:      ...
        !           389:      DOES>
        !           390:      (possible padding)
        !           391:      possibly handler: jmp dodoes
        !           392:      (possible branch delay slot(s))
        !           393:      Forth code after DOES>
        !           394:      
        !           395:      defined word:
        !           396:      
        !           397:      cfa: address of or jump to handler OR
        !           398:           address of or jump to dodoes, address of DOES-code
        !           399:      pfa:
        !           400:      
        !           401:      */
        !           402:   {
        !           403:     DOCFA;
        !           404: 
        !           405:     /*    fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
        !           406: #ifdef DEBUG
        !           407:     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
        !           408:     fflush(stderr);
        !           409: #endif
        !           410:     *--rp = (Cell)ip;
        !           411:     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
        !           412:     ip = DOES_CODE1(cfa);
        !           413: #ifdef USE_TOS
        !           414:     *sp-- = TOS;
        !           415:     TOS = (Cell)PFA(cfa);
        !           416: #else
        !           417:     *--sp = (Cell)PFA(cfa);
        !           418: #endif
        !           419:     /*    fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
        !           420:   }
        !           421:   NEXT_P0;
        !           422:   NEXT;
        !           423: 
        !           424: #include "prim.i"
        !           425: }

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