File:  [gforth] / gforth / engine / main.c
Revision 1.37: download - view: text, annotated - select for diffs
Thu Jul 27 10:40:42 2000 UTC (23 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
The relocator now checks for unimplemented primitives used in the image.

    1: /* command line interpretation, image loading etc. for Gforth
    2: 
    3: 
    4:   Copyright (C) 1995,1996,1997,1998 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., 675 Mass Ave, Cambridge, MA 02139, USA.
   21: */
   22: 
   23: #include "config.h"
   24: #include <errno.h>
   25: #include <ctype.h>
   26: #include <stdio.h>
   27: #include <unistd.h>
   28: #include <string.h>
   29: #include <math.h>
   30: #include <sys/types.h>
   31: #ifndef STANDALONE
   32: #include <sys/stat.h>
   33: #endif
   34: #include <fcntl.h>
   35: #include <assert.h>
   36: #include <stdlib.h>
   37: #ifndef STANDALONE
   38: #if HAVE_SYS_MMAN_H
   39: #include <sys/mman.h>
   40: #endif
   41: #endif
   42: #include "forth.h"
   43: #include "io.h"
   44: #include "getopt.h"
   45: #ifdef STANDALONE
   46: #include <systypes.h>
   47: #endif
   48: 
   49: #define PRIM_VERSION 1
   50: /* increment this whenever the primitives change in an incompatible way */
   51: 
   52: #ifndef DEFAULTPATH
   53: #  define DEFAULTPATH "~+"
   54: #endif
   55: 
   56: #ifdef MSDOS
   57: jmp_buf throw_jmp_buf;
   58: #endif
   59: 
   60: #if defined(DIRECT_THREADED) 
   61: #  define CA(n)	(symbols[(n)])
   62: #else
   63: #  define CA(n)	((Cell)(symbols+(n)))
   64: #endif
   65: 
   66: #define maxaligned(n)	(typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
   67: 
   68: static UCell dictsize=0;
   69: static UCell dsize=0;
   70: static UCell rsize=0;
   71: static UCell fsize=0;
   72: static UCell lsize=0;
   73: int offset_image=0;
   74: int die_on_signal=0;
   75: #ifndef INCLUDE_IMAGE
   76: static int clear_dictionary=0;
   77: UCell pagesize=1;
   78: char *progname;
   79: #else
   80: char *progname = "gforth";
   81: int optind = 1;
   82: #endif
   83: 
   84: #ifdef HAS_DEBUG
   85: static int debug=0;
   86: #else
   87: # define debug 0
   88: # define perror(x...)
   89: # define fprintf(x...)
   90: #endif
   91: 
   92: ImageHeader *gforth_header;
   93: 
   94: #ifdef MEMCMP_AS_SUBROUTINE
   95: int gforth_memcmp(const char * s1, const char * s2, size_t n)
   96: {
   97:   return memcmp(s1, s2, n);
   98: }
   99: #endif
  100: 
  101: /* image file format:
  102:  *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
  103:  *   padding to a multiple of 8
  104:  *   magic: "Gforth2x" means format 0.4,
  105:  *              where x is a byte with
  106:  *              bit 7:   reserved = 0
  107:  *              bit 6:5: address unit size 2^n octets
  108:  *              bit 4:3: character size 2^n octets
  109:  *              bit 2:1: cell size 2^n octets
  110:  *              bit 0:   endian, big=0, little=1.
  111:  *  The magic are always 8 octets, no matter what the native AU/character size is
  112:  *  padding to max alignment (no padding necessary on current machines)
  113:  *  ImageHeader structure (see forth.h)
  114:  *  data (size in ImageHeader.image_size)
  115:  *  tags ((if relocatable, 1 bit/data cell)
  116:  *
  117:  * tag==1 means that the corresponding word is an address;
  118:  * If the word is >=0, the address is within the image;
  119:  * addresses within the image are given relative to the start of the image.
  120:  * If the word =-1 (CF_NIL), the address is NIL,
  121:  * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
  122:  * If the word =CF(DODOES), it's a DOES> CFA
  123:  * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,
  124:  *					possibly containing a jump to dodoes)
  125:  * If the word is <CF(DOESJUMP), it's a primitive
  126:  */
  127: 
  128: void relocate(Cell *image, const char *bitstring, int size, Label symbols[])
  129: {
  130:   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
  131:   Cell token;
  132:   char bits;
  133:   Cell max_symbols;
  134: 
  135: /*  printf("relocating %x[%x]\n", image, size); */
  136:   
  137:   for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)
  138:     ;
  139:   size/=sizeof(Cell);
  140: 
  141:   for(k=0; k<=steps; k++) {
  142:     for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
  143:       /*      fprintf(stderr,"relocate: image[%d]\n", i);*/
  144:       if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
  145: 	/* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
  146: 	if((token=image[i])<0)
  147: 	  switch(token)
  148: 	    {
  149: 	    case CF_NIL      : image[i]=0; break;
  150: #if !defined(DOUBLY_INDIRECT)
  151: 	    case CF(DOCOL)   :
  152: 	    case CF(DOVAR)   :
  153: 	    case CF(DOCON)   :
  154: 	    case CF(DOUSER)  : 
  155: 	    case CF(DODEFER) : 
  156: 	    case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;
  157: 	    case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
  158: #endif /* !defined(DOUBLY_INDIRECT) */
  159: 	    case CF(DODOES)  :
  160: 	      MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)image)));
  161: 	      break;
  162: 	    default          :
  163: /*	      printf("Code field generation image[%x]:=CA(%x)\n",
  164: 		     i, CF(image[i])); */
  165: 	      if (CF(token)<max_symbols)
  166: 		image[i]=(Cell)CA(CF(token));
  167: 	      else
  168: 		fprintf(stderr,"Primitive %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n",CF(token),(long)&image[i],VERSION);
  169: 	    }
  170: 	else
  171: 	  image[i]+=(Cell)image;
  172:       }
  173:     }
  174:   }
  175:   ((ImageHeader*)(image))->base = (Address) image;
  176: }
  177: 
  178: UCell checksum(Label symbols[])
  179: {
  180:   UCell r=PRIM_VERSION;
  181:   Cell i;
  182: 
  183:   for (i=DOCOL; i<=DOESJUMP; i++) {
  184:     r ^= (UCell)(symbols[i]);
  185:     r = (r << 5) | (r >> (8*sizeof(Cell)-5));
  186:   }
  187: #ifdef DIRECT_THREADED
  188:   /* we have to consider all the primitives */
  189:   for (; symbols[i]!=(Label)0; i++) {
  190:     r ^= (UCell)(symbols[i]);
  191:     r = (r << 5) | (r >> (8*sizeof(Cell)-5));
  192:   }
  193: #else
  194:   /* in indirect threaded code all primitives are accessed through the
  195:      symbols table, so we just have to put the base address of symbols
  196:      in the checksum */
  197:   r ^= (UCell)symbols;
  198: #endif
  199:   return r;
  200: }
  201: 
  202: Address verbose_malloc(Cell size)
  203: {
  204:   Address r;
  205:   /* leave a little room (64B) for stack underflows */
  206:   if ((r = malloc(size+64))==NULL) {
  207:     perror(progname);
  208:     exit(1);
  209:   }
  210:   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
  211:   if (debug)
  212:     fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);
  213:   return r;
  214: }
  215: 
  216: static Address next_address=0;
  217: void after_alloc(Address r, Cell size)
  218: {
  219:   if (r != (Address)-1) {
  220:     if (debug)
  221:       fprintf(stderr, "success, address=$%lx\n", (long) r);
  222:     if (pagesize != 1)
  223:       next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
  224:   } else {
  225:     if (debug)
  226:       fprintf(stderr, "failed: %s\n", strerror(errno));
  227:   }
  228: }
  229: 
  230: #ifndef MAP_FAILED
  231: #define MAP_FAILED ((Address) -1)
  232: #endif
  233: #ifndef MAP_FILE
  234: # define MAP_FILE 0
  235: #endif
  236: #ifndef MAP_PRIVATE
  237: # define MAP_PRIVATE 0
  238: #endif
  239: 
  240: #if defined(HAVE_MMAP)
  241: static Address alloc_mmap(Cell size)
  242: {
  243:   Address r;
  244: 
  245: #if defined(MAP_ANON)
  246:   if (debug)
  247:     fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
  248:   r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
  249: #else /* !defined(MAP_ANON) */
  250:   /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
  251:      apparently defaults) */
  252:   static int dev_zero=-1;
  253: 
  254:   if (dev_zero == -1)
  255:     dev_zero = open("/dev/zero", O_RDONLY);
  256:   if (dev_zero == -1) {
  257:     r = MAP_FAILED;
  258:     if (debug)
  259:       fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ", 
  260: 	      strerror(errno));
  261:   } else {
  262:     if (debug)
  263:       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
  264:     r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
  265:   }
  266: #endif /* !defined(MAP_ANON) */
  267:   after_alloc(r, size);
  268:   return r;  
  269: }
  270: #endif
  271: 
  272: Address my_alloc(Cell size)
  273: {
  274: #if HAVE_MMAP
  275:   Address r;
  276: 
  277:   r=alloc_mmap(size);
  278:   if (r!=MAP_FAILED)
  279:     return r;
  280: #endif /* HAVE_MMAP */
  281:   /* use malloc as fallback */
  282:   return verbose_malloc(size);
  283: }
  284: 
  285: #if (defined(mips) && !defined(INDIRECT_THREADED))
  286: /* the 256MB jump restriction on the MIPS architecture makes the
  287:    combination of direct threading and mmap unsafe. */
  288: #define mips_dict_alloc 1
  289: #define dict_alloc(size) verbose_malloc(size)
  290: #else
  291: #define dict_alloc(size) my_alloc(size)
  292: #endif
  293: 
  294: Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
  295: {
  296:   Address image = MAP_FAILED;
  297: 
  298: #if defined(HAVE_MMAP) && !defined(mips_dict_alloc)
  299:   if (offset==0) {
  300:     image=alloc_mmap(dictsize);
  301:     if (debug)
  302:       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
  303:     image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
  304:     after_alloc(image,dictsize);
  305:   }
  306: #endif /* defined(MAP_ANON) && !defined(mips_dict_alloc) */
  307:   if (image == MAP_FAILED) {
  308:     image = dict_alloc(dictsize+offset)+offset;
  309:     rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
  310:     fread(image, 1, imagesize, file);
  311:   }
  312:   return image;
  313: }
  314: 
  315: void set_stack_sizes(ImageHeader * header)
  316: {
  317:   if (dictsize==0)
  318:     dictsize = header->dict_size;
  319:   if (dsize==0)
  320:     dsize = header->data_stack_size;
  321:   if (rsize==0)
  322:     rsize = header->return_stack_size;
  323:   if (fsize==0)
  324:     fsize = header->fp_stack_size;
  325:   if (lsize==0)
  326:     lsize = header->locals_stack_size;
  327:   dictsize=maxaligned(dictsize);
  328:   dsize=maxaligned(dsize);
  329:   rsize=maxaligned(rsize);
  330:   lsize=maxaligned(lsize);
  331:   fsize=maxaligned(fsize);
  332: }
  333: 
  334: void alloc_stacks(ImageHeader * header)
  335: {
  336:   header->dict_size=dictsize;
  337:   header->data_stack_size=dsize;
  338:   header->fp_stack_size=fsize;
  339:   header->return_stack_size=rsize;
  340:   header->locals_stack_size=lsize;
  341: 
  342:   header->data_stack_base=my_alloc(dsize);
  343:   header->fp_stack_base=my_alloc(fsize);
  344:   header->return_stack_base=my_alloc(rsize);
  345:   header->locals_stack_base=my_alloc(lsize);
  346: }
  347: 
  348: int go_forth(Address image, int stack, Cell *entries)
  349: {
  350:   ImageHeader *image_header = (ImageHeader *)image;
  351:   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
  352:   Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
  353:   Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
  354:   Address lp0=image_header->locals_stack_base + lsize;
  355:   Xt *ip0=(Xt *)(image_header->boot_entry);
  356: #ifdef SYSSIGNALS
  357:   int throw_code;
  358: #endif
  359: 
  360:   /* ensure that the cached elements (if any) are accessible */
  361:   IF_TOS(sp0--);
  362:   IF_FTOS(fp0--);
  363:   
  364:   for(;stack>0;stack--)
  365:     *--sp0=entries[stack-1];
  366: 
  367: #ifdef SYSSIGNALS
  368:   get_winsize();
  369:    
  370:   install_signal_handlers(); /* right place? */
  371:   
  372:   if ((throw_code=setjmp(throw_jmp_buf))) {
  373:     static Cell signal_data_stack[8];
  374:     static Cell signal_return_stack[8];
  375:     static Float signal_fp_stack[1];
  376: 
  377:     signal_data_stack[7]=throw_code;
  378: 
  379: #ifdef GFORTH_DEBUGGING
  380:     if (rp <= rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
  381:       /* no rstack overflow or underflow */
  382:       rp0 = rp;
  383:       *--rp0 = (Cell)ip;
  384:     }
  385:     else /* I love non-syntactic ifdefs :-) */
  386: #endif
  387:     rp0 = signal_return_stack+8;
  388:     /* fprintf(stderr, "rp=$%x\n",rp0);*/
  389:     
  390:     return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
  391: 		       rp0, signal_fp_stack, 0));
  392:   }
  393: #endif
  394: 
  395:   return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
  396: }
  397: 
  398: 
  399: #ifndef INCLUDE_IMAGE
  400: void print_sizes(Cell sizebyte)
  401:      /* print size information */
  402: {
  403:   static char* endianstring[]= { "   big","little" };
  404:   
  405:   fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
  406: 	  endianstring[sizebyte & 1],
  407: 	  1 << ((sizebyte >> 1) & 3),
  408: 	  1 << ((sizebyte >> 3) & 3),
  409: 	  1 << ((sizebyte >> 5) & 3));
  410: }
  411: 
  412: Address loader(FILE *imagefile, char* filename)
  413: /* returns the address of the image proper (after the preamble) */
  414: {
  415:   ImageHeader header;
  416:   Address image;
  417:   Address imp; /* image+preamble */
  418:   Char magic[8];
  419:   char magic7; /* size byte of magic number */
  420:   Cell preamblesize=0;
  421:   Label *symbols = engine(0,0,0,0,0);
  422:   Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
  423:   UCell check_sum;
  424:   Cell ausize = ((RELINFOBITS ==  8) ? 0 :
  425: 		 (RELINFOBITS == 16) ? 1 :
  426: 		 (RELINFOBITS == 32) ? 2 : 3);
  427:   Cell charsize = ((sizeof(Char) == 1) ? 0 :
  428: 		   (sizeof(Char) == 2) ? 1 :
  429: 		   (sizeof(Char) == 4) ? 2 : 3) + ausize;
  430:   Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
  431: 		   (sizeof(Cell) == 2) ? 1 :
  432: 		   (sizeof(Cell) == 4) ? 2 : 3) + ausize;
  433:   Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
  434: #ifdef WORDS_BIGENDIAN
  435:        0
  436: #else
  437:        1
  438: #endif
  439:     ;
  440: 
  441: #ifndef DOUBLY_INDIRECT
  442:   check_sum = checksum(symbols);
  443: #else /* defined(DOUBLY_INDIRECT) */
  444:   check_sum = (UCell)symbols;
  445: #endif /* defined(DOUBLY_INDIRECT) */
  446:   
  447:   do {
  448:     if(fread(magic,sizeof(Char),8,imagefile) < 8) {
  449:       fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.4) image.\n",
  450: 	      progname, filename);
  451:       exit(1);
  452:     }
  453:     preamblesize+=8;
  454:   } while(memcmp(magic,"Gforth2",7));
  455:   magic7 = magic[7];
  456:   if (debug) {
  457:     magic[7]='\0';
  458:     fprintf(stderr,"Magic found: %s ", magic);
  459:     print_sizes(magic7);
  460:   }
  461: 
  462:   if (magic7 != sizebyte)
  463:     {
  464:       fprintf(stderr,"This image is:         ");
  465:       print_sizes(magic7);
  466:       fprintf(stderr,"whereas the machine is ");
  467:       print_sizes(sizebyte);
  468:       exit(-2);
  469:     };
  470: 
  471:   fread((void *)&header,sizeof(ImageHeader),1,imagefile);
  472: 
  473:   set_stack_sizes(&header);
  474:   
  475: #if HAVE_GETPAGESIZE
  476:   pagesize=getpagesize(); /* Linux/GNU libc offers this */
  477: #elif HAVE_SYSCONF && defined(_SC_PAGESIZE)
  478:   pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */
  479: #elif PAGESIZE
  480:   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
  481: #endif
  482:   if (debug)
  483:     fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
  484: 
  485:   image = dict_alloc_read(imagefile, preamblesize+header.image_size,
  486: 			  preamblesize+dictsize, data_offset);
  487:   imp=image+preamblesize;
  488:   if (clear_dictionary)
  489:     memset(imp+header.image_size, 0, dictsize-header.image_size);
  490:   if(header.base==0) {
  491:     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
  492:     char reloc_bits[reloc_size];
  493:     fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
  494:     fread(reloc_bits, 1, reloc_size, imagefile);
  495:     relocate((Cell *)imp, reloc_bits, header.image_size, symbols);
  496: #if 0
  497:     { /* let's see what the relocator did */
  498:       FILE *snapshot=fopen("snapshot.fi","wb");
  499:       fwrite(image,1,imagesize,snapshot);
  500:       fclose(snapshot);
  501:     }
  502: #endif
  503:   }
  504:   else if(header.base!=imp) {
  505:     fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address $%lx) at address $%lx\n",
  506: 	    progname, (unsigned long)header.base, (unsigned long)imp);
  507:     exit(1);
  508:   }
  509:   if (header.checksum==0)
  510:     ((ImageHeader *)imp)->checksum=check_sum;
  511:   else if (header.checksum != check_sum) {
  512:     fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
  513: 	    progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
  514:     exit(1);
  515:   }
  516:   fclose(imagefile);
  517: 
  518:   alloc_stacks((ImageHeader *)imp);
  519: 
  520:   CACHE_FLUSH(imp, header.image_size);
  521: 
  522:   return imp;
  523: }
  524: 
  525: /* index of last '/' or '\' in file, 0 if there is none. !! Hmm, could
  526:    be implemented with strrchr and the separator should be
  527:    OS-dependent */
  528: int onlypath(char *file)
  529: {
  530:   int i;
  531:   i=strlen(file);
  532:   while (i) {
  533:     if (file[i]=='\\' || file[i]=='/') break;
  534:     i--;
  535:   }
  536:   return i;
  537: }
  538: 
  539: FILE *openimage(char *fullfilename)
  540: {
  541:   FILE *image_file;
  542:   char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
  543: 
  544:   image_file=fopen(expfilename,"rb");
  545:   if (image_file!=NULL && debug)
  546:     fprintf(stderr, "Opened image file: %s\n", expfilename);
  547:   return image_file;
  548: }
  549: 
  550: /* try to open image file concat(path[0:len],imagename) */
  551: FILE *checkimage(char *path, int len, char *imagename)
  552: {
  553:   int dirlen=len;
  554:   char fullfilename[dirlen+strlen(imagename)+2];
  555: 
  556:   memcpy(fullfilename, path, dirlen);
  557:   if (fullfilename[dirlen-1]!='/')
  558:     fullfilename[dirlen++]='/';
  559:   strcpy(fullfilename+dirlen,imagename);
  560:   return openimage(fullfilename);
  561: }
  562: 
  563: FILE * open_image_file(char * imagename, char * path)
  564: {
  565:   FILE * image_file=NULL;
  566:   char *origpath=path;
  567:   
  568:   if(strchr(imagename, '/')==NULL) {
  569:     /* first check the directory where the exe file is in !! 01may97jaw */
  570:     if (onlypath(progname))
  571:       image_file=checkimage(progname, onlypath(progname), imagename);
  572:     if (!image_file)
  573:       do {
  574: 	char *pend=strchr(path, PATHSEP);
  575: 	if (pend==NULL)
  576: 	  pend=path+strlen(path);
  577: 	if (strlen(path)==0) break;
  578: 	image_file=checkimage(path, pend-path, imagename);
  579: 	path=pend+(*pend==PATHSEP);
  580:       } while (image_file==NULL);
  581:   } else {
  582:     image_file=openimage(imagename);
  583:   }
  584: 
  585:   if (!image_file) {
  586:     fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
  587: 	    progname, imagename, origpath);
  588:     exit(1);
  589:   }
  590: 
  591:   return image_file;
  592: }
  593: #endif
  594: 
  595: #ifdef HAS_OS
  596: UCell convsize(char *s, UCell elemsize)
  597: /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
  598:    of bytes.  the letter at the end indicates the unit, where e stands
  599:    for the element size. default is e */
  600: {
  601:   char *endp;
  602:   UCell n,m;
  603: 
  604:   m = elemsize;
  605:   n = strtoul(s,&endp,0);
  606:   if (endp!=NULL) {
  607:     if (strcmp(endp,"b")==0)
  608:       m=1;
  609:     else if (strcmp(endp,"k")==0)
  610:       m=1024;
  611:     else if (strcmp(endp,"M")==0)
  612:       m=1024*1024;
  613:     else if (strcmp(endp,"G")==0)
  614:       m=1024*1024*1024;
  615:     else if (strcmp(endp,"T")==0) {
  616: #if (SIZEOF_CHAR_P > 4)
  617:       m=1024L*1024*1024*1024;
  618: #else
  619:       fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
  620:       exit(1);
  621: #endif
  622:     } else if (strcmp(endp,"e")!=0 && strcmp(endp,"")!=0) {
  623:       fprintf(stderr,"%s: cannot grok size specification %s: invalid unit \"%s\"\n", progname, s, endp);
  624:       exit(1);
  625:     }
  626:   }
  627:   return n*m;
  628: }
  629: 
  630: void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
  631: {
  632:   int c;
  633: 
  634:   opterr=0;
  635:   while (1) {
  636:     int option_index=0;
  637:     static struct option opts[] = {
  638:       {"appl-image", required_argument, NULL, 'a'},
  639:       {"image-file", required_argument, NULL, 'i'},
  640:       {"dictionary-size", required_argument, NULL, 'm'},
  641:       {"data-stack-size", required_argument, NULL, 'd'},
  642:       {"return-stack-size", required_argument, NULL, 'r'},
  643:       {"fp-stack-size", required_argument, NULL, 'f'},
  644:       {"locals-stack-size", required_argument, NULL, 'l'},
  645:       {"path", required_argument, NULL, 'p'},
  646:       {"version", no_argument, NULL, 'v'},
  647:       {"help", no_argument, NULL, 'h'},
  648:       /* put something != 0 into offset_image */
  649:       {"offset-image", no_argument, &offset_image, 1},
  650:       {"no-offset-im", no_argument, &offset_image, 0},
  651:       {"clear-dictionary", no_argument, &clear_dictionary, 1},
  652:       {"die-on-signal", no_argument, &die_on_signal, 1},
  653:       {"debug", no_argument, &debug, 1},
  654:       {0,0,0,0}
  655:       /* no-init-file, no-rc? */
  656:     };
  657:     
  658:     c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
  659:     
  660:     switch (c) {
  661:     case EOF: return;
  662:     case '?': optind--; return;
  663:     case 'a': *imagename = optarg; return;
  664:     case 'i': *imagename = optarg; break;
  665:     case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
  666:     case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
  667:     case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
  668:     case 'f': fsize = convsize(optarg,sizeof(Float)); break;
  669:     case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
  670:     case 'p': *path = optarg; break;
  671:     case 'o': offset_image = 1; break;
  672:     case 'n': offset_image = 0; break;
  673:     case 'c': clear_dictionary = 1; break;
  674:     case 's': die_on_signal = 1; break;
  675:     case 'x': debug = 1; break;
  676:     case 'v': fprintf(stderr, "gforth %s\n", VERSION); exit(0);
  677:     case 'h': 
  678:       fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
  679: Engine Options:\n\
  680:   --appl-image FILE		    equivalent to '--image-file=FILE --'\n\
  681:   --clear-dictionary		    Initialize the dictionary with 0 bytes\n\
  682:   -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\
  683:   --debug			    Print debugging information during startup\n\
  684:   --die-on-signal		    exit instead of CATCHing some signals\n\
  685:   -f SIZE, --fp-stack-size=SIZE	    Specify floating point stack size\n\
  686:   -h, --help			    Print this message and exit\n\
  687:   -i FILE, --image-file=FILE	    Use image FILE instead of `gforth.fi'\n\
  688:   -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
  689:   -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\
  690:   --no-offset-im		    Load image at normal position\n\
  691:   --offset-image		    Load image at a different position\n\
  692:   -p PATH, --path=PATH		    Search path for finding image and sources\n\
  693:   -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
  694:   -v, --version			    Print version and exit\n\
  695: SIZE arguments consist of an integer followed by a unit. The unit can be\n\
  696:   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
  697: 	      argv[0]);
  698:       optind--;
  699:       return;
  700:     }
  701:   }
  702: }
  703: #endif
  704: 
  705: #ifdef INCLUDE_IMAGE
  706: extern Cell image[];
  707: extern const char reloc_bits[];
  708: #endif
  709: 
  710: int main(int argc, char **argv, char **env)
  711: {
  712: #ifdef HAS_OS
  713:   char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
  714: #else
  715:   char *path = DEFAULTPATH;
  716: #endif
  717: #ifndef INCLUDE_IMAGE
  718:   char *imagename="gforth.fi";
  719:   FILE *image_file;
  720:   Address image;
  721: #endif
  722:   int retvalue;
  723: 	  
  724: #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)
  725:   /* turn on alignment checks on the 486.
  726:    * on the 386 this should have no effect. */
  727:   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
  728:   /* this is unusable with Linux' libc.4.6.27, because this library is
  729:      not alignment-clean; we would have to replace some library
  730:      functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep
  731:      the stack FP-aligned. */
  732: #endif
  733: 
  734:   /* buffering of the user output device */
  735: #ifdef _IONBF
  736:   if (isatty(fileno(stdout))) {
  737:     fflush(stdout);
  738:     setvbuf(stdout,NULL,_IONBF,0);
  739:   }
  740: #endif
  741: 
  742:   progname = argv[0];
  743: 
  744: #ifdef HAS_OS
  745:   gforth_args(argc, argv, &path, &imagename);
  746: #endif
  747: 
  748: #ifdef INCLUDE_IMAGE
  749:   set_stack_sizes((ImageHeader *)image);
  750:   if(((ImageHeader *)image)->base != image)
  751:     relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
  752: 	     (Label*)engine(0, 0, 0, 0, 0));
  753:   alloc_stacks((ImageHeader *)image);
  754: #else
  755:   image_file = open_image_file(imagename, path);
  756:   image = loader(image_file, imagename);
  757: #endif
  758:   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
  759: 
  760:   {
  761:     char path2[strlen(path)+1];
  762:     char *p1, *p2;
  763:     Cell environ[]= {
  764:       (Cell)argc-(optind-1),
  765:       (Cell)(argv+(optind-1)),
  766:       (Cell)strlen(path),
  767:       (Cell)path2};
  768:     argv[optind-1] = progname;
  769:     /*
  770:        for (i=0; i<environ[0]; i++)
  771:        printf("%s\n", ((char **)(environ[1]))[i]);
  772:        */
  773:     /* make path OS-independent by replacing path separators with NUL */
  774:     for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
  775:       if (*p1==PATHSEP)
  776: 	*p2 = '\0';
  777:       else
  778: 	*p2 = *p1;
  779:     *p2='\0';
  780:     retvalue = go_forth(image, 4, environ);
  781:     deprep_terminal();
  782:   }
  783:   return retvalue;
  784: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>