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>