--- gforth/Attic/engine.c 1994/08/31 19:42:44 1.13 +++ gforth/Attic/engine.c 1997/03/04 17:49:48 1.41 @@ -1,8 +1,25 @@ -/* - $Id: engine.c,v 1.13 1994/08/31 19:42:44 pazsan Exp $ - Copyright 1992 by the ANSI figForth Development Group +/* Gforth virtual machine (aka inner interpreter) + + Copyright (C) 1995 Free Software Foundation, Inc. + + This file is part of Gforth. + + Gforth is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ +#include "config.h" #include #include #include @@ -14,21 +31,19 @@ #include #include #include +#include +#include +#include #include "forth.h" #include "io.h" +#include "threading.h" -typedef union { - struct { -#ifdef BIG_ENDIAN - Cell high; - Cell low; -#else - Cell low; - Cell high; -#endif; - } cells; - DCell dcell; -} Double_Store; +#ifndef SEEK_SET +/* should be defined in stdio.h, but some systems don't have it */ +#define SEEK_SET 0 +#endif + +#define IOR(flag) ((flag)? -512-errno : 0) typedef struct F83Name { struct F83Name *next; /* the link field for old hands */ @@ -41,196 +56,323 @@ typedef struct F83Name { #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0) #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0) -/* NEXT and NEXT1 are split into several parts to help scheduling */ -#ifdef DIRECT_THREADED -# define NEXT1_P1 -# ifdef i386 -# define NEXT1_P2 ({cfa=*ip++; goto *cfa;}) -# else -# define NEXT1_P2 ({goto *cfa;}) -# endif -# define DEF_CA -#else -# define NEXT1_P1 ({ca = *cfa;}) -# define NEXT1_P2 ({goto *ca;}) -# define DEF_CA Label ca; -#endif -#if defined(i386) && defined(DIRECT_THREADED) -# define NEXT_P1 -# define NEXT1 ({goto *cfa;}) -#else -# define NEXT_P1 ({cfa = *ip++; NEXT1_P1;}) -# define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;}) -#endif - -#define NEXT ({DEF_CA NEXT_P1; NEXT1_P2;}) - -#ifdef USE_TOS -#define IF_TOS(x) x -#else -#define IF_TOS(x) -#define TOS (sp[0]) -#endif - -#ifdef USE_FTOS -#define IF_FTOS(x) x -#else -#define IF_FTOS(x) -#define FTOS (fp[0]) -#endif +Cell *SP; +Float *FP; +Address UP=NULL; +#if 0 +/* not used currently */ int emitcounter; +#endif #define NULLC '\0' -#ifdef copycstr -# define cstr(to,from,size)\ - { memcpy(to,from,size);\ - to[size]=NULLC;} -#else -char scratch[1024]; -int soffset; -# define cstr(from,size) \ - ({ char * to = scratch; \ - memcpy(to,from,size); \ - to[size] = NULLC; \ - soffset = size+1; \ - to; \ - }) -# define cstr1(from,size) \ - ({ char * to = scratch+soffset; \ - memcpy(to,from,size); \ - to[size] = NULLC; \ - soffset += size+1; \ - to; \ - }) -#endif +char *cstr(Char *from, UCell size, int clear) +/* return a C-string corresponding to the Forth string ( FROM SIZE ). + the C-string lives until the next call of cstr with CLEAR being true */ +{ + static struct cstr_buffer { + char *buffer; + size_t size; + } *buffers=NULL; + static int nbuffers=0; + static int used=0; + struct cstr_buffer *b; + + if (buffers==NULL) + buffers=malloc(0); + if (clear) + used=0; + if (used>=nbuffers) { + buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1)); + buffers[used]=(struct cstr_buffer){malloc(0),0}; + nbuffers=used+1; + } + b=&buffers[used]; + if (size+1 > b->size) { + b->buffer = realloc(b->buffer,size+1); + b->size = size+1; + } + memcpy(b->buffer,from,size); + b->buffer[size]='\0'; + used++; + return b->buffer; +} + +char *tilde_cstr(Char *from, UCell size, int clear) +/* like cstr(), but perform tilde expansion on the string */ +{ + char *s1,*s2; + int s1_len, s2_len; + struct passwd *getpwnam (), *user_entry; + + if (size<1 || from[0]!='~') + return cstr(from, size, clear); + if (size<2 || from[1]=='/') { + s1 = (char *)getenv ("HOME"); + if(s1 == NULL) + s1 = ""; + s2 = from+1; + s2_len = size-1; + } else { + UCell i; + for (i=1; ipw_dir; + s2 = from+i; + s2_len = size-i; + } + s1_len = strlen(s1); + if (s1_len>1 && s1[s1_len-1]=='/') + s1_len--; + { + char path[s1_len+s2_len]; + memcpy(path,s1,s1_len); + memcpy(path+s1_len,s2,s2_len); + return cstr(path,s1_len+s2_len,clear); + } +} + #define NEWLINE '\n' +#ifndef HAVE_RINT +#define rint(x) floor((x)+0.5) +#endif -static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"}; +static char* fileattr[6]={"r","rb","r+","r+b","w","wb"}; -static Address up0=NULL; +#ifndef O_BINARY +#define O_BINARY 0 +#endif +#ifndef O_TEXT +#define O_TEXT 0 +#endif -#if defined(i386) && defined(FORCE_REG) -# define REG(reg) __asm__(reg) +static int ufileattr[6]= { + O_RDONLY|O_TEXT, O_RDONLY|O_BINARY, + O_RDWR |O_TEXT, O_RDWR |O_BINARY, + O_WRONLY|O_TEXT, O_WRONLY|O_BINARY }; -Label *engine(Xt *ip0, Cell *sp0, Cell *rp, Float *fp, Address lp) -{ - register Xt *ip REG("%esi")=ip0; - register Cell *sp REG("%edi")=sp0; +/* if machine.h has not defined explicit registers, define them as implicit */ +#ifndef IPREG +#define IPREG +#endif +#ifndef SPREG +#define SPREG +#endif +#ifndef RPREG +#define RPREG +#endif +#ifndef FPREG +#define FPREG +#endif +#ifndef LPREG +#define LPREG +#endif +#ifndef CFAREG +#define CFAREG +#endif +#ifndef UPREG +#define UPREG +#endif +#ifndef TOSREG +#define TOSREG +#endif +#ifndef FTOSREG +#define FTOSREG +#endif -#else -# define REG(reg) +#ifndef CPU_DEP1 +# define CPU_DEP1 0 +#endif -Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp) -{ +/* declare and compute cfa for certain threading variants */ +/* warning: this is nonsyntactical; it will not work in place of a statement */ +#ifdef CFA_NEXT +#define DOCFA +#else +#define DOCFA Xt cfa; GETCFA(cfa) #endif + +Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0) /* executes code at ip, if ip!=NULL returns array of machine code labels (for use in a loader), if ip==NULL */ - register Xt cfa -#ifdef i386 -# ifdef USE_TOS - REG("%ecx") -# else - REG("%edx") -# endif -#endif - ; - Address up=up0; +{ + register Xt *ip IPREG = ip0; + register Cell *sp SPREG = sp0; + register Cell *rp RPREG = rp0; + register Float *fp FPREG = fp0; + register Address lp LPREG = lp0; +#ifdef CFA_NEXT + register Xt cfa CFAREG; +#endif + register Address up UPREG = UP; + IF_TOS(register Cell TOS TOSREG;) + IF_FTOS(register Float FTOS FTOSREG;) +#if defined(DOUBLY_INDIRECT) + static Label *symbols; + static void *routines[]= { +#else /* !defined(DOUBLY_INDIRECT) */ static Label symbols[]= { +#endif /* !defined(DOUBLY_INDIRECT) */ &&docol, &&docon, &&dovar, &&douser, &&dodefer, + &&dofield, &&dodoes, - &&dodoes, /* dummy for does handler address */ + /* the following entry is normally unused; + it's there because its index indicates a does-handler */ + CPU_DEP1, #include "prim_labels.i" + 0 }; - IF_TOS(register Cell TOS;) - IF_FTOS(Float FTOS;) -#ifdef CPU_DEP - CPU_DEP; +#ifdef CPU_DEP2 + CPU_DEP2 #endif - if (ip == NULL) - return symbols; +#ifdef DEBUG + fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n", + (unsigned)ip,(unsigned)sp,(unsigned)rp, + (unsigned)fp,(unsigned)lp,(unsigned)up); +#endif + + if (ip == NULL) { +#if defined(DOUBLY_INDIRECT) +#define MAX_SYMBOLS 1000 + int i; + Cell code_offset = offset_image? 11*sizeof(Cell) : 0; + + symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+code_offset)+code_offset); + for (i=0; i=MAX_SYMBOLS) { + fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS); + exit(1); + } + symbols[i] = &routines[i]; + } +#endif /* defined(DOUBLY_INDIRECT) */ + return symbols; +} IF_TOS(TOS = sp[0]); IF_FTOS(FTOS = fp[0]); - prep_terminal(); +/* prep_terminal(); */ + NEXT_P0; NEXT; + +#ifdef CPU_DEP3 + CPU_DEP3 +#endif docol: + { + DOCFA; #ifdef DEBUG - printf("%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa)); -#endif -#ifdef i386 - /* this is the simple version */ - *--rp = (Cell)ip; - ip = (Xt *)PFA1(cfa); - NEXT; + fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif - /* this one is important, so we help the compiler optimizing - The following version may be better (for scheduling), but probably has - problems with code fields employing calls and delay slots - */ - { - DEF_CA - Xt *current_ip = (Xt *)PFA1(cfa); - cfa = *current_ip; - NEXT1_P1; +#ifdef CISC_NEXT + /* this is the simple version */ *--rp = (Cell)ip; - ip = current_ip+1; - NEXT1_P2; + ip = (Xt *)PFA1(cfa); + NEXT_P0; + NEXT; +#else + /* this one is important, so we help the compiler optimizing + The following version may be better (for scheduling), but probably has + problems with code fields employing calls and delay slots + */ + { + DEF_CA + Xt *current_ip = (Xt *)PFA1(cfa); + cfa = *current_ip; + NEXT1_P1; + *--rp = (Cell)ip; + ip = current_ip+1; + NEXT1_P2; + } +#endif } - + docon: + { + DOCFA; #ifdef DEBUG - printf("%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa)); + fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = *(Cell *)PFA1(cfa); + *sp-- = TOS; + TOS = *(Cell *)PFA1(cfa); #else - *--sp = *(Cell *)PFA1(cfa); + *--sp = *(Cell *)PFA1(cfa); #endif + } + NEXT_P0; NEXT; dovar: + { + DOCFA; #ifdef DEBUG - printf("%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)PFA1(cfa); + *sp-- = TOS; + TOS = (Cell)PFA1(cfa); #else - *--sp = (Cell)PFA1(cfa); + *--sp = (Cell)PFA1(cfa); #endif + } + NEXT_P0; NEXT; - /* !! user? */ - douser: + { + DOCFA; #ifdef DEBUG - printf("%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); #endif #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)(up+*(Cell*)PFA1(cfa)); + *sp-- = TOS; + TOS = (Cell)(up+*(Cell*)PFA1(cfa)); #else - *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); + *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); #endif + } + NEXT_P0; NEXT; dodefer: + { + DOCFA; #ifdef DEBUG - printf("%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa)); + fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); #endif - cfa = *(Xt *)PFA1(cfa); - NEXT1; + EXEC(*(Xt *)PFA1(cfa)); + } + + dofield: + { + DOCFA; +#ifdef DEBUG + fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); +#endif + TOS += *(Cell*)PFA1(cfa); + } + NEXT_P0; + NEXT; dodoes: /* this assumes the following structure: @@ -250,20 +392,27 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp pfa: */ + { + DOCFA; + + /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/ #ifdef DEBUG - printf("%08x/%08x: does: %08x\n",(Cell)ip,(Cell)cfa,*(Cell)PFA(cfa)); - fflush(stdout); + fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa)); + fflush(stderr); #endif - *--rp = (Cell)ip; - /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ - ip = DOES_CODE1(cfa); + *--rp = (Cell)ip; + /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ + ip = DOES_CODE1(cfa); #ifdef USE_TOS - *sp-- = TOS; - TOS = (Cell)PFA(cfa); + *sp-- = TOS; + TOS = (Cell)PFA(cfa); #else - *--sp = (Cell)PFA(cfa); + *--sp = (Cell)PFA(cfa); #endif + /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/ + } + NEXT_P0; NEXT; - + #include "primitives.i" }