Annotation of gforth/main.c, revision 1.18
1.1 anton 1: /*
1.16 pazsan 2: $Id: main.c,v 1.15 1994/10/24 19:16:02 anton Exp $
1.1 anton 3: Copyright 1993 by the ANSI figForth Development Group
4: */
5:
6: #include <ctype.h>
7: #include <stdio.h>
8: #include <string.h>
9: #include <math.h>
10: #include <sys/types.h>
11: #include <sys/stat.h>
12: #include <fcntl.h>
13: #include <assert.h>
14: #include <stdlib.h>
15: #include "forth.h"
1.5 pazsan 16: #include "io.h"
1.12 pazsan 17: #ifdef USE_GETOPT
18: # include "getopt.h"
19: #else
1.16 pazsan 20: extern int getopt (int , char * const [], const char *);
1.12 pazsan 21:
1.16 pazsan 22: extern char *optarg;
23: extern int optind, opterr;
1.12 pazsan 24: #endif
1.2 pazsan 25:
1.10 anton 26: #ifndef DEFAULTPATH
1.16 pazsan 27: # define DEFAULTPATH "/usr/local/lib/gforth:."
1.10 anton 28: #endif
29:
1.1 anton 30: #ifdef DIRECT_THREADED
1.16 pazsan 31: # define CA(n) (symbols[(n)])
1.1 anton 32: #else
1.16 pazsan 33: # define CA(n) ((int)(symbols+(n)))
1.1 anton 34: #endif
35:
1.10 anton 36: #define maxaligned(n) ((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
37:
38: static int dictsize=0;
39: static int dsize=0;
40: static int rsize=0;
41: static int fsize=0;
42: static int lsize=0;
43: char *progname;
44:
45:
1.1 anton 46: /* image file format:
1.18 ! pazsan 47: * preamble (is skipped off), size multiple of 8
! 48: * magig: "gforth00" (means format version 0.0)
1.1 anton 49: * size of image with stacks without tags (in bytes)
50: * size of image without stacks and tags (in bytes)
1.5 pazsan 51: * size of data and FP stack (in bytes)
1.1 anton 52: * pointer to start of code
1.7 anton 53: * pointer into throw (for signal handling)
1.16 pazsan 54: * pointer to dictionary
1.1 anton 55: * data (size in image[1])
56: * tags (1 bit/data cell)
57: *
58: * tag==1 mean that the corresponding word is an address;
59: * If the word is >=0, the address is within the image;
60: * addresses within the image are given relative to the start of the image.
61: * If the word is =-1, the address is NIL,
1.2 pazsan 62: * If the word is between -2 and -5, it's a CFA (:, Create, Constant, User)
63: * If the word is -6, it's a DOES> CFA
64: * If the word is -7, it's a DOES JUMP
65: * If the word is <-7, it's a primitive
1.1 anton 66: */
67:
1.10 anton 68: void relocate(Cell *image, char *bitstring, int size, Label symbols[])
1.1 anton 69: {
1.16 pazsan 70: int i=0, j, k, steps=(size/sizeof(Cell))/8;
71: char bits;
1.5 pazsan 72: /* static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/
73:
1.16 pazsan 74: for(k=0; k<=steps; k++)
75: for(j=0, bits=bitstring[k]; j<8; j++, i++, bits<<=1)
76: if(bits & 0x80)
77: if(image[i]<0)
78: switch(image[i])
79: {
80: case CF_NIL : image[i]=0; break;
81: case CF(DOCOL) :
82: case CF(DOVAR) :
83: case CF(DOCON) :
84: case CF(DOUSER) :
85: case CF(DODEFER) : MAKE_CF(image+i,symbols[CF(image[i])]); break;
86: case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((int)image));
87: break;
88: case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
89: default : image[i]=(Cell)CA(CF(image[i]));
90: }
91: else
92: image[i]+=(Cell)image;
1.1 anton 93: }
94:
1.10 anton 95: Cell *loader(FILE *imagefile)
96: {
1.16 pazsan 97: Cell header[3];
98: Cell *image;
1.18 ! pazsan 99: Char magic[8];
1.16 pazsan 100: int wholesize;
101: int imagesize; /* everything needed by the image */
1.18 ! pazsan 102:
! 103: do
! 104: {
! 105: if(fread(magic,sizeof(Char),8,imagefile) < 8) {
! 106: fprintf(stderr,"This file doesn't seam to be a gforth image\n");
! 107: exit(1);
! 108: }
! 109: #ifdef DEBUG
! 110: printf("Magic found: %s\n",magic);
! 111: #endif
! 112: }
! 113: while(memcmp(magic,"gforth00",8));
! 114:
! 115: fread(header,sizeof(Cell),3,imagefile);
1.16 pazsan 116: if (dictsize==0)
117: dictsize = header[0];
118: if (dsize==0)
119: dsize=header[2];
120: if (rsize==0)
121: rsize=header[2];
122: if (fsize==0)
123: fsize=header[2];
124: if (lsize==0)
125: lsize=header[2];
126: dictsize=maxaligned(dictsize);
127: dsize=maxaligned(dsize);
128: rsize=maxaligned(rsize);
129: lsize=maxaligned(lsize);
130: fsize=maxaligned(fsize);
131:
132: wholesize = dictsize+dsize+rsize+fsize+lsize;
133: imagesize = header[1]+((header[1]-1)/sizeof(Cell))/8+1;
134: image=malloc(wholesize>imagesize?wholesize:imagesize);
135: memset(image,0,wholesize); /* why? - anton */
136: image[0]=header[0];
137: image[1]=header[1];
138: image[2]=header[2];
139:
140: fread(image+3,1,header[1]-3*sizeof(Cell),imagefile);
141: fread(((void *)image)+header[1],1,((header[1]-1)/sizeof(Cell))/8+1,
142: imagefile);
143: fclose(imagefile);
144:
145: if(image[5]==0) {
146: relocate(image,(char *)image+header[1],header[1],engine(0,0,0,0,0));
147: }
148: else if(image[5]!=(Cell)image) {
149: fprintf(stderr,"Corrupted image address, please recompile image\n");
150: exit(1);
151: }
1.1 anton 152:
1.16 pazsan 153: CACHE_FLUSH(image,image[1]);
154:
155: return(image);
1.1 anton 156: }
157:
1.10 anton 158: int go_forth(Cell *image, int stack, Cell *entries)
1.1 anton 159: {
1.15 anton 160: Cell *sp=(Cell*)((void *)image+dictsize+dsize);
161: Address lp=(Address)((void *)sp+lsize);
162: Float *fp=(Float *)((void *)lp+fsize);
163: Cell *rp=(Cell*)((void *)fp+rsize);
164: Xt *ip=(Xt *)(image[3]);
165: int throw_code;
166:
167: for(;stack>0;stack--)
168: *--sp=entries[stack-1];
169:
170: install_signal_handlers(); /* right place? */
171:
172: if ((throw_code=setjmp(throw_jmp_buf))) {
173: static Cell signal_data_stack[8];
174: static Cell signal_return_stack[8];
175: static Float signal_fp_stack[1];
176:
177: signal_data_stack[7]=throw_code;
178:
179: return((int)engine((Xt *)image[4],signal_data_stack+7,
180: signal_return_stack+8,signal_fp_stack,0));
181: }
182:
183: return((int)engine(ip,sp,rp,fp,lp));
1.1 anton 184: }
185:
1.10 anton 186: int convsize(char *s, int elemsize)
187: /* converts s of the format #+u (e.g. 25k) into the number of bytes.
188: the unit u can be one of bekM, where e stands for the element
189: size. default is e */
190: {
191: char *endp;
192: int n,m;
193:
194: m = elemsize;
195: n = strtoul(s,&endp,0);
196: if (endp!=NULL) {
197: if (strcmp(endp,"b")==0)
198: m=1;
199: else if (strcmp(endp,"k")==0)
200: m=1024;
201: else if (strcmp(endp,"M")==0)
202: m=1024*1024;
203: else if (strcmp(endp,"e")!=0) {
204: fprintf(stderr,"%s: cannot grok size specification %s\n", progname, s);
205: exit(1);
206: }
207: }
208: return n*m;
209: }
210:
1.1 anton 211: int main(int argc, char **argv, char **env)
212: {
1.16 pazsan 213: char *path, *path1;
214: char *imagename="gforth.fi";
215: FILE *image_file;
216: int c, retvalue;
1.10 anton 217:
1.14 anton 218: #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)
1.6 anton 219: /* turn on alignment checks on the 486.
220: * on the 386 this should have no effect. */
221: __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
222: #endif
1.2 pazsan 223:
1.16 pazsan 224: progname = argv[0];
225: if ((path=getenv("GFORTHPATH"))==NULL)
226: path = strcpy(malloc(strlen(DEFAULTPATH)+1),DEFAULTPATH);
227: opterr=0;
228: while (1) {
229: int option_index=0;
1.12 pazsan 230: #ifdef USE_GETOPT
1.16 pazsan 231: static struct option opts[] = {
232: {"image-file", required_argument, NULL, 'i'},
233: {"dictionary-size", required_argument, NULL, 'm'},
234: {"data-stack-size", required_argument, NULL, 'd'},
235: {"return-stack-size", required_argument, NULL, 'r'},
236: {"fp-stack-size", required_argument, NULL, 'f'},
237: {"locals-stack-size", required_argument, NULL, 'l'},
238: {"path", required_argument, NULL, 'p'},
239: {0,0,0,0}
240: /* no-init-file, no-rc? */
241: };
1.10 anton 242:
1.17 pazsan 243: c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:", opts, &option_index);
1.12 pazsan 244: #else
1.17 pazsan 245: c = getopt(argc, argv, "+i:m:d:r:f:l:p:");
1.12 pazsan 246: #endif
247:
1.16 pazsan 248: if (c==EOF)
249: break;
250: if (c=='?') {
251: optind--;
252: break;
253: }
254: switch (c) {
255: case 'i': imagename = optarg; break;
256: case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
257: case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
258: case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
259: case 'f': fsize = convsize(optarg,sizeof(Float)); break;
260: case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
261: case 'p': path = optarg; break;
262: }
263: }
264: path1=path;
265: do {
266: char *pend=strchr(path, ':');
267: if (pend==NULL)
268: pend=path+strlen(path);
269: if (strlen(path)==0) {
270: fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
271: progname, imagename, path1);
272: exit(1);
273: }
274: {
275: int dirlen=pend-path;
276: char fullfilename[dirlen+strlen(imagename)+2];
277: memcpy(fullfilename, path, dirlen);
278: if (fullfilename[dirlen-1]!='/')
279: fullfilename[dirlen++]='/';
280: strcpy(fullfilename+dirlen,imagename);
281: image_file=fopen(fullfilename,"rb");
282: }
283: path=pend+(*pend==':');
284: } while (image_file==NULL);
285:
286: {
287: Cell environ[]= {
288: (Cell)argc-(optind-1),
289: (Cell)(argv+(optind-1)),
290: (Cell)path1};
291: argv[optind-1] = progname;
292: /*
293: for (i=0; i<environ[0]; i++)
294: printf("%s\n", ((char **)(environ[1]))[i]);
295: */
296: retvalue=go_forth(loader(image_file),3,environ);
297: deprep_terminal();
298: exit(retvalue);
299: }
1.1 anton 300: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>