File:
[gforth] /
gforth /
engine /
main.c
Revision
1.100:
download - view:
text,
annotated -
select for diffs
Thu Jan 30 16:14:31 2003 UTC (21 years, 2 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
eliminated some (hopefully outdated) hppa special treatments
rewrote hppa cacheflush
prims2x can now process CRLF inputs (but the output is partly unixified)
prims2x can now process several sync lines in sequence
minor fixes
1: /* command line interpretation, image loading etc. for Gforth
2:
3:
4: Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
5:
6: This file is part of Gforth.
7:
8: Gforth is free software; you can redistribute it and/or
9: modify it under the terms of the GNU General Public License
10: as published by the Free Software Foundation; either version 2
11: of the License, or (at your option) any later version.
12:
13: This program is distributed in the hope that it will be useful,
14: but WITHOUT ANY WARRANTY; without even the implied warranty of
15: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16: GNU General Public License for more details.
17:
18: You should have received a copy of the GNU General Public License
19: along with this program; if not, write to the Free Software
20: Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
21: */
22:
23: #include "config.h"
24: #include "forth.h"
25: #include <errno.h>
26: #include <ctype.h>
27: #include <stdio.h>
28: #include <unistd.h>
29: #include <string.h>
30: #include <math.h>
31: #include <sys/types.h>
32: #ifndef STANDALONE
33: #include <sys/stat.h>
34: #endif
35: #include <fcntl.h>
36: #include <assert.h>
37: #include <stdlib.h>
38: #ifndef STANDALONE
39: #if HAVE_SYS_MMAN_H
40: #include <sys/mman.h>
41: #endif
42: #endif
43: #include "io.h"
44: #include "getopt.h"
45: #ifdef STANDALONE
46: #include <systypes.h>
47: #endif
48:
49: /* global variables for engine.c
50: We put them here because engine.c is compiled several times in
51: different ways for the same engine. */
52: Cell *SP;
53: Float *FP;
54: Address UP=NULL;
55:
56: #ifdef GFORTH_DEBUGGING
57: /* define some VM registers as global variables, so they survive exceptions;
58: global register variables are not up to the task (according to the
59: GNU C manual) */
60: Xt *saved_ip;
61: Cell *rp;
62: #endif
63:
64: #ifdef NO_IP
65: Label next_code;
66: #endif
67:
68: #ifdef HAS_FILE
69: char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
70: char* pfileattr[6]={"r","r","r+","r+","w","w"};
71:
72: #ifndef O_BINARY
73: #define O_BINARY 0
74: #endif
75: #ifndef O_TEXT
76: #define O_TEXT 0
77: #endif
78:
79: int ufileattr[6]= {
80: O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
81: O_RDWR |O_BINARY, O_RDWR |O_BINARY,
82: O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
83: #endif
84: /* end global vars for engine.c */
85:
86: #define PRIM_VERSION 1
87: /* increment this whenever the primitives change in an incompatible way */
88:
89: #ifndef DEFAULTPATH
90: # define DEFAULTPATH "."
91: #endif
92:
93: #ifdef MSDOS
94: jmp_buf throw_jmp_buf;
95: #endif
96:
97: #if defined(DOUBLY_INDIRECT)
98: # define CFA(n) ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})
99: #else
100: # define CFA(n) ((Cell)(symbols+((n)&~0x4000UL)))
101: #endif
102:
103: #define maxaligned(n) (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
104:
105: static UCell dictsize=0;
106: static UCell dsize=0;
107: static UCell rsize=0;
108: static UCell fsize=0;
109: static UCell lsize=0;
110: int offset_image=0;
111: int die_on_signal=0;
112: #ifndef INCLUDE_IMAGE
113: static int clear_dictionary=0;
114: UCell pagesize=1;
115: char *progname;
116: #else
117: char *progname = "gforth";
118: int optind = 1;
119: #endif
120:
121: #define CODE_BLOCK_SIZE (256*1024)
122: Address code_area=0;
123: Cell code_area_size = CODE_BLOCK_SIZE;
124: Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE
125: does for the dictionary */
126: Address start_flush=NULL; /* start of unflushed code */
127: Cell last_jump=0; /* if the last prim was compiled without jump, this
128: is it's number, otherwise this contains 0 */
129:
130: static int no_super=0; /* true if compile_prim should not fuse prims */
131: static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
132: dynamically */
133:
134: #ifdef HAS_DEBUG
135: int debug=0;
136: #else
137: # define perror(x...)
138: # define fprintf(x...)
139: #endif
140:
141: ImageHeader *gforth_header;
142: Label *vm_prims;
143: #ifdef DOUBLY_INDIRECT
144: Label *xts; /* same content as vm_prims, but should only be used for xts */
145: #endif
146:
147: #ifdef MEMCMP_AS_SUBROUTINE
148: int gforth_memcmp(const char * s1, const char * s2, size_t n)
149: {
150: return memcmp(s1, s2, n);
151: }
152: #endif
153:
154: /* image file format:
155: * "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
156: * padding to a multiple of 8
157: * magic: "Gforth3x" means format 0.6,
158: * where x is a byte with
159: * bit 7: reserved = 0
160: * bit 6:5: address unit size 2^n octets
161: * bit 4:3: character size 2^n octets
162: * bit 2:1: cell size 2^n octets
163: * bit 0: endian, big=0, little=1.
164: * The magic are always 8 octets, no matter what the native AU/character size is
165: * padding to max alignment (no padding necessary on current machines)
166: * ImageHeader structure (see forth.h)
167: * data (size in ImageHeader.image_size)
168: * tags ((if relocatable, 1 bit/data cell)
169: *
170: * tag==1 means that the corresponding word is an address;
171: * If the word is >=0, the address is within the image;
172: * addresses within the image are given relative to the start of the image.
173: * If the word =-1 (CF_NIL), the address is NIL,
174: * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
175: * If the word =CF(DODOES), it's a DOES> CFA
176: * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,
177: * possibly containing a jump to dodoes)
178: * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive
179: * If the word is <CF(DOESJUMP) and bit 14 is clear,
180: * it's the threaded code of a primitive
181: * bits 13..9 of a primitive token state which group the primitive belongs to,
182: * bits 8..0 of a primitive token index into the group
183: */
184:
185: static Cell groups[32] = {
186: 0,
187: #undef GROUP
188: #define GROUP(x, n) DOESJUMP+1+n,
189: #include "prim_grp.i"
190: #undef GROUP
191: #define GROUP(x, n)
192: };
193:
194: void relocate(Cell *image, const char *bitstring,
195: int size, Cell base, Label symbols[])
196: {
197: int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
198: Cell token;
199: char bits;
200: Cell max_symbols;
201: /*
202: * A virtual start address that's the real start address minus
203: * the one in the image
204: */
205: Cell *start = (Cell * ) (((void *) image) - ((void *) base));
206:
207: /* group index into table */
208:
209: /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
210:
211: for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)
212: ;
213: max_symbols--;
214: size/=sizeof(Cell);
215:
216: for(k=0; k<=steps; k++) {
217: for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
218: /* fprintf(stderr,"relocate: image[%d]\n", i);*/
219: if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
220: /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
221: token=image[i];
222: if(token<0) {
223: int group = (-token & 0x3E00) >> 9;
224: if(group == 0) {
225: switch(token|0x4000) {
226: case CF_NIL : image[i]=0; break;
227: #if !defined(DOUBLY_INDIRECT)
228: case CF(DOCOL) :
229: case CF(DOVAR) :
230: case CF(DOCON) :
231: case CF(DOUSER) :
232: case CF(DODEFER) :
233: case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;
234: case CF(DOESJUMP): image[i]=0; break;
235: #endif /* !defined(DOUBLY_INDIRECT) */
236: case CF(DODOES) :
237: MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));
238: break;
239: default : /* backward compatibility */
240: /* printf("Code field generation image[%x]:=CFA(%x)\n",
241: i, CF(image[i])); */
242: if (CF((token | 0x4000))<max_symbols) {
243: image[i]=(Cell)CFA(CF(token));
244: #ifdef DIRECT_THREADED
245: if ((token & 0x4000) == 0) /* threade code, no CFA */
246: compile_prim1(&image[i]);
247: #endif
248: } else
249: fprintf(stderr,"Primitive %ld used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token),(long)&image[i],PACKAGE_VERSION);
250: }
251: } else {
252: int tok = -token & 0x1FF;
253: if (tok < (groups[group+1]-groups[group])) {
254: #if defined(DOUBLY_INDIRECT)
255: image[i]=(Cell)CFA(((groups[group]+tok) | (CF(token) & 0x4000)));
256: #else
257: image[i]=(Cell)CFA((groups[group]+tok));
258: #endif
259: #ifdef DIRECT_THREADED
260: if ((token & 0x4000) == 0) /* threade code, no CFA */
261: compile_prim1(&image[i]);
262: #endif
263: } else
264: fprintf(stderr,"Primitive %lx, %d of group %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, (long)&image[i],PACKAGE_VERSION);
265: }
266: } else {
267: // if base is > 0: 0 is a null reference so don't adjust
268: if (token>=base) {
269: image[i]+=(Cell)start;
270: }
271: }
272: }
273: }
274: }
275: finish_code();
276: ((ImageHeader*)(image))->base = (Address) image;
277: }
278:
279: UCell checksum(Label symbols[])
280: {
281: UCell r=PRIM_VERSION;
282: Cell i;
283:
284: for (i=DOCOL; i<=DOESJUMP; i++) {
285: r ^= (UCell)(symbols[i]);
286: r = (r << 5) | (r >> (8*sizeof(Cell)-5));
287: }
288: #ifdef DIRECT_THREADED
289: /* we have to consider all the primitives */
290: for (; symbols[i]!=(Label)0; i++) {
291: r ^= (UCell)(symbols[i]);
292: r = (r << 5) | (r >> (8*sizeof(Cell)-5));
293: }
294: #else
295: /* in indirect threaded code all primitives are accessed through the
296: symbols table, so we just have to put the base address of symbols
297: in the checksum */
298: r ^= (UCell)symbols;
299: #endif
300: return r;
301: }
302:
303: Address verbose_malloc(Cell size)
304: {
305: Address r;
306: /* leave a little room (64B) for stack underflows */
307: if ((r = malloc(size+64))==NULL) {
308: perror(progname);
309: exit(1);
310: }
311: r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
312: if (debug)
313: fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);
314: return r;
315: }
316:
317: static Address next_address=0;
318: void after_alloc(Address r, Cell size)
319: {
320: if (r != (Address)-1) {
321: if (debug)
322: fprintf(stderr, "success, address=$%lx\n", (long) r);
323: if (pagesize != 1)
324: next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
325: } else {
326: if (debug)
327: fprintf(stderr, "failed: %s\n", strerror(errno));
328: }
329: }
330:
331: #ifndef MAP_FAILED
332: #define MAP_FAILED ((Address) -1)
333: #endif
334: #ifndef MAP_FILE
335: # define MAP_FILE 0
336: #endif
337: #ifndef MAP_PRIVATE
338: # define MAP_PRIVATE 0
339: #endif
340: #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
341: # define MAP_ANON MAP_ANONYMOUS
342: #endif
343:
344: #if defined(HAVE_MMAP)
345: static Address alloc_mmap(Cell size)
346: {
347: Address r;
348:
349: #if defined(MAP_ANON)
350: if (debug)
351: fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
352: r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
353: #else /* !defined(MAP_ANON) */
354: /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
355: apparently defaults) */
356: static int dev_zero=-1;
357:
358: if (dev_zero == -1)
359: dev_zero = open("/dev/zero", O_RDONLY);
360: if (dev_zero == -1) {
361: r = MAP_FAILED;
362: if (debug)
363: fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
364: strerror(errno));
365: } else {
366: if (debug)
367: fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
368: r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
369: }
370: #endif /* !defined(MAP_ANON) */
371: after_alloc(r, size);
372: return r;
373: }
374: #endif
375:
376: Address my_alloc(Cell size)
377: {
378: #if HAVE_MMAP
379: Address r;
380:
381: r=alloc_mmap(size);
382: if (r!=MAP_FAILED)
383: return r;
384: #endif /* HAVE_MMAP */
385: /* use malloc as fallback */
386: return verbose_malloc(size);
387: }
388:
389: Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
390: {
391: Address image = MAP_FAILED;
392:
393: #if defined(HAVE_MMAP)
394: if (offset==0) {
395: image=alloc_mmap(dictsize);
396: if (debug)
397: fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
398: image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
399: after_alloc(image,dictsize);
400: }
401: #endif /* defined(HAVE_MMAP) */
402: if (image == MAP_FAILED) {
403: image = my_alloc(dictsize+offset)+offset;
404: rewind(file); /* fseek(imagefile,0L,SEEK_SET); */
405: fread(image, 1, imagesize, file);
406: }
407: return image;
408: }
409:
410: void set_stack_sizes(ImageHeader * header)
411: {
412: if (dictsize==0)
413: dictsize = header->dict_size;
414: if (dsize==0)
415: dsize = header->data_stack_size;
416: if (rsize==0)
417: rsize = header->return_stack_size;
418: if (fsize==0)
419: fsize = header->fp_stack_size;
420: if (lsize==0)
421: lsize = header->locals_stack_size;
422: dictsize=maxaligned(dictsize);
423: dsize=maxaligned(dsize);
424: rsize=maxaligned(rsize);
425: lsize=maxaligned(lsize);
426: fsize=maxaligned(fsize);
427: }
428:
429: void alloc_stacks(ImageHeader * header)
430: {
431: header->dict_size=dictsize;
432: header->data_stack_size=dsize;
433: header->fp_stack_size=fsize;
434: header->return_stack_size=rsize;
435: header->locals_stack_size=lsize;
436:
437: header->data_stack_base=my_alloc(dsize);
438: header->fp_stack_base=my_alloc(fsize);
439: header->return_stack_base=my_alloc(rsize);
440: header->locals_stack_base=my_alloc(lsize);
441: }
442:
443: #warning You can ignore the warnings about clobbered variables in go_forth
444: int go_forth(Address image, int stack, Cell *entries)
445: {
446: volatile ImageHeader *image_header = (ImageHeader *)image;
447: Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
448: Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
449: Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
450: #ifdef GFORTH_DEBUGGING
451: volatile Cell *orig_rp0=rp0;
452: #endif
453: Address lp0=image_header->locals_stack_base + lsize;
454: Xt *ip0=(Xt *)(image_header->boot_entry);
455: #ifdef SYSSIGNALS
456: int throw_code;
457: #endif
458:
459: /* ensure that the cached elements (if any) are accessible */
460: IF_spTOS(sp0--);
461: IF_fpTOS(fp0--);
462:
463: for(;stack>0;stack--)
464: *--sp0=entries[stack-1];
465:
466: #ifdef SYSSIGNALS
467: get_winsize();
468:
469: install_signal_handlers(); /* right place? */
470:
471: if ((throw_code=setjmp(throw_jmp_buf))) {
472: static Cell signal_data_stack[8];
473: static Cell signal_return_stack[8];
474: static Float signal_fp_stack[1];
475:
476: signal_data_stack[7]=throw_code;
477:
478: #ifdef GFORTH_DEBUGGING
479: if (debug)
480: fprintf(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
481: throw_code, saved_ip, rp);
482: if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
483: /* no rstack overflow or underflow */
484: rp0 = rp;
485: *--rp0 = (Cell)saved_ip;
486: }
487: else /* I love non-syntactic ifdefs :-) */
488: rp0 = signal_return_stack+8;
489: #else /* !defined(GFORTH_DEBUGGING) */
490: if (debug)
491: fprintf(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
492: rp0 = signal_return_stack+8;
493: #endif /* !defined(GFORTH_DEBUGGING) */
494: /* fprintf(stderr, "rp=$%x\n",rp0);*/
495:
496: return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
497: rp0, signal_fp_stack, 0));
498: }
499: #endif
500:
501: return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
502: }
503:
504: #ifndef INCLUDE_IMAGE
505: void print_sizes(Cell sizebyte)
506: /* print size information */
507: {
508: static char* endianstring[]= { " big","little" };
509:
510: fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
511: endianstring[sizebyte & 1],
512: 1 << ((sizebyte >> 1) & 3),
513: 1 << ((sizebyte >> 3) & 3),
514: 1 << ((sizebyte >> 5) & 3));
515: }
516:
517: #define MAX_IMMARGS 2
518:
519: #ifndef NO_DYNAMIC
520: typedef struct {
521: Label start;
522: Cell length; /* only includes the jump iff superend is true*/
523: Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */
524: char superend; /* true if primitive ends superinstruction, i.e.,
525: unconditional branch, execute, etc. */
526: Cell nimmargs;
527: struct immarg {
528: Cell offset; /* offset of immarg within prim */
529: char rel; /* true if immarg is relative */
530: } immargs[MAX_IMMARGS];
531: } PrimInfo;
532:
533: PrimInfo *priminfos;
534: PrimInfo **decomp_prims;
535:
536: int compare_priminfo_length(const void *_a, const void *_b)
537: {
538: PrimInfo **a = (PrimInfo **)_a;
539: PrimInfo **b = (PrimInfo **)_b;
540: Cell diff = (*a)->length - (*b)->length;
541: if (diff)
542: return diff;
543: else /* break ties by start address; thus the decompiler produces
544: the earliest primitive with the same code (e.g. noop instead
545: of (char) and @ instead of >code-address */
546: return (*b)->start - (*a)->start;
547: }
548:
549: #endif /* defined(NO_DYNAMIC) */
550: Cell npriminfos=0;
551:
552:
553: void check_prims(Label symbols1[])
554: {
555: int i;
556: #ifndef NO_DYNAMIC
557: Label *symbols2, *symbols3, *ends1;
558: static char superend[]={
559: #include "prim_superend.i"
560: };
561: #endif
562:
563: if (debug)
564: #ifdef __VERSION__
565: fprintf(stderr, "Compiled with gcc-" __VERSION__ "\n");
566: #else
567: #define xstr(s) str(s)
568: #define str(s) #s
569: fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");
570: #endif
571: for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)
572: ;
573: npriminfos = i;
574:
575: #ifndef NO_DYNAMIC
576: if (no_dynamic)
577: return;
578: symbols2=engine2(0,0,0,0,0);
579: #if NO_IP
580: symbols3=engine3(0,0,0,0,0);
581: #else
582: symbols3=symbols1;
583: #endif
584: ends1 = symbols1+i+1-DOESJUMP;
585: priminfos = calloc(i,sizeof(PrimInfo));
586: for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {
587: int prim_len = ends1[i]-symbols1[i];
588: PrimInfo *pi=&priminfos[i];
589: int j=0;
590: char *s1 = (char *)symbols1[i];
591: char *s2 = (char *)symbols2[i];
592: char *s3 = (char *)symbols3[i];
593:
594: pi->start = s1;
595: pi->superend = superend[i-DOESJUMP-1]|no_super;
596: if (pi->superend)
597: pi->length = symbols1[i+1]-symbols1[i];
598: else
599: pi->length = prim_len;
600: pi->restlength = symbols1[i+1] - symbols1[i] - pi->length;
601: pi->nimmargs = 0;
602: if (debug)
603: fprintf(stderr, "Prim %3d @ %p %p %p, length=%3ld restlength=%2ld superend=%1d",
604: i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength), pi->superend);
605: assert(prim_len>=0);
606: while (j<(pi->length+pi->restlength)) {
607: if (s1[j]==s3[j]) {
608: if (s1[j] != s2[j]) {
609: pi->start = NULL; /* not relocatable */
610: if (debug)
611: fprintf(stderr,"\n non_reloc: engine1!=engine2 offset %3d",j);
612: /* assert(j<prim_len); */
613: break;
614: }
615: j++;
616: } else {
617: struct immarg *ia=&pi->immargs[pi->nimmargs];
618:
619: pi->nimmargs++;
620: ia->offset=j;
621: if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
622: ia->rel=0;
623: if (debug)
624: fprintf(stderr,"\n absolute immarg: offset %3d",j);
625: } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
626: symbols1[DOESJUMP+1]) {
627: ia->rel=1;
628: if (debug)
629: fprintf(stderr,"\n relative immarg: offset %3d",j);
630: } else {
631: pi->start = NULL; /* not relocatable */
632: if (debug)
633: fprintf(stderr,"\n non_reloc: engine1!=engine3 offset %3d",j);
634: /* assert(j<prim_len);*/
635: break;
636: }
637: j+=4;
638: }
639: }
640: if (debug)
641: fprintf(stderr,"\n");
642: }
643: decomp_prims = calloc(i,sizeof(PrimInfo *));
644: for (i=DOESJUMP+1; i<npriminfos; i++)
645: decomp_prims[i] = &(priminfos[i]);
646: qsort(decomp_prims+DOESJUMP+1, npriminfos-DOESJUMP-1, sizeof(PrimInfo *),
647: compare_priminfo_length);
648: #endif
649: }
650:
651: void flush_to_here(void)
652: {
653: #ifndef NO_DYNAMIC
654: if (start_flush)
655: FLUSH_ICACHE(start_flush, code_here-start_flush);
656: start_flush=code_here;
657: #endif
658: }
659:
660: #ifndef NO_DYNAMIC
661: void append_jump(void)
662: {
663: if (last_jump) {
664: PrimInfo *pi = &priminfos[last_jump];
665:
666: memcpy(code_here, pi->start+pi->length, pi->restlength);
667: code_here += pi->restlength;
668: last_jump=0;
669: }
670: }
671:
672: /* Gforth remembers all code blocks in this list. On forgetting (by
673: executing a marker) the code blocks are not freed (because Gforth does
674: not remember how they were allocated; hmm, remembering that might be
675: easier and cleaner). Instead, code_here etc. are reset to the old
676: value, and the "forgotten" code blocks are reused when they are
677: needed. */
678:
679: struct code_block_list {
680: struct code_block_list *next;
681: Address block;
682: Cell size;
683: } *code_block_list=NULL, **next_code_blockp=&code_block_list;
684:
685: Address append_prim(Cell p)
686: {
687: PrimInfo *pi = &priminfos[p];
688: Address old_code_here = code_here;
689:
690: if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
691: struct code_block_list *p;
692: append_jump();
693: flush_to_here();
694: if (*next_code_blockp == NULL) {
695: code_here = start_flush = code_area = my_alloc(code_area_size);
696: p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
697: *next_code_blockp = p;
698: p->next = NULL;
699: p->block = code_here;
700: p->size = code_area_size;
701: } else {
702: p = *next_code_blockp;
703: code_here = start_flush = code_area = p->block;
704: }
705: old_code_here = code_here;
706: next_code_blockp = &(p->next);
707: }
708: memcpy(code_here, pi->start, pi->length);
709: code_here += pi->length;
710: return old_code_here;
711: }
712: #endif
713:
714: int forget_dyncode(Address code)
715: {
716: #ifdef NO_DYNAMIC
717: return -1;
718: #else
719: struct code_block_list *p, **pp;
720:
721: for (pp=&code_block_list, p=*pp; p!=NULL; pp=&(p->next), p=*pp) {
722: if (code >= p->block && code < p->block+p->size) {
723: next_code_blockp = &(p->next);
724: code_here = start_flush = code;
725: code_area = p->block;
726: last_jump = 0;
727: return -1;
728: }
729: }
730: return -no_dynamic;
731: #endif /* !defined(NO_DYNAMIC) */
732: }
733:
734: Label decompile_code(Label _code)
735: {
736: #ifdef NO_DYNAMIC
737: return _code;
738: #else /* !defined(NO_DYNAMIC) */
739: Cell i;
740: struct code_block_list *p;
741: Address code=_code;
742:
743: /* first, check if we are in code at all */
744: for (p = code_block_list;; p = p->next) {
745: if (p == NULL)
746: return code;
747: if (code >= p->block && code < p->block+p->size)
748: break;
749: }
750: /* reverse order because NOOP might match other prims */
751: for (i=npriminfos-1; i>DOESJUMP; i--) {
752: PrimInfo *pi=decomp_prims[i];
753: if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
754: return pi->start;
755: }
756: return code;
757: #endif /* !defined(NO_DYNAMIC) */
758: }
759:
760: #ifdef NO_IP
761: int nbranchinfos=0;
762:
763: struct branchinfo {
764: Label *targetptr; /* *(bi->targetptr) is the target */
765: Cell *addressptr; /* store the target here */
766: } branchinfos[100000];
767:
768: int ndoesexecinfos=0;
769: struct doesexecinfo {
770: int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
771: Cell *xt; /* cfa of word whose does-code needs calling */
772: } doesexecinfos[10000];
773:
774: /* definitions of N_execute etc. */
775: #include "prim_num.i"
776:
777: void set_rel_target(Cell *source, Label target)
778: {
779: *source = ((Cell)target)-(((Cell)source)+4);
780: }
781:
782: void register_branchinfo(Label source, Cell targetptr)
783: {
784: struct branchinfo *bi = &(branchinfos[nbranchinfos]);
785: bi->targetptr = (Label *)targetptr;
786: bi->addressptr = (Cell *)source;
787: nbranchinfos++;
788: }
789:
790: Cell *compile_prim1arg(Cell p)
791: {
792: int l = priminfos[p].length;
793: Address old_code_here=code_here;
794:
795: assert(vm_prims[p]==priminfos[p].start);
796: append_prim(p);
797: return (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
798: }
799:
800: Cell *compile_call2(Cell targetptr)
801: {
802: Cell *next_code_target;
803: PrimInfo *pi = &priminfos[N_call2];
804: Address old_code_here = append_prim(N_call2);
805:
806: next_code_target = (Cell *)(old_code_here + pi->immargs[0].offset);
807: register_branchinfo(old_code_here + pi->immargs[1].offset, targetptr);
808: return next_code_target;
809: }
810: #endif
811:
812: void finish_code(void)
813: {
814: #ifdef NO_IP
815: Cell i;
816:
817: compile_prim1(NULL);
818: for (i=0; i<ndoesexecinfos; i++) {
819: struct doesexecinfo *dei = &doesexecinfos[i];
820: branchinfos[dei->branchinfo].targetptr = DOES_CODE1((dei->xt));
821: }
822: ndoesexecinfos = 0;
823: for (i=0; i<nbranchinfos; i++) {
824: struct branchinfo *bi=&branchinfos[i];
825: set_rel_target(bi->addressptr, *(bi->targetptr));
826: }
827: nbranchinfos = 0;
828: #endif
829: flush_to_here();
830: }
831:
832: void compile_prim1(Cell *start)
833: {
834: #if defined(DOUBLY_INDIRECT)
835: Label prim=(Label)*start;
836: if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
837: fprintf(stderr,"compile_prim encountered xt %p\n", prim);
838: *start=(Cell)prim;
839: return;
840: } else {
841: *start = (Cell)(prim-((Label)xts)+((Label)vm_prims));
842: return;
843: }
844: #elif defined(NO_IP)
845: static Cell *last_start=NULL;
846: static Xt last_prim=NULL;
847: /* delay work by one call in order to get relocated immargs */
848:
849: if (last_start) {
850: unsigned i = last_prim-vm_prims;
851: PrimInfo *pi=&priminfos[i];
852: Cell *next_code_target=NULL;
853:
854: assert(i<npriminfos);
855: if (i==N_execute||i==N_perform||i==N_lit_perform) {
856: next_code_target = compile_prim1arg(N_set_next_code);
857: }
858: if (i==N_call) {
859: next_code_target = compile_call2(last_start[1]);
860: } else if (i==N_does_exec) {
861: struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
862: *compile_prim1arg(N_lit) = (Cell)PFA(last_start[1]);
863: /* we cannot determine the callee now (last_start[1] may be a
864: forward reference), so just register an arbitrary target, and
865: register in dei that we need to fix this before resolving
866: branches */
867: dei->branchinfo = nbranchinfos;
868: dei->xt = (Cell *)(last_start[1]);
869: next_code_target = compile_call2(NULL);
870: } else if (pi->start == NULL) { /* non-reloc */
871: next_code_target = compile_prim1arg(N_set_next_code);
872: set_rel_target(compile_prim1arg(N_abranch),*(Xt)last_prim);
873: } else {
874: unsigned j;
875: Address old_code_here = append_prim(i);
876:
877: for (j=0; j<pi->nimmargs; j++) {
878: struct immarg *ia = &(pi->immargs[j]);
879: Cell argval = last_start[pi->nimmargs - j]; /* !! specific to prims */
880: if (ia->rel) { /* !! assumption: relative refs are branches */
881: register_branchinfo(old_code_here + ia->offset, argval);
882: } else /* plain argument */
883: *(Cell *)(old_code_here + ia->offset) = argval;
884: }
885: }
886: if (next_code_target!=NULL)
887: *next_code_target = (Cell)code_here;
888: }
889: if (start) {
890: last_prim = (Xt)*start;
891: *start = (Cell)code_here;
892: }
893: last_start = start;
894: return;
895: #elif !defined(NO_DYNAMIC)
896: Label prim=(Label)*start;
897: unsigned i;
898: Address old_code_here;
899:
900: i = ((Xt)prim)-vm_prims;
901: prim = *(Xt)prim;
902: if (no_dynamic) {
903: *start = (Cell)prim;
904: return;
905: }
906: if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */
907: append_jump();
908: *start = (Cell)prim;
909: return;
910: }
911: assert(priminfos[i].start = prim);
912: #ifdef ALIGN_CODE
913: /* ALIGN_CODE;*/
914: #endif
915: assert(prim==priminfos[i].start);
916: old_code_here = append_prim(i);
917: last_jump = (priminfos[i].superend) ? 0 : i;
918: *start = (Cell)old_code_here;
919: return;
920: #else /* !defined(DOUBLY_INDIRECT), no code replication */
921: Label prim=(Label)*start;
922: #if !defined(INDIRECT_THREADED)
923: prim = *(Xt)prim;
924: #endif
925: *start = (Cell)prim;
926: return;
927: #endif /* !defined(DOUBLY_INDIRECT) */
928: }
929:
930: Label compile_prim(Label prim)
931: {
932: Cell x=(Cell)prim;
933: assert(0);
934: compile_prim1(&x);
935: return (Label)x;
936: }
937:
938: #if defined(PRINT_SUPER_LENGTHS) && !defined(NO_DYNAMIC)
939: Cell prim_length(Cell prim)
940: {
941: return priminfos[prim+DOESJUMP+1].length;
942: }
943: #endif
944:
945: Address loader(FILE *imagefile, char* filename)
946: /* returns the address of the image proper (after the preamble) */
947: {
948: ImageHeader header;
949: Address image;
950: Address imp; /* image+preamble */
951: Char magic[8];
952: char magic7; /* size byte of magic number */
953: Cell preamblesize=0;
954: Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
955: UCell check_sum;
956: Cell ausize = ((RELINFOBITS == 8) ? 0 :
957: (RELINFOBITS == 16) ? 1 :
958: (RELINFOBITS == 32) ? 2 : 3);
959: Cell charsize = ((sizeof(Char) == 1) ? 0 :
960: (sizeof(Char) == 2) ? 1 :
961: (sizeof(Char) == 4) ? 2 : 3) + ausize;
962: Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
963: (sizeof(Cell) == 2) ? 1 :
964: (sizeof(Cell) == 4) ? 2 : 3) + ausize;
965: Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
966: #ifdef WORDS_BIGENDIAN
967: 0
968: #else
969: 1
970: #endif
971: ;
972:
973: vm_prims = engine(0,0,0,0,0);
974: check_prims(vm_prims);
975: #ifndef DOUBLY_INDIRECT
976: #ifdef PRINT_SUPER_LENGTHS
977: print_super_lengths();
978: #endif
979: check_sum = checksum(vm_prims);
980: #else /* defined(DOUBLY_INDIRECT) */
981: check_sum = (UCell)vm_prims;
982: #endif /* defined(DOUBLY_INDIRECT) */
983:
984: do {
985: if(fread(magic,sizeof(Char),8,imagefile) < 8) {
986: fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.6) image.\n",
987: progname, filename);
988: exit(1);
989: }
990: preamblesize+=8;
991: } while(memcmp(magic,"Gforth3",7));
992: magic7 = magic[7];
993: if (debug) {
994: magic[7]='\0';
995: fprintf(stderr,"Magic found: %s ", magic);
996: print_sizes(magic7);
997: }
998:
999: if (magic7 != sizebyte)
1000: {
1001: fprintf(stderr,"This image is: ");
1002: print_sizes(magic7);
1003: fprintf(stderr,"whereas the machine is ");
1004: print_sizes(sizebyte);
1005: exit(-2);
1006: };
1007:
1008: fread((void *)&header,sizeof(ImageHeader),1,imagefile);
1009:
1010: set_stack_sizes(&header);
1011:
1012: #if HAVE_GETPAGESIZE
1013: pagesize=getpagesize(); /* Linux/GNU libc offers this */
1014: #elif HAVE_SYSCONF && defined(_SC_PAGESIZE)
1015: pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */
1016: #elif PAGESIZE
1017: pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
1018: #endif
1019: if (debug)
1020: fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
1021:
1022: image = dict_alloc_read(imagefile, preamblesize+header.image_size,
1023: preamblesize+dictsize, data_offset);
1024: imp=image+preamblesize;
1025: alloc_stacks((ImageHeader *)imp);
1026: if (clear_dictionary)
1027: memset(imp+header.image_size, 0, dictsize-header.image_size);
1028: if(header.base==0 || header.base == (Address)0x100) {
1029: Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
1030: char reloc_bits[reloc_size];
1031: fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
1032: fread(reloc_bits, 1, reloc_size, imagefile);
1033: relocate((Cell *)imp, reloc_bits, header.image_size, (Cell)header.base, vm_prims);
1034: #if 0
1035: { /* let's see what the relocator did */
1036: FILE *snapshot=fopen("snapshot.fi","wb");
1037: fwrite(image,1,imagesize,snapshot);
1038: fclose(snapshot);
1039: }
1040: #endif
1041: }
1042: else if(header.base!=imp) {
1043: fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address $%lx) at address $%lx\n",
1044: progname, (unsigned long)header.base, (unsigned long)imp);
1045: exit(1);
1046: }
1047: if (header.checksum==0)
1048: ((ImageHeader *)imp)->checksum=check_sum;
1049: else if (header.checksum != check_sum) {
1050: fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
1051: progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
1052: exit(1);
1053: }
1054: #ifdef DOUBLY_INDIRECT
1055: ((ImageHeader *)imp)->xt_base = xts;
1056: #endif
1057: fclose(imagefile);
1058:
1059: /* unnecessary, except maybe for CODE words */
1060: /* FLUSH_ICACHE(imp, header.image_size);*/
1061:
1062: return imp;
1063: }
1064:
1065: /* pointer to last '/' or '\' in file, 0 if there is none. */
1066: char *onlypath(char *filename)
1067: {
1068: return strrchr(filename, DIRSEP);
1069: }
1070:
1071: FILE *openimage(char *fullfilename)
1072: {
1073: FILE *image_file;
1074: char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
1075:
1076: image_file=fopen(expfilename,"rb");
1077: if (image_file!=NULL && debug)
1078: fprintf(stderr, "Opened image file: %s\n", expfilename);
1079: return image_file;
1080: }
1081:
1082: /* try to open image file concat(path[0:len],imagename) */
1083: FILE *checkimage(char *path, int len, char *imagename)
1084: {
1085: int dirlen=len;
1086: char fullfilename[dirlen+strlen(imagename)+2];
1087:
1088: memcpy(fullfilename, path, dirlen);
1089: if (fullfilename[dirlen-1]!=DIRSEP)
1090: fullfilename[dirlen++]=DIRSEP;
1091: strcpy(fullfilename+dirlen,imagename);
1092: return openimage(fullfilename);
1093: }
1094:
1095: FILE * open_image_file(char * imagename, char * path)
1096: {
1097: FILE * image_file=NULL;
1098: char *origpath=path;
1099:
1100: if(strchr(imagename, DIRSEP)==NULL) {
1101: /* first check the directory where the exe file is in !! 01may97jaw */
1102: if (onlypath(progname))
1103: image_file=checkimage(progname, onlypath(progname)-progname, imagename);
1104: if (!image_file)
1105: do {
1106: char *pend=strchr(path, PATHSEP);
1107: if (pend==NULL)
1108: pend=path+strlen(path);
1109: if (strlen(path)==0) break;
1110: image_file=checkimage(path, pend-path, imagename);
1111: path=pend+(*pend==PATHSEP);
1112: } while (image_file==NULL);
1113: } else {
1114: image_file=openimage(imagename);
1115: }
1116:
1117: if (!image_file) {
1118: fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
1119: progname, imagename, origpath);
1120: exit(1);
1121: }
1122:
1123: return image_file;
1124: }
1125: #endif
1126:
1127: #ifdef HAS_OS
1128: UCell convsize(char *s, UCell elemsize)
1129: /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
1130: of bytes. the letter at the end indicates the unit, where e stands
1131: for the element size. default is e */
1132: {
1133: char *endp;
1134: UCell n,m;
1135:
1136: m = elemsize;
1137: n = strtoul(s,&endp,0);
1138: if (endp!=NULL) {
1139: if (strcmp(endp,"b")==0)
1140: m=1;
1141: else if (strcmp(endp,"k")==0)
1142: m=1024;
1143: else if (strcmp(endp,"M")==0)
1144: m=1024*1024;
1145: else if (strcmp(endp,"G")==0)
1146: m=1024*1024*1024;
1147: else if (strcmp(endp,"T")==0) {
1148: #if (SIZEOF_CHAR_P > 4)
1149: m=1024L*1024*1024*1024;
1150: #else
1151: fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
1152: exit(1);
1153: #endif
1154: } else if (strcmp(endp,"e")!=0 && strcmp(endp,"")!=0) {
1155: fprintf(stderr,"%s: cannot grok size specification %s: invalid unit \"%s\"\n", progname, s, endp);
1156: exit(1);
1157: }
1158: }
1159: return n*m;
1160: }
1161:
1162: void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
1163: {
1164: int c;
1165:
1166: opterr=0;
1167: while (1) {
1168: int option_index=0;
1169: static struct option opts[] = {
1170: {"appl-image", required_argument, NULL, 'a'},
1171: {"image-file", required_argument, NULL, 'i'},
1172: {"dictionary-size", required_argument, NULL, 'm'},
1173: {"data-stack-size", required_argument, NULL, 'd'},
1174: {"return-stack-size", required_argument, NULL, 'r'},
1175: {"fp-stack-size", required_argument, NULL, 'f'},
1176: {"locals-stack-size", required_argument, NULL, 'l'},
1177: {"path", required_argument, NULL, 'p'},
1178: {"version", no_argument, NULL, 'v'},
1179: {"help", no_argument, NULL, 'h'},
1180: /* put something != 0 into offset_image */
1181: {"offset-image", no_argument, &offset_image, 1},
1182: {"no-offset-im", no_argument, &offset_image, 0},
1183: {"clear-dictionary", no_argument, &clear_dictionary, 1},
1184: {"die-on-signal", no_argument, &die_on_signal, 1},
1185: {"debug", no_argument, &debug, 1},
1186: {"no-super", no_argument, &no_super, 1},
1187: {"no-dynamic", no_argument, &no_dynamic, 1},
1188: {"dynamic", no_argument, &no_dynamic, 0},
1189: {0,0,0,0}
1190: /* no-init-file, no-rc? */
1191: };
1192:
1193: c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
1194:
1195: switch (c) {
1196: case EOF: return;
1197: case '?': optind--; return;
1198: case 'a': *imagename = optarg; return;
1199: case 'i': *imagename = optarg; break;
1200: case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
1201: case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
1202: case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
1203: case 'f': fsize = convsize(optarg,sizeof(Float)); break;
1204: case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
1205: case 'p': *path = optarg; break;
1206: case 'o': offset_image = 1; break;
1207: case 'n': offset_image = 0; break;
1208: case 'c': clear_dictionary = 1; break;
1209: case 's': die_on_signal = 1; break;
1210: case 'x': debug = 1; break;
1211: case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
1212: case 'h':
1213: fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
1214: Engine Options:\n\
1215: --appl-image FILE equivalent to '--image-file=FILE --'\n\
1216: --clear-dictionary Initialize the dictionary with 0 bytes\n\
1217: -d SIZE, --data-stack-size=SIZE Specify data stack size\n\
1218: --debug Print debugging information during startup\n\
1219: --die-on-signal exit instead of CATCHing some signals\n\
1220: --dynamic use dynamic native code\n\
1221: -f SIZE, --fp-stack-size=SIZE Specify floating point stack size\n\
1222: -h, --help Print this message and exit\n\
1223: -i FILE, --image-file=FILE Use image FILE instead of `gforth.fi'\n\
1224: -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
1225: -m SIZE, --dictionary-size=SIZE Specify Forth dictionary size\n\
1226: --no-dynamic Use only statically compiled primitives\n\
1227: --no-offset-im Load image at normal position\n\
1228: --no-super No dynamically formed superinstructions\n\
1229: --offset-image Load image at a different position\n\
1230: -p PATH, --path=PATH Search path for finding image and sources\n\
1231: -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
1232: -v, --version Print engine version and exit\n\
1233: SIZE arguments consist of an integer followed by a unit. The unit can be\n\
1234: `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
1235: argv[0]);
1236: optind--;
1237: return;
1238: }
1239: }
1240: }
1241: #endif
1242:
1243: #ifdef INCLUDE_IMAGE
1244: extern Cell image[];
1245: extern const char reloc_bits[];
1246: #endif
1247:
1248: int main(int argc, char **argv, char **env)
1249: {
1250: #ifdef HAS_OS
1251: char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
1252: #else
1253: char *path = DEFAULTPATH;
1254: #endif
1255: #ifndef INCLUDE_IMAGE
1256: char *imagename="gforth.fi";
1257: FILE *image_file;
1258: Address image;
1259: #endif
1260: int retvalue;
1261:
1262: #if defined(i386) && defined(ALIGNMENT_CHECK)
1263: /* turn on alignment checks on the 486.
1264: * on the 386 this should have no effect. */
1265: __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
1266: /* this is unusable with Linux' libc.4.6.27, because this library is
1267: not alignment-clean; we would have to replace some library
1268: functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep
1269: the stack FP-aligned. */
1270: #endif
1271:
1272: /* buffering of the user output device */
1273: #ifdef _IONBF
1274: if (isatty(fileno(stdout))) {
1275: fflush(stdout);
1276: setvbuf(stdout,NULL,_IONBF,0);
1277: }
1278: #endif
1279:
1280: progname = argv[0];
1281:
1282: #ifdef HAS_OS
1283: gforth_args(argc, argv, &path, &imagename);
1284: #endif
1285:
1286: #ifdef INCLUDE_IMAGE
1287: set_stack_sizes((ImageHeader *)image);
1288: if(((ImageHeader *)image)->base != image)
1289: relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
1290: (Label*)engine(0, 0, 0, 0, 0));
1291: alloc_stacks((ImageHeader *)image);
1292: #else
1293: image_file = open_image_file(imagename, path);
1294: image = loader(image_file, imagename);
1295: #endif
1296: gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
1297:
1298: {
1299: char path2[strlen(path)+1];
1300: char *p1, *p2;
1301: Cell environ[]= {
1302: (Cell)argc-(optind-1),
1303: (Cell)(argv+(optind-1)),
1304: (Cell)strlen(path),
1305: (Cell)path2};
1306: argv[optind-1] = progname;
1307: /*
1308: for (i=0; i<environ[0]; i++)
1309: printf("%s\n", ((char **)(environ[1]))[i]);
1310: */
1311: /* make path OS-independent by replacing path separators with NUL */
1312: for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
1313: if (*p1==PATHSEP)
1314: *p2 = '\0';
1315: else
1316: *p2 = *p1;
1317: *p2='\0';
1318: retvalue = go_forth(image, 4, environ);
1319: #ifdef VM_PROFILING
1320: vm_print_profile(stderr);
1321: #endif
1322: deprep_terminal();
1323: }
1324: return retvalue;
1325: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to main.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / engine