File:
[gforth] /
gforth /
Attic /
main.c
Revision
1.9:
download - view:
text,
annotated -
select for diffs
Thu Aug 25 15:25:30 1994 UTC (29 years, 7 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
make now generates both images
the image names were changed
added C-level support for deferred words (dodefer)
made 2>r 2r> 2r@ 2rdrop primitives
some tuning of the outer interpreter; eliminated many words based on
counted strings
Replaced the hash function with one that works better for larger tables
/*
$Id: main.c,v 1.9 1994/08/25 15:25:30 anton Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <assert.h>
#include <stdlib.h>
#include "forth.h"
#include "io.h"
Xt *throw_ip;
#ifndef DEFAULTBIN
# define DEFAULTBIN ""
#endif
#ifdef DIRECT_THREADED
# define CA(n) (symbols[(n)])
#else
# define CA(n) ((int)(symbols+(n)))
#endif
/* image file format:
* size of image with stacks without tags (in bytes)
* size of image without stacks and tags (in bytes)
* size of data and FP stack (in bytes)
* pointer to start of code
* pointer into throw (for signal handling)
* data (size in image[1])
* tags (1 bit/data cell)
*
* tag==1 mean that the corresponding word is an address;
* If the word is >=0, the address is within the image;
* addresses within the image are given relative to the start of the image.
* If the word is =-1, the address is NIL,
* If the word is between -2 and -5, it's a CFA (:, Create, Constant, User)
* If the word is -6, it's a DOES> CFA
* If the word is -7, it's a DOES JUMP
* If the word is <-7, it's a primitive
*/
void relocate(int *image, char *bitstring, int size, Label symbols[])
{
int i=0, j, k, steps=(size/sizeof(Cell))/8;
char bits;
/* static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/
for(k=0; k<=steps; k++)
for(j=0, bits=bitstring[k]; j<8; j++, i++, bits<<=1)
if(bits & 0x80)
if(image[i]<0)
switch(image[i])
{
case CF_NIL : image[i]=0; break;
case CF(DOCOL) :
case CF(DOVAR) :
case CF(DOCON) :
case CF(DOUSER) :
case CF(DODEFER) :
MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((int)image));
break;
case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
default : image[i]=(Cell)CA(CF(image[i]));
}
else
image[i]+=(Cell)image;
CACHE_FLUSH(image,size);
}
int* loader(const char* filename)
{ int header[2];
FILE *imagefile;
int *image;
if(!(int)(imagefile=fopen(filename,"rb")))
{
fprintf(stderr,"Can't open image file '%s'",filename);
exit(1);
}
fread(header,1,2*sizeof(int),imagefile);
image=malloc(header[0]+((header[0]-1)/sizeof(Cell))/8+1);
memset(image,0,header[0]+((header[0]-1)/sizeof(Cell))/8+1);
image[0]=header[0];
image[1]=header[1];
fread(image+2,1,header[1]-2*sizeof(Cell),imagefile);
fread(((void *)image)+header[0],1,((header[1]-1)/sizeof(Cell))/8+1,
imagefile);
fclose(imagefile);
relocate(image,(char *)image+header[0],header[1],engine(0,0,0,0,0));
return(image);
}
int go_forth(int *image, int stack, Cell *entries)
{
Cell* rp=(Cell*)((void *)image+image[0]);
double* fp=(double*)((void *)rp-image[2]);
Address lp=(Address)((void *)fp-image[2]);
Cell* sp=(Cell*)((void *)lp-image[2]);
Cell* ip=(Cell*)(image[3]);
int throw_code;
throw_ip = (Xt *)(image[4]);
for(;stack>0;stack--)
*--sp=entries[stack-1];
install_signal_handlers(); /* right place? */
if ((throw_code=setjmp(throw_jmp_buf))) {
static Cell signal_data_stack[8];
static Cell signal_return_stack[8];
signal_data_stack[7]=throw_code;
return((int)engine(image[4],signal_data_stack+7,
signal_return_stack+8,0,0));
}
return((int)engine(ip,sp,rp,fp,lp));
}
int main(int argc, char **argv, char **env)
{
char imagefile[256];
Cell environ[3] = {(Cell)argc, (Cell)argv, (Cell)env};
char* imagepath;
#if defined(i386) && defined(ALIGNMENT_CHECK)
/* turn on alignment checks on the 486.
* on the 386 this should have no effect. */
__asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
#endif
if((int)(imagepath=getenv("FORTHBIN")))
{
strcpy(imagefile,imagepath);
if(imagefile[strlen(imagefile)-1]!='/')
imagefile[strlen(imagefile)]='/';
}
else
{
strcpy(imagefile,DEFAULTBIN);
if(imagefile[0]!=0 && imagefile[strlen(imagefile)-1]!='/')
imagefile[strlen(imagefile)]='/';
}
if(argc>1 && argv[1][0]=='@')
{
if(argv[1][1]=='/')
strcpy(imagefile,argv[1]+1);
else
strcpy(imagefile+strlen(imagefile),argv[1]+1);
environ[0]-=1;
environ[1]+=sizeof(argv);
argv[1]=argv[0];
}
else
strcpy(imagefile+strlen(imagefile),"kernal.fi");
exit(go_forth(loader(imagefile),3,environ));
}
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>