File:  [gforth] / gforth / engine / main.c
Revision 1.39: download - view: text, annotated - select for diffs
Sat Sep 23 15:06:08 2000 UTC (21 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright dates in many files (not in ec-related files)

    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., 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:   volatile 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:   volatile Cell *orig_rp0=rp0;
  355:   Address lp0=image_header->locals_stack_base + lsize;
  356:   Xt *ip0=(Xt *)(image_header->boot_entry);
  357: #ifdef SYSSIGNALS
  358:   int throw_code;
  359: #endif
  360: 
  361:   /* ensure that the cached elements (if any) are accessible */
  362:   IF_TOS(sp0--);
  363:   IF_FTOS(fp0--);
  364:   
  365:   for(;stack>0;stack--)
  366:     *--sp0=entries[stack-1];
  367: 
  368: #ifdef SYSSIGNALS
  369:   get_winsize();
  370:    
  371:   install_signal_handlers(); /* right place? */
  372:   
  373:   if ((throw_code=setjmp(throw_jmp_buf))) {
  374:     static Cell signal_data_stack[8];
  375:     static Cell signal_return_stack[8];
  376:     static Float signal_fp_stack[1];
  377: 
  378:     signal_data_stack[7]=throw_code;
  379: 
  380: #ifdef GFORTH_DEBUGGING
  381:     /* fprintf(stderr,"\nrp=%ld\n",(long)rp); */
  382:     if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
  383:       /* no rstack overflow or underflow */
  384:       rp0 = rp;
  385:       *--rp0 = (Cell)ip;
  386:     }
  387:     else /* I love non-syntactic ifdefs :-) */
  388: #endif
  389:     rp0 = signal_return_stack+8;
  390:     /* fprintf(stderr, "rp=$%x\n",rp0);*/
  391:     
  392:     return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
  393: 		       rp0, signal_fp_stack, 0));
  394:   }
  395: #endif
  396: 
  397:   return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
  398: }
  399: 
  400: 
  401: #ifndef INCLUDE_IMAGE
  402: void print_sizes(Cell sizebyte)
  403:      /* print size information */
  404: {
  405:   static char* endianstring[]= { "   big","little" };
  406:   
  407:   fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
  408: 	  endianstring[sizebyte & 1],
  409: 	  1 << ((sizebyte >> 1) & 3),
  410: 	  1 << ((sizebyte >> 3) & 3),
  411: 	  1 << ((sizebyte >> 5) & 3));
  412: }
  413: 
  414: Address loader(FILE *imagefile, char* filename)
  415: /* returns the address of the image proper (after the preamble) */
  416: {
  417:   ImageHeader header;
  418:   Address image;
  419:   Address imp; /* image+preamble */
  420:   Char magic[8];
  421:   char magic7; /* size byte of magic number */
  422:   Cell preamblesize=0;
  423:   Label *symbols = engine(0,0,0,0,0);
  424:   Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
  425:   UCell check_sum;
  426:   Cell ausize = ((RELINFOBITS ==  8) ? 0 :
  427: 		 (RELINFOBITS == 16) ? 1 :
  428: 		 (RELINFOBITS == 32) ? 2 : 3);
  429:   Cell charsize = ((sizeof(Char) == 1) ? 0 :
  430: 		   (sizeof(Char) == 2) ? 1 :
  431: 		   (sizeof(Char) == 4) ? 2 : 3) + ausize;
  432:   Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
  433: 		   (sizeof(Cell) == 2) ? 1 :
  434: 		   (sizeof(Cell) == 4) ? 2 : 3) + ausize;
  435:   Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
  436: #ifdef WORDS_BIGENDIAN
  437:        0
  438: #else
  439:        1
  440: #endif
  441:     ;
  442: 
  443: #ifndef DOUBLY_INDIRECT
  444:   check_sum = checksum(symbols);
  445: #else /* defined(DOUBLY_INDIRECT) */
  446:   check_sum = (UCell)symbols;
  447: #endif /* defined(DOUBLY_INDIRECT) */
  448:   
  449:   do {
  450:     if(fread(magic,sizeof(Char),8,imagefile) < 8) {
  451:       fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.4) image.\n",
  452: 	      progname, filename);
  453:       exit(1);
  454:     }
  455:     preamblesize+=8;
  456:   } while(memcmp(magic,"Gforth2",7));
  457:   magic7 = magic[7];
  458:   if (debug) {
  459:     magic[7]='\0';
  460:     fprintf(stderr,"Magic found: %s ", magic);
  461:     print_sizes(magic7);
  462:   }
  463: 
  464:   if (magic7 != sizebyte)
  465:     {
  466:       fprintf(stderr,"This image is:         ");
  467:       print_sizes(magic7);
  468:       fprintf(stderr,"whereas the machine is ");
  469:       print_sizes(sizebyte);
  470:       exit(-2);
  471:     };
  472: 
  473:   fread((void *)&header,sizeof(ImageHeader),1,imagefile);
  474: 
  475:   set_stack_sizes(&header);
  476:   
  477: #if HAVE_GETPAGESIZE
  478:   pagesize=getpagesize(); /* Linux/GNU libc offers this */
  479: #elif HAVE_SYSCONF && defined(_SC_PAGESIZE)
  480:   pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */
  481: #elif PAGESIZE
  482:   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
  483: #endif
  484:   if (debug)
  485:     fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
  486: 
  487:   image = dict_alloc_read(imagefile, preamblesize+header.image_size,
  488: 			  preamblesize+dictsize, data_offset);
  489:   imp=image+preamblesize;
  490:   if (clear_dictionary)
  491:     memset(imp+header.image_size, 0, dictsize-header.image_size);
  492:   if(header.base==0) {
  493:     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
  494:     char reloc_bits[reloc_size];
  495:     fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
  496:     fread(reloc_bits, 1, reloc_size, imagefile);
  497:     relocate((Cell *)imp, reloc_bits, header.image_size, symbols);
  498: #if 0
  499:     { /* let's see what the relocator did */
  500:       FILE *snapshot=fopen("snapshot.fi","wb");
  501:       fwrite(image,1,imagesize,snapshot);
  502:       fclose(snapshot);
  503:     }
  504: #endif
  505:   }
  506:   else if(header.base!=imp) {
  507:     fprintf(stderr,"%s: Cannot load nonrelocatable image (compiled for address $%lx) at address $%lx\n",
  508: 	    progname, (unsigned long)header.base, (unsigned long)imp);
  509:     exit(1);
  510:   }
  511:   if (header.checksum==0)
  512:     ((ImageHeader *)imp)->checksum=check_sum;
  513:   else if (header.checksum != check_sum) {
  514:     fprintf(stderr,"%s: Checksum of image ($%lx) does not match the executable ($%lx)\n",
  515: 	    progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
  516:     exit(1);
  517:   }
  518:   fclose(imagefile);
  519: 
  520:   alloc_stacks((ImageHeader *)imp);
  521: 
  522:   CACHE_FLUSH(imp, header.image_size);
  523: 
  524:   return imp;
  525: }
  526: 
  527: /* index of last '/' or '\' in file, 0 if there is none. !! Hmm, could
  528:    be implemented with strrchr and the separator should be
  529:    OS-dependent */
  530: int onlypath(char *file)
  531: {
  532:   int i;
  533:   i=strlen(file);
  534:   while (i) {
  535:     if (file[i]=='\\' || file[i]=='/') break;
  536:     i--;
  537:   }
  538:   return i;
  539: }
  540: 
  541: FILE *openimage(char *fullfilename)
  542: {
  543:   FILE *image_file;
  544:   char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
  545: 
  546:   image_file=fopen(expfilename,"rb");
  547:   if (image_file!=NULL && debug)
  548:     fprintf(stderr, "Opened image file: %s\n", expfilename);
  549:   return image_file;
  550: }
  551: 
  552: /* try to open image file concat(path[0:len],imagename) */
  553: FILE *checkimage(char *path, int len, char *imagename)
  554: {
  555:   int dirlen=len;
  556:   char fullfilename[dirlen+strlen(imagename)+2];
  557: 
  558:   memcpy(fullfilename, path, dirlen);
  559:   if (fullfilename[dirlen-1]!='/')
  560:     fullfilename[dirlen++]='/';
  561:   strcpy(fullfilename+dirlen,imagename);
  562:   return openimage(fullfilename);
  563: }
  564: 
  565: FILE * open_image_file(char * imagename, char * path)
  566: {
  567:   FILE * image_file=NULL;
  568:   char *origpath=path;
  569:   
  570:   if(strchr(imagename, '/')==NULL) {
  571:     /* first check the directory where the exe file is in !! 01may97jaw */
  572:     if (onlypath(progname))
  573:       image_file=checkimage(progname, onlypath(progname), imagename);
  574:     if (!image_file)
  575:       do {
  576: 	char *pend=strchr(path, PATHSEP);
  577: 	if (pend==NULL)
  578: 	  pend=path+strlen(path);
  579: 	if (strlen(path)==0) break;
  580: 	image_file=checkimage(path, pend-path, imagename);
  581: 	path=pend+(*pend==PATHSEP);
  582:       } while (image_file==NULL);
  583:   } else {
  584:     image_file=openimage(imagename);
  585:   }
  586: 
  587:   if (!image_file) {
  588:     fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
  589: 	    progname, imagename, origpath);
  590:     exit(1);
  591:   }
  592: 
  593:   return image_file;
  594: }
  595: #endif
  596: 
  597: #ifdef HAS_OS
  598: UCell convsize(char *s, UCell elemsize)
  599: /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
  600:    of bytes.  the letter at the end indicates the unit, where e stands
  601:    for the element size. default is e */
  602: {
  603:   char *endp;
  604:   UCell n,m;
  605: 
  606:   m = elemsize;
  607:   n = strtoul(s,&endp,0);
  608:   if (endp!=NULL) {
  609:     if (strcmp(endp,"b")==0)
  610:       m=1;
  611:     else if (strcmp(endp,"k")==0)
  612:       m=1024;
  613:     else if (strcmp(endp,"M")==0)
  614:       m=1024*1024;
  615:     else if (strcmp(endp,"G")==0)
  616:       m=1024*1024*1024;
  617:     else if (strcmp(endp,"T")==0) {
  618: #if (SIZEOF_CHAR_P > 4)
  619:       m=1024L*1024*1024*1024;
  620: #else
  621:       fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
  622:       exit(1);
  623: #endif
  624:     } else if (strcmp(endp,"e")!=0 && strcmp(endp,"")!=0) {
  625:       fprintf(stderr,"%s: cannot grok size specification %s: invalid unit \"%s\"\n", progname, s, endp);
  626:       exit(1);
  627:     }
  628:   }
  629:   return n*m;
  630: }
  631: 
  632: void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
  633: {
  634:   int c;
  635: 
  636:   opterr=0;
  637:   while (1) {
  638:     int option_index=0;
  639:     static struct option opts[] = {
  640:       {"appl-image", required_argument, NULL, 'a'},
  641:       {"image-file", required_argument, NULL, 'i'},
  642:       {"dictionary-size", required_argument, NULL, 'm'},
  643:       {"data-stack-size", required_argument, NULL, 'd'},
  644:       {"return-stack-size", required_argument, NULL, 'r'},
  645:       {"fp-stack-size", required_argument, NULL, 'f'},
  646:       {"locals-stack-size", required_argument, NULL, 'l'},
  647:       {"path", required_argument, NULL, 'p'},
  648:       {"version", no_argument, NULL, 'v'},
  649:       {"help", no_argument, NULL, 'h'},
  650:       /* put something != 0 into offset_image */
  651:       {"offset-image", no_argument, &offset_image, 1},
  652:       {"no-offset-im", no_argument, &offset_image, 0},
  653:       {"clear-dictionary", no_argument, &clear_dictionary, 1},
  654:       {"die-on-signal", no_argument, &die_on_signal, 1},
  655:       {"debug", no_argument, &debug, 1},
  656:       {0,0,0,0}
  657:       /* no-init-file, no-rc? */
  658:     };
  659:     
  660:     c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
  661:     
  662:     switch (c) {
  663:     case EOF: return;
  664:     case '?': optind--; return;
  665:     case 'a': *imagename = optarg; return;
  666:     case 'i': *imagename = optarg; break;
  667:     case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
  668:     case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
  669:     case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
  670:     case 'f': fsize = convsize(optarg,sizeof(Float)); break;
  671:     case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
  672:     case 'p': *path = optarg; break;
  673:     case 'o': offset_image = 1; break;
  674:     case 'n': offset_image = 0; break;
  675:     case 'c': clear_dictionary = 1; break;
  676:     case 's': die_on_signal = 1; break;
  677:     case 'x': debug = 1; break;
  678:     case 'v': fprintf(stderr, "gforth %s\n", VERSION); exit(0);
  679:     case 'h': 
  680:       fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
  681: Engine Options:\n\
  682:   --appl-image FILE		    equivalent to '--image-file=FILE --'\n\
  683:   --clear-dictionary		    Initialize the dictionary with 0 bytes\n\
  684:   -d SIZE, --data-stack-size=SIZE   Specify data stack size\n\
  685:   --debug			    Print debugging information during startup\n\
  686:   --die-on-signal		    exit instead of CATCHing some signals\n\
  687:   -f SIZE, --fp-stack-size=SIZE	    Specify floating point stack size\n\
  688:   -h, --help			    Print this message and exit\n\
  689:   -i FILE, --image-file=FILE	    Use image FILE instead of `gforth.fi'\n\
  690:   -l SIZE, --locals-stack-size=SIZE Specify locals stack size\n\
  691:   -m SIZE, --dictionary-size=SIZE   Specify Forth dictionary size\n\
  692:   --no-offset-im		    Load image at normal position\n\
  693:   --offset-image		    Load image at a different position\n\
  694:   -p PATH, --path=PATH		    Search path for finding image and sources\n\
  695:   -r SIZE, --return-stack-size=SIZE Specify return stack size\n\
  696:   -v, --version			    Print version and exit\n\
  697: SIZE arguments consist of an integer followed by a unit. The unit can be\n\
  698:   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
  699: 	      argv[0]);
  700:       optind--;
  701:       return;
  702:     }
  703:   }
  704: }
  705: #endif
  706: 
  707: #ifdef INCLUDE_IMAGE
  708: extern Cell image[];
  709: extern const char reloc_bits[];
  710: #endif
  711: 
  712: int main(int argc, char **argv, char **env)
  713: {
  714: #ifdef HAS_OS
  715:   char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
  716: #else
  717:   char *path = DEFAULTPATH;
  718: #endif
  719: #ifndef INCLUDE_IMAGE
  720:   char *imagename="gforth.fi";
  721:   FILE *image_file;
  722:   Address image;
  723: #endif
  724:   int retvalue;
  725: 	  
  726: #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)
  727:   /* turn on alignment checks on the 486.
  728:    * on the 386 this should have no effect. */
  729:   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
  730:   /* this is unusable with Linux' libc.4.6.27, because this library is
  731:      not alignment-clean; we would have to replace some library
  732:      functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep
  733:      the stack FP-aligned. */
  734: #endif
  735: 
  736:   /* buffering of the user output device */
  737: #ifdef _IONBF
  738:   if (isatty(fileno(stdout))) {
  739:     fflush(stdout);
  740:     setvbuf(stdout,NULL,_IONBF,0);
  741:   }
  742: #endif
  743: 
  744:   progname = argv[0];
  745: 
  746: #ifdef HAS_OS
  747:   gforth_args(argc, argv, &path, &imagename);
  748: #endif
  749: 
  750: #ifdef INCLUDE_IMAGE
  751:   set_stack_sizes((ImageHeader *)image);
  752:   if(((ImageHeader *)image)->base != image)
  753:     relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
  754: 	     (Label*)engine(0, 0, 0, 0, 0));
  755:   alloc_stacks((ImageHeader *)image);
  756: #else
  757:   image_file = open_image_file(imagename, path);
  758:   image = loader(image_file, imagename);
  759: #endif
  760:   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
  761: 
  762:   {
  763:     char path2[strlen(path)+1];
  764:     char *p1, *p2;
  765:     Cell environ[]= {
  766:       (Cell)argc-(optind-1),
  767:       (Cell)(argv+(optind-1)),
  768:       (Cell)strlen(path),
  769:       (Cell)path2};
  770:     argv[optind-1] = progname;
  771:     /*
  772:        for (i=0; i<environ[0]; i++)
  773:        printf("%s\n", ((char **)(environ[1]))[i]);
  774:        */
  775:     /* make path OS-independent by replacing path separators with NUL */
  776:     for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
  777:       if (*p1==PATHSEP)
  778: 	*p2 = '\0';
  779:       else
  780: 	*p2 = *p1;
  781:     *p2='\0';
  782:     retvalue = go_forth(image, 4, environ);
  783:     deprep_terminal();
  784:   }
  785:   return retvalue;
  786: }

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