[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.9 and 1.97

version 1.9, Wed Jun 17 16:55:16 1998 UTC version 1.97, Sun Jan 26 12:31:45 2003 UTC
Line 1 
Line 1 
 /* command line interpretation, image loading etc. for Gforth  /* command line interpretation, image loading etc. for Gforth
   
   
   Copyright (C) 1995 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
Line 17 
Line 17 
   
   You should have received a copy of the GNU General Public License    You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software    along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 */  */
   
 #include "config.h"  #include "config.h"
   #include "forth.h"
 #include <errno.h>  #include <errno.h>
 #include <ctype.h>  #include <ctype.h>
 #include <stdio.h>  #include <stdio.h>
Line 28 
Line 29 
 #include <string.h>  #include <string.h>
 #include <math.h>  #include <math.h>
 #include <sys/types.h>  #include <sys/types.h>
   #ifndef STANDALONE
 #include <sys/stat.h>  #include <sys/stat.h>
   #endif
 #include <fcntl.h>  #include <fcntl.h>
 #include <assert.h>  #include <assert.h>
 #include <stdlib.h>  #include <stdlib.h>
   #ifndef STANDALONE
 #if HAVE_SYS_MMAN_H  #if HAVE_SYS_MMAN_H
 #include <sys/mman.h>  #include <sys/mman.h>
 #endif  #endif
 #include "forth.h"  #endif
 #include "io.h"  #include "io.h"
 #include "getopt.h"  #include "getopt.h"
   #ifdef STANDALONE
   #include <systypes.h>
   #endif
   
   /* global variables for engine.c
      We put them here because engine.c is compiled several times in
      different ways for the same engine. */
   Cell *SP;
   Float *FP;
   Address UP=NULL;
   
   #ifdef GFORTH_DEBUGGING
   /* define some VM registers as global variables, so they survive exceptions;
      global register variables are not up to the task (according to the
      GNU C manual) */
   Xt *saved_ip;
   Cell *rp;
   #endif
   
   #ifdef NO_IP
   Label next_code;
   #endif
   
   #ifdef HAS_FILE
   char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"};
   char* pfileattr[6]={"r","r","r+","r+","w","w"};
   
   #ifndef O_BINARY
   #define O_BINARY 0
   #endif
   #ifndef O_TEXT
   #define O_TEXT 0
   #endif
   
   int ufileattr[6]= {
     O_RDONLY|O_BINARY, O_RDONLY|O_BINARY,
     O_RDWR  |O_BINARY, O_RDWR  |O_BINARY,
     O_WRONLY|O_BINARY, O_WRONLY|O_BINARY };
   #endif
   /* end global vars for engine.c */
   
 #define PRIM_VERSION 1  #define PRIM_VERSION 1
 /* increment this whenever the primitives change in an incompatible way */  /* increment this whenever the primitives change in an incompatible way */
   
 #ifdef MSDOS  
 jmp_buf throw_jmp_buf;  
 #  ifndef DEFAULTPATH  #  ifndef DEFAULTPATH
 #    define DEFAULTPATH "."  #    define DEFAULTPATH "."
 #  endif  #  endif
   
   #ifdef MSDOS
   jmp_buf throw_jmp_buf;
 #endif  #endif
   
 #if defined(DIRECT_THREADED)  #if defined(DOUBLY_INDIRECT)
 #  define CA(n) (symbols[(n)])  #  define CFA(n)        ({Cell _n = (n); ((Cell)(((_n & 0x4000) ? symbols : xts)+(_n&~0x4000UL)));})
 #else  #else
 #  define CA(n) ((Cell)(symbols+(n)))  #  define CFA(n)        ((Cell)(symbols+((n)&~0x4000UL)))
 #endif  #endif
   
 #define maxaligned(n)   (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))  #define maxaligned(n)   (typeof(n))((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
Line 64 
Line 109 
 static UCell lsize=0;  static UCell lsize=0;
 int offset_image=0;  int offset_image=0;
 int die_on_signal=0;  int die_on_signal=0;
   #ifndef INCLUDE_IMAGE
 static int clear_dictionary=0;  static int clear_dictionary=0;
 static int debug=0;  UCell pagesize=1;
 static size_t pagesize=0;  
 char *progname;  char *progname;
   #else
   char *progname = "gforth";
   int optind = 1;
   #endif
   
   #define CODE_BLOCK_SIZE (256*1024)
   Address code_area=0;
   Cell code_area_size = CODE_BLOCK_SIZE;
   Address code_here=NULL+CODE_BLOCK_SIZE; /* does for code-area what HERE
                                              does for the dictionary */
   Address start_flush=0; /* start of unflushed code */
   Cell last_jump=0; /* if the last prim was compiled without jump, this
                        is it's number, otherwise this contains 0 */
   
   static int no_super=0;   /* true if compile_prim should not fuse prims */
   static int no_dynamic=NO_DYNAMIC_DEFAULT; /* if true, no code is generated
                                                dynamically */
   
   #ifdef HAS_DEBUG
   int debug=0;
   #else
   # define perror(x...)
   # define fprintf(x...)
   #endif
   
   ImageHeader *gforth_header;
   Label *vm_prims;
   #ifdef DOUBLY_INDIRECT
   Label *xts; /* same content as vm_prims, but should only be used for xts */
   #endif
   
   #ifdef MEMCMP_AS_SUBROUTINE
   int gforth_memcmp(const char * s1, const char * s2, size_t n)
   {
     return memcmp(s1, s2, n);
   }
   #endif
   
 /* image file format:  /* image file format:
  *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.3.0 -i\n")   *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
  *   padding to a multiple of 8   *   padding to a multiple of 8
  *   magic: "Gforth1x" means format 0.2,   *   magic: "Gforth3x" means format 0.6,
  *              where x is even for big endian and odd for little endian   *              where x is a byte with
  *              and x & ~1 is the size of the cell in bytes.   *              bit 7:   reserved = 0
    *              bit 6:5: address unit size 2^n octets
    *              bit 4:3: character size 2^n octets
    *              bit 2:1: cell size 2^n octets
    *              bit 0:   endian, big=0, little=1.
    *  The magic are always 8 octets, no matter what the native AU/character size is
  *  padding to max alignment (no padding necessary on current machines)   *  padding to max alignment (no padding necessary on current machines)
  *  ImageHeader structure (see below)   *  ImageHeader structure (see forth.h)
  *  data (size in ImageHeader.image_size)   *  data (size in ImageHeader.image_size)
  *  tags ((if relocatable, 1 bit/data cell)   *  tags ((if relocatable, 1 bit/data cell)
  *   *
Line 88 
Line 175 
  * If the word =CF(DODOES), it's a DOES> CFA   * If the word =CF(DODOES), it's a DOES> CFA
  * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,   * If the word =CF(DOESJUMP), it's a DOES JUMP (2 Cells after DOES>,
  *                                      possibly containing a jump to dodoes)   *                                      possibly containing a jump to dodoes)
  * If the word is <CF(DOESJUMP), it's a primitive   * If the word is <CF(DOESJUMP) and bit 14 is set, it's the xt of a primitive
    * If the word is <CF(DOESJUMP) and bit 14 is clear,
    *                                        it's the threaded code of a primitive
    * bits 13..9 of a primitive token state which group the primitive belongs to,
    * bits 8..0 of a primitive token index into the group
  */   */
   
 typedef struct {  static Cell groups[32] = {
   Address base;         /* base address of image (0 if relocatable) */    0,
   UCell checksum;       /* checksum of ca's to protect against some  #undef GROUP
                            incompatible binary/executable combinations  #define GROUP(x, n) DOESJUMP+1+n,
                            (0 if relocatable) */  #include "prim_grp.i"
   UCell image_size;     /* all sizes in bytes */  #undef GROUP
   UCell dict_size;  #define GROUP(x, n)
   UCell data_stack_size;  };
   UCell fp_stack_size;  
   UCell return_stack_size;  
   UCell locals_stack_size;  
   Xt *boot_entry;       /* initial ip for booting (in BOOT) */  
   Xt *throw_entry;      /* ip after signal (in THROW) */  
   Cell unused1;         /* possibly tib stack size */  
   Cell unused2;  
   Address data_stack_base; /* this and the following fields are initialized by the loader */  
   Address fp_stack_base;  
   Address return_stack_base;  
   Address locals_stack_base;  
 } ImageHeader;  
 /* the image-header is created in main.fs */  
   
 void relocate(Cell *image, char *bitstring, int size, Label symbols[])  void relocate(Cell *image, const char *bitstring,
                 int size, Cell base, Label symbols[])
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/8;    int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
     Cell token;
   char bits;    char bits;
 /*   static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/    Cell max_symbols;
     /*
      * A virtual start address that's the real start address minus
      * the one in the image
      */
     Cell *start = (Cell * ) (((void *) image) - ((void *) base));
   
 /*  printf("relocating %x[%x]\n", image, size); */    /* group index into table */
   
   for(k=0; k<=steps; k++)  /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
     for(j=0, bits=bitstring[k]; j<8; j++, i++, bits<<=1) {  
     for (max_symbols=DOESJUMP+1; symbols[max_symbols]!=0; max_symbols++)
       ;
     max_symbols--;
     size/=sizeof(Cell);
   
     for(k=0; k<=steps; k++) {
       for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
       /*      fprintf(stderr,"relocate: image[%d]\n", i);*/        /*      fprintf(stderr,"relocate: image[%d]\n", i);*/
       if(bits & 0x80) {        if((i < size) && (bits & (1U << (RELINFOBITS-1)))) {
         /* fprintf(stderr,"relocate: image[%d]=%d\n", i, image[i]);*/          /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
         if(image[i]<0)          token=image[i];
           switch(image[i])          if(token<0) {
             {            int group = (-token & 0x3E00) >> 9;
             if(group == 0) {
               switch(token|0x4000) {
             case CF_NIL      : image[i]=0; break;              case CF_NIL      : image[i]=0; break;
 #if !defined(DOUBLY_INDIRECT)  #if !defined(DOUBLY_INDIRECT)
             case CF(DOCOL)   :              case CF(DOCOL)   :
Line 136 
Line 230 
             case CF(DOCON)   :              case CF(DOCON)   :
             case CF(DOUSER)  :              case CF(DOUSER)  :
             case CF(DODEFER) :              case CF(DODEFER) :
             case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(image[i])]); break;              case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;
             case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;              case CF(DOESJUMP): image[i]=0; break;
 #endif /* !defined(DOUBLY_INDIRECT) */  #endif /* !defined(DOUBLY_INDIRECT) */
             case CF(DODOES)  :              case CF(DODOES)  :
               MAKE_DOES_CF(image+i,image[i+1]+((Cell)image));                MAKE_DOES_CF(image+i,(Xt *)(image[i+1]+((Cell)start)));
               break;                break;
             default          :              default          : /* backward compatibility */
 /*            printf("Code field generation image[%x]:=CA(%x)\n",  /*            printf("Code field generation image[%x]:=CFA(%x)\n",
                      i, CF(image[i])); */                       i, CF(image[i])); */
               image[i]=(Cell)CA(CF(image[i]));                if (CF((token | 0x4000))<max_symbols) {
                   image[i]=(Cell)CFA(CF(token));
   #ifdef DIRECT_THREADED
                   if ((token & 0x4000) == 0) /* threade code, no CFA */
                     compile_prim1(&image[i]);
   #endif
                 } else
                   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],PACKAGE_VERSION);
               }
             } else {
               int tok = -token & 0x1FF;
               if (tok < (groups[group+1]-groups[group])) {
   #if defined(DOUBLY_INDIRECT)
                 image[i]=(Cell)CFA(((groups[group]+tok) | (CF(token) & 0x4000)));
   #else
                 image[i]=(Cell)CFA((groups[group]+tok));
   #endif
   #ifdef DIRECT_THREADED
                 if ((token & 0x4000) == 0) /* threade code, no CFA */
                   compile_prim1(&image[i]);
   #endif
               } else
                 fprintf(stderr,"Primitive %x, %d of group %d used in this image at $%lx is not implemented by this\n engine (%s); executing this code will crash.\n", -token, tok, group, (long)&image[i],PACKAGE_VERSION);
             }
           } else {
             // if base is > 0: 0 is a null reference so don't adjust
             if (token>=base) {
               image[i]+=(Cell)start;
             }
           }
             }              }
         else  
           image[i]+=(Cell)image;  
       }        }
     }      }
     finish_code();
     ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
 UCell checksum(Label symbols[])  UCell checksum(Label symbols[])
Line 191 
Line 314 
   return r;    return r;
 }  }
   
 Address my_alloc(Cell size)  
 {  
 #if HAVE_MMAP  
   static Address next_address=0;    static Address next_address=0;
   Address r;  void after_alloc(Address r, Cell size)
   {
 #if defined(MAP_ANON)    if (r != (Address)-1) {
   if (debug)    if (debug)
     fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);        fprintf(stderr, "success, address=$%lx\n", (long) r);
   r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);      if (pagesize != 1)
 #else /* !defined(MAP_ANON) */        next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
   /* Ultrix (at least does not define MAP_FILE and MAP_PRIVATE (both are    } else {
      apparently defaults*/      if (debug)
         fprintf(stderr, "failed: %s\n", strerror(errno));
     }
   }
   
   #ifndef MAP_FAILED
   #define MAP_FAILED ((Address) -1)
   #endif
 #ifndef MAP_FILE  #ifndef MAP_FILE
 # define MAP_FILE 0  # define MAP_FILE 0
 #endif  #endif
 #ifndef MAP_PRIVATE  #ifndef MAP_PRIVATE
 # define MAP_PRIVATE 0  # define MAP_PRIVATE 0
 #endif  #endif
   #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
   # define MAP_ANON MAP_ANONYMOUS
   #endif
   
   #if defined(HAVE_MMAP)
   static Address alloc_mmap(Cell size)
   {
     Address r;
   
   #if defined(MAP_ANON)
     if (debug)
       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);
     r = mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0);
   #else /* !defined(MAP_ANON) */
     /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
        apparently defaults) */
   static int dev_zero=-1;    static int dev_zero=-1;
   
   if (dev_zero == -1)    if (dev_zero == -1)
     dev_zero = open("/dev/zero", O_RDONLY);      dev_zero = open("/dev/zero", O_RDONLY);
   if (dev_zero == -1) {    if (dev_zero == -1) {
     r = (Address)-1;      r = MAP_FAILED;
     if (debug)      if (debug)
       fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",        fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
               strerror(errno));                strerror(errno));
Line 225 
Line 368 
     r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);      r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE, dev_zero, 0);
   }    }
 #endif /* !defined(MAP_ANON) */  #endif /* !defined(MAP_ANON) */
     after_alloc(r, size);
   if (r != (Address)-1) {  
     if (debug)  
       fprintf(stderr, "success, address=$%lx\n", (long) r);  
     if (pagesize != 0)  
       next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */  
     return r;      return r;
   }    }
   if (debug)  #endif
     fprintf(stderr, "failed: %s\n", strerror(errno));  
   Address my_alloc(Cell size)
   {
   #if HAVE_MMAP
     Address r;
   
     r=alloc_mmap(size);
     if (r!=MAP_FAILED)
       return r;
 #endif /* HAVE_MMAP */  #endif /* HAVE_MMAP */
   /* use malloc as fallback */    /* use malloc as fallback */
   return verbose_malloc(size);    return verbose_malloc(size);
 }  }
   
 #if (defined(mips) && !defined(INDIRECT_THREADED))  Address dict_alloc_read(FILE *file, Cell imagesize, Cell dictsize, Cell offset)
 /* the 256MB jump restriction on the MIPS architecture makes the  {
    combination of direct threading and mmap unsafe. */    Address image = MAP_FAILED;
 #define dict_alloc(size) verbose_malloc(size)  
   #if defined(HAVE_MMAP)
     if (offset==0) {
       image=alloc_mmap(dictsize);
       if (debug)
         fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
       image = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE, fileno(file), 0);
       after_alloc(image,dictsize);
     }
   #endif /* defined(HAVE_MMAP) */
     if (image == MAP_FAILED) {
       image = my_alloc(dictsize+offset)+offset;
       rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
       fread(image, 1, imagesize, file);
     }
     return image;
   }
   
   void set_stack_sizes(ImageHeader * header)
   {
     if (dictsize==0)
       dictsize = header->dict_size;
     if (dsize==0)
       dsize = header->data_stack_size;
     if (rsize==0)
       rsize = header->return_stack_size;
     if (fsize==0)
       fsize = header->fp_stack_size;
     if (lsize==0)
       lsize = header->locals_stack_size;
     dictsize=maxaligned(dictsize);
     dsize=maxaligned(dsize);
     rsize=maxaligned(rsize);
     lsize=maxaligned(lsize);
     fsize=maxaligned(fsize);
   }
   
   void alloc_stacks(ImageHeader * header)
   {
     header->dict_size=dictsize;
     header->data_stack_size=dsize;
     header->fp_stack_size=fsize;
     header->return_stack_size=rsize;
     header->locals_stack_size=lsize;
   
     header->data_stack_base=my_alloc(dsize);
     header->fp_stack_base=my_alloc(fsize);
     header->return_stack_base=my_alloc(rsize);
     header->locals_stack_base=my_alloc(lsize);
   }
   
   #warning You can ignore the warnings about clobbered variables in go_forth
   int go_forth(Address image, int stack, Cell *entries)
   {
     volatile ImageHeader *image_header = (ImageHeader *)image;
     Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
     Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);
     Float *fp0=(Float *)(image_header->fp_stack_base + fsize);
   #ifdef GFORTH_DEBUGGING
     volatile Cell *orig_rp0=rp0;
   #endif
     Address lp0=image_header->locals_stack_base + lsize;
     Xt *ip0=(Xt *)(image_header->boot_entry);
   #ifdef SYSSIGNALS
     int throw_code;
   #endif
   
     /* ensure that the cached elements (if any) are accessible */
     IF_spTOS(sp0--);
     IF_fpTOS(fp0--);
   
     for(;stack>0;stack--)
       *--sp0=entries[stack-1];
   
   #ifdef SYSSIGNALS
     get_winsize();
   
     install_signal_handlers(); /* right place? */
   
     if ((throw_code=setjmp(throw_jmp_buf))) {
       static Cell signal_data_stack[8];
       static Cell signal_return_stack[8];
       static Float signal_fp_stack[1];
   
       signal_data_stack[7]=throw_code;
   
   #ifdef GFORTH_DEBUGGING
       if (debug)
         fprintf(stderr,"\ncaught signal, throwing exception %d, ip=%p rp=%p\n",
                 throw_code, saved_ip, rp);
       if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
         /* no rstack overflow or underflow */
         rp0 = rp;
         *--rp0 = (Cell)saved_ip;
       }
       else /* I love non-syntactic ifdefs :-) */
         rp0 = signal_return_stack+8;
   #else  /* !defined(GFORTH_DEBUGGING) */
       if (debug)
         fprintf(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
         rp0 = signal_return_stack+8;
   #endif /* !defined(GFORTH_DEBUGGING) */
       /* fprintf(stderr, "rp=$%x\n",rp0);*/
   
       return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
                          rp0, signal_fp_stack, 0));
     }
   #endif
   
     return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
   }
   
   #ifndef INCLUDE_IMAGE
   void print_sizes(Cell sizebyte)
        /* print size information */
   {
     static char* endianstring[]= { "   big","little" };
   
     fprintf(stderr,"%s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",
             endianstring[sizebyte & 1],
             1 << ((sizebyte >> 1) & 3),
             1 << ((sizebyte >> 3) & 3),
             1 << ((sizebyte >> 5) & 3));
   }
   
   #define MAX_IMMARGS 2
   
   #ifndef NO_DYNAMIC
   typedef struct {
     Label start;
     Cell length; /* only includes the jump iff superend is true*/
     Cell restlength; /* length of the rest (i.e., the jump or (on superend) 0) */
     char superend; /* true if primitive ends superinstruction, i.e.,
                        unconditional branch, execute, etc. */
     Cell nimmargs;
     struct immarg {
       Cell offset; /* offset of immarg within prim */
       char rel;    /* true if immarg is relative */
     } immargs[MAX_IMMARGS];
   } PrimInfo;
   
   PrimInfo *priminfos;
   PrimInfo **decomp_prims;
   
   int compare_priminfo_length(const void *_a, const void *_b)
   {
     PrimInfo **a = (PrimInfo **)_a;
     PrimInfo **b = (PrimInfo **)_b;
     Cell diff = (*a)->length - (*b)->length;
     if (diff)
       return diff;
     else /* break ties by start address; thus the decompiler produces
             the earliest primitive with the same code (e.g. noop instead
             of (char) and @ instead of >code-address */
       return (*b)->start - (*a)->start;
   }
   
   #endif /* defined(NO_DYNAMIC) */
   Cell npriminfos=0;
   
   
   void check_prims(Label symbols1[])
   {
     int i;
   #ifndef NO_DYNAMIC
     Label *symbols2, *symbols3, *ends1;
     static char superend[]={
   #include "prim_superend.i"
     };
   #endif
   
     if (debug)
   #ifdef __VERSION__
       fprintf(stderr, "Compiled with gcc-" __VERSION__ "\n");
   #else
   #define xstr(s) str(s)
   #define str(s) #s
     fprintf(stderr, "Compiled with gcc-" xstr(__GNUC__) "." xstr(__GNUC_MINOR__) "\n");
   #endif
     for (i=DOESJUMP+1; symbols1[i+1]!=0; i++)
       ;
     npriminfos = i;
   
   #ifndef NO_DYNAMIC
     if (no_dynamic)
       return;
     symbols2=engine2(0,0,0,0,0);
   #if NO_IP
     symbols3=engine3(0,0,0,0,0);
   #else
     symbols3=symbols1;
   #endif
     ends1 = symbols1+i+1-DOESJUMP;
     priminfos = calloc(i,sizeof(PrimInfo));
     for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {
       int prim_len = ends1[i]-symbols1[i];
       PrimInfo *pi=&priminfos[i];
       int j=0;
       char *s1 = (char *)symbols1[i];
       char *s2 = (char *)symbols2[i];
       char *s3 = (char *)symbols3[i];
   
       pi->start = s1;
       pi->superend = superend[i-DOESJUMP-1]|no_super;
       if (pi->superend)
         pi->length = symbols1[i+1]-symbols1[i];
       else
         pi->length = prim_len;
       pi->restlength = symbols1[i+1] - symbols1[i] - pi->length;
       pi->nimmargs = 0;
       if (debug)
         fprintf(stderr, "Prim %3d @ %p %p %p, length=%3d restlength=%2d superend=%1d",
                 i, s1, s2, s3, pi->length, pi->restlength, pi->superend);
       assert(prim_len>=0);
       while (j<(pi->length+pi->restlength)) {
         if (s1[j]==s3[j]) {
           if (s1[j] != s2[j]) {
             pi->start = NULL; /* not relocatable */
             if (debug)
               fprintf(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
             /* assert(j<prim_len); */
             break;
           }
           j++;
         } else {
           struct immarg *ia=&pi->immargs[pi->nimmargs];
   
           pi->nimmargs++;
           ia->offset=j;
           if ((~*(Cell *)&(s1[j]))==*(Cell *)&(s3[j])) {
             ia->rel=0;
             if (debug)
               fprintf(stderr,"\n   absolute immarg: offset %3d",j);
           } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                      symbols1[DOESJUMP+1]) {
             ia->rel=1;
             if (debug)
               fprintf(stderr,"\n   relative immarg: offset %3d",j);
           } else {
             pi->start = NULL; /* not relocatable */
             if (debug)
               fprintf(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
             /* assert(j<prim_len);*/
             break;
           }
           j+=4;
         }
       }
       if (debug)
         fprintf(stderr,"\n");
     }
     decomp_prims = calloc(i,sizeof(PrimInfo *));
     for (i=DOESJUMP+1; i<npriminfos; i++)
       decomp_prims[i] = &(priminfos[i]);
     qsort(decomp_prims+DOESJUMP+1, npriminfos-DOESJUMP-1, sizeof(PrimInfo *),
           compare_priminfo_length);
   #endif
   }
   
   void flush_to_here(void)
   {
   #ifndef NO_DYNAMIC
     FLUSH_ICACHE(start_flush, code_here-start_flush);
     start_flush=code_here;
   #endif
   }
   
   #ifndef NO_DYNAMIC
   void append_jump(void)
   {
     if (last_jump) {
       PrimInfo *pi = &priminfos[last_jump];
   
       memcpy(code_here, pi->start+pi->length, pi->restlength);
       code_here += pi->restlength;
       last_jump=0;
     }
   }
   
   /* Gforth remembers all code blocks in this list.  On forgetting (by
   executing a marker) the code blocks are not freed (because Gforth does
   not remember how they were allocated; hmm, remembering that might be
   easier and cleaner).  Instead, code_here etc. are reset to the old
   value, and the "forgotten" code blocks are reused when they are
   needed. */
   
   struct code_block_list {
     struct code_block_list *next;
     Address block;
     Cell size;
   } *code_block_list=NULL, **next_code_blockp=&code_block_list;
   
   Address append_prim(Cell p)
   {
     PrimInfo *pi = &priminfos[p];
     Address old_code_here = code_here;
   
     if (code_area+code_area_size < code_here+pi->length+pi->restlength) {
       struct code_block_list *p;
       append_jump();
       flush_to_here();
       if (*next_code_blockp == NULL) {
         code_here = start_flush = code_area = my_alloc(code_area_size);
         p = (struct code_block_list *)malloc(sizeof(struct code_block_list));
         *next_code_blockp = p;
         p->next = NULL;
         p->block = code_here;
         p->size = code_area_size;
       } else {
         p = *next_code_blockp;
         code_here = start_flush = code_area = p->block;
       }
       old_code_here = code_here;
       next_code_blockp = &(p->next);
     }
     memcpy(code_here, pi->start, pi->length);
     code_here += pi->length;
     return old_code_here;
   }
   #endif
   
   int forget_dyncode(Address code)
   {
   #ifdef NO_DYNAMIC
     return -1;
 #else  #else
 #define dict_alloc(size) my_alloc(size)    struct code_block_list *p, **pp;
   
     for (pp=&code_block_list, p=*pp; p!=NULL; pp=&(p->next), p=*pp) {
       if (code >= p->block && code < p->block+p->size) {
         next_code_blockp = &(p->next);
         code_here = start_flush = code;
         code_area = p->block;
         last_jump = 0;
         return -1;
       }
     }
     return -no_dynamic;
   #endif /* !defined(NO_DYNAMIC) */
   }
   
   Label decompile_code(Label _code)
   {
   #ifdef NO_DYNAMIC
     return _code;
   #else /* !defined(NO_DYNAMIC) */
     Cell i;
     struct code_block_list *p;
     Address code=_code;
   
     /* first, check if we are in code at all */
     for (p = code_block_list;; p = p->next) {
       if (p == NULL)
         return code;
       if (code >= p->block && code < p->block+p->size)
         break;
     }
     /* reverse order because NOOP might match other prims */
     for (i=npriminfos-1; i>DOESJUMP; i--) {
       PrimInfo *pi=decomp_prims[i];
       if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
         return pi->start;
     }
     return code;
   #endif /* !defined(NO_DYNAMIC) */
   }
   
   #ifdef NO_IP
   int nbranchinfos=0;
   
   struct branchinfo {
     Label *targetptr; /* *(bi->targetptr) is the target */
     Cell *addressptr; /* store the target here */
   } branchinfos[100000];
   
   int ndoesexecinfos=0;
   struct doesexecinfo {
     int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
     Cell *xt; /* cfa of word whose does-code needs calling */
   } doesexecinfos[10000];
   
   /* definitions of N_execute etc. */
   #include "prim_num.i"
   
   void set_rel_target(Cell *source, Label target)
   {
     *source = ((Cell)target)-(((Cell)source)+4);
   }
   
   void register_branchinfo(Label source, Cell targetptr)
   {
     struct branchinfo *bi = &(branchinfos[nbranchinfos]);
     bi->targetptr = (Label *)targetptr;
     bi->addressptr = (Cell *)source;
     nbranchinfos++;
   }
   
   Cell *compile_prim1arg(Cell p)
   {
     int l = priminfos[p].length;
     Address old_code_here=code_here;
   
     assert(vm_prims[p]==priminfos[p].start);
     append_prim(p);
     return (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
   }
   
   Cell *compile_call2(Cell targetptr)
   {
     Cell *next_code_target;
     PrimInfo *pi = &priminfos[N_call2];
     Address old_code_here = append_prim(N_call2);
   
     next_code_target = (Cell *)(old_code_here + pi->immargs[0].offset);
     register_branchinfo(old_code_here + pi->immargs[1].offset, targetptr);
     return next_code_target;
   }
   #endif
   
   void finish_code(void)
   {
   #ifdef NO_IP
     Cell i;
   
     compile_prim1(NULL);
     for (i=0; i<ndoesexecinfos; i++) {
       struct doesexecinfo *dei = &doesexecinfos[i];
       branchinfos[dei->branchinfo].targetptr = DOES_CODE1((dei->xt));
     }
     ndoesexecinfos = 0;
     for (i=0; i<nbranchinfos; i++) {
       struct branchinfo *bi=&branchinfos[i];
       set_rel_target(bi->addressptr, *(bi->targetptr));
     }
     nbranchinfos = 0;
   #endif
     flush_to_here();
   }
   
   void compile_prim1(Cell *start)
   {
   #if defined(DOUBLY_INDIRECT)
     Label prim=(Label)*start;
     if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
       fprintf(stderr,"compile_prim encountered xt %p\n", prim);
       *start=(Cell)prim;
       return;
     } else {
       *start = (Cell)(prim-((Label)xts)+((Label)vm_prims));
       return;
     }
   #elif defined(NO_IP)
     static Cell *last_start=NULL;
     static Xt last_prim=NULL;
     /* delay work by one call in order to get relocated immargs */
   
     if (last_start) {
       unsigned i = last_prim-vm_prims;
       PrimInfo *pi=&priminfos[i];
       Cell *next_code_target=NULL;
   
       assert(i<npriminfos);
       if (i==N_execute||i==N_perform||i==N_lit_perform) {
         next_code_target = compile_prim1arg(N_set_next_code);
       }
       if (i==N_call) {
         next_code_target = compile_call2(last_start[1]);
       } else if (i==N_does_exec) {
         struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
         *compile_prim1arg(N_lit) = (Cell)PFA(last_start[1]);
         /* we cannot determine the callee now (last_start[1] may be a
            forward reference), so just register an arbitrary target, and
            register in dei that we need to fix this before resolving
            branches */
         dei->branchinfo = nbranchinfos;
         dei->xt = (Cell *)(last_start[1]);
         next_code_target = compile_call2(NULL);
       } else if (pi->start == NULL) { /* non-reloc */
         next_code_target = compile_prim1arg(N_set_next_code);
         set_rel_target(compile_prim1arg(N_abranch),*(Xt)last_prim);
       } else {
         unsigned j;
         Address old_code_here = append_prim(i);
   
         for (j=0; j<pi->nimmargs; j++) {
           struct immarg *ia = &(pi->immargs[j]);
           Cell argval = last_start[pi->nimmargs - j]; /* !! specific to prims */
           if (ia->rel) { /* !! assumption: relative refs are branches */
             register_branchinfo(old_code_here + ia->offset, argval);
           } else /* plain argument */
             *(Cell *)(old_code_here + ia->offset) = argval;
         }
       }
       if (next_code_target!=NULL)
         *next_code_target = (Cell)code_here;
     }
     if (start) {
       last_prim = (Xt)*start;
       *start = (Cell)code_here;
     }
     last_start = start;
     return;
   #elif !defined(NO_DYNAMIC)
     Label prim=(Label)*start;
     unsigned i;
     Address old_code_here;
   
     i = ((Xt)prim)-vm_prims;
     prim = *(Xt)prim;
     if (no_dynamic) {
       *start = (Cell)prim;
       return;
     }
     if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */
       append_jump();
       *start = (Cell)prim;
       return;
     }
     assert(priminfos[i].start = prim);
   #ifdef ALIGN_CODE
     /*  ALIGN_CODE;*/
   #endif
     assert(prim==priminfos[i].start);
     old_code_here = append_prim(i);
     last_jump = (priminfos[i].superend) ? 0 : i;
     *start = (Cell)old_code_here;
     return;
   #else /* !defined(DOUBLY_INDIRECT), no code replication */
     Label prim=(Label)*start;
   #if !defined(INDIRECT_THREADED)
     prim = *(Xt)prim;
   #endif
     *start = (Cell)prim;
     return;
   #endif /* !defined(DOUBLY_INDIRECT) */
   }
   
   Label compile_prim(Label prim)
   {
     Cell x=(Cell)prim;
     assert(0);
     compile_prim1(&x);
     return (Label)x;
   }
   
   #if defined(PRINT_SUPER_LENGTHS) && !defined(NO_DYNAMIC)
   Cell prim_length(Cell prim)
   {
     return priminfos[prim+DOESJUMP+1].length;
   }
 #endif  #endif
   
 Address loader(FILE *imagefile, char* filename)  Address loader(FILE *imagefile, char* filename)
Line 254 
Line 947 
   ImageHeader header;    ImageHeader header;
   Address image;    Address image;
   Address imp; /* image+preamble */    Address imp; /* image+preamble */
   Char magic[9];    Char magic[8];
     char magic7; /* size byte of magic number */
   Cell preamblesize=0;    Cell preamblesize=0;
   Label *symbols = engine(0,0,0,0,0);  
   Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;    Cell data_offset = offset_image ? 56*sizeof(Cell) : 0;
   UCell check_sum;    UCell check_sum;
   static char* endianstring[]= { "big","little" };    Cell ausize = ((RELINFOBITS ==  8) ? 0 :
                    (RELINFOBITS == 16) ? 1 :
                    (RELINFOBITS == 32) ? 2 : 3);
     Cell charsize = ((sizeof(Char) == 1) ? 0 :
                      (sizeof(Char) == 2) ? 1 :
                      (sizeof(Char) == 4) ? 2 : 3) + ausize;
     Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
                      (sizeof(Cell) == 2) ? 1 :
                      (sizeof(Cell) == 4) ? 2 : 3) + ausize;
     Cell sizebyte = (ausize << 5) + (charsize << 3) + (cellsize << 1) +
   #ifdef WORDS_BIGENDIAN
          0
   #else
          1
   #endif
       ;
   
     vm_prims = engine(0,0,0,0,0);
     check_prims(vm_prims);
 #ifndef DOUBLY_INDIRECT  #ifndef DOUBLY_INDIRECT
   check_sum = checksum(symbols);  #ifdef PRINT_SUPER_LENGTHS
     print_super_lengths();
   #endif
     check_sum = checksum(vm_prims);
 #else /* defined(DOUBLY_INDIRECT) */  #else /* defined(DOUBLY_INDIRECT) */
   check_sum = (UCell)symbols;    check_sum = (UCell)vm_prims;
 #endif /* defined(DOUBLY_INDIRECT) */  #endif /* defined(DOUBLY_INDIRECT) */
   
   do    do {
     {  
       if(fread(magic,sizeof(Char),8,imagefile) < 8) {        if(fread(magic,sizeof(Char),8,imagefile) < 8) {
         fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.2) image.\n",        fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.6) image.\n",
                 progname, filename);                  progname, filename);
         exit(1);          exit(1);
       }        }
       preamblesize+=8;        preamblesize+=8;
     }    } while(memcmp(magic,"Gforth3",7));
   while(memcmp(magic,"Gforth1",7));    magic7 = magic[7];
   if (debug) {    if (debug) {
     magic[8]='\0';      magic[7]='\0';
     fprintf(stderr,"Magic found: %s\n", magic);      fprintf(stderr,"Magic found: %s ", magic);
       print_sizes(magic7);
   }    }
   
   if(magic[7] != sizeof(Cell) +    if (magic7 != sizebyte)
 #ifdef WORDS_BIGENDIAN      {
        '0'        fprintf(stderr,"This image is:         ");
 #else        print_sizes(magic7);
        '1'        fprintf(stderr,"whereas the machine is ");
 #endif        print_sizes(sizebyte);
        )  
     { fprintf(stderr,"This image is %d bit %s-endian, whereas the machine is %d bit %s-endian.\n",  
               ((magic[7]-'0')&~1)*8, endianstring[magic[7]&1],  
               (int) sizeof(Cell)*8, endianstring[  
 #ifdef WORDS_BIGENDIAN  
                       0  
 #else  
                       1  
 #endif  
                       ]);  
       exit(-2);        exit(-2);
     };      };
   
   fread((void *)&header,sizeof(ImageHeader),1,imagefile);    fread((void *)&header,sizeof(ImageHeader),1,imagefile);
   if (dictsize==0)  
     dictsize = header.dict_size;    set_stack_sizes(&header);
   if (dsize==0)  
     dsize=header.data_stack_size;  
   if (rsize==0)  
     rsize=header.return_stack_size;  
   if (fsize==0)  
     fsize=header.fp_stack_size;  
   if (lsize==0)  
     lsize=header.locals_stack_size;  
   dictsize=maxaligned(dictsize);  
   dsize=maxaligned(dsize);  
   rsize=maxaligned(rsize);  
   lsize=maxaligned(lsize);  
   fsize=maxaligned(fsize);  
   
 #if HAVE_GETPAGESIZE  #if HAVE_GETPAGESIZE
   pagesize=getpagesize(); /* Linux/GNU libc offers this */    pagesize=getpagesize(); /* Linux/GNU libc offers this */
Line 328 
Line 1018 
   if (debug)    if (debug)
     fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);      fprintf(stderr,"pagesize=%ld\n",(unsigned long) pagesize);
   
   image = dict_alloc(preamblesize+dictsize+data_offset)+data_offset;    image = dict_alloc_read(imagefile, preamblesize+header.image_size,
   rewind(imagefile);  /* fseek(imagefile,0L,SEEK_SET); */                            preamblesize+dictsize, data_offset);
   if (clear_dictionary)  
     memset(image,0,dictsize);  
   fread(image,1,preamblesize+header.image_size,imagefile);  
   imp=image+preamblesize;    imp=image+preamblesize;
   if(header.base==0) {    alloc_stacks((ImageHeader *)imp);
     if (clear_dictionary)
       memset(imp+header.image_size, 0, dictsize-header.image_size);
     if(header.base==0 || header.base  == (Address)0x100) {
     Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;      Cell reloc_size=((header.image_size-1)/sizeof(Cell))/8+1;
     char reloc_bits[reloc_size];      char reloc_bits[reloc_size];
       fseek(imagefile, preamblesize+header.image_size, SEEK_SET);
     fread(reloc_bits,1,reloc_size,imagefile);      fread(reloc_bits,1,reloc_size,imagefile);
     relocate((Cell *)imp,reloc_bits,header.image_size,symbols);      relocate((Cell *)imp, reloc_bits, header.image_size, (Cell)header.base, vm_prims);
 #if 0  #if 0
     { /* let's see what the relocator did */      { /* let's see what the relocator did */
       FILE *snapshot=fopen("snapshot.fi","wb");        FILE *snapshot=fopen("snapshot.fi","wb");
Line 359 
Line 1050 
             progname, (unsigned long)(header.checksum),(unsigned long)check_sum);              progname, (unsigned long)(header.checksum),(unsigned long)check_sum);
     exit(1);      exit(1);
   }    }
   #ifdef DOUBLY_INDIRECT
     ((ImageHeader *)imp)->xt_base = xts;
   #endif
   fclose(imagefile);    fclose(imagefile);
   
   ((ImageHeader *)imp)->dict_size=dictsize;    /* unnecessary, except maybe for CODE words */
   ((ImageHeader *)imp)->data_stack_size=dsize;    /* FLUSH_ICACHE(imp, header.image_size);*/
   ((ImageHeader *)imp)->fp_stack_size=fsize;  
   ((ImageHeader *)imp)->return_stack_size=rsize;  
   ((ImageHeader *)imp)->locals_stack_size=lsize;  
   
   ((ImageHeader *)imp)->data_stack_base=my_alloc(dsize);  
   ((ImageHeader *)imp)->fp_stack_base=my_alloc(fsize);  
   ((ImageHeader *)imp)->return_stack_base=my_alloc(rsize);  
   ((ImageHeader *)imp)->locals_stack_base=my_alloc(lsize);  
   
   CACHE_FLUSH(imp, header.image_size);  
   
   return imp;    return imp;
 }  }
   
 int go_forth(Address image, int stack, Cell *entries)  /* pointer to last '/' or '\' in file, 0 if there is none. */
   char *onlypath(char *filename)
 {  {
   Cell *sp=(Cell*)(((ImageHeader *)image)->data_stack_base + dsize);    return strrchr(filename, DIRSEP);
   Float *fp=(Float *)(((ImageHeader *)image)->fp_stack_base + fsize);  }
   Cell *rp=(Cell *)(((ImageHeader *)image)->return_stack_base + rsize);  
   Address lp=((ImageHeader *)image)->locals_stack_base + lsize;  
   Xt *ip=(Xt *)(((ImageHeader *)image)->boot_entry);  
   int throw_code;  
   
   /* ensure that the cached elements (if any) are accessible */  FILE *openimage(char *fullfilename)
   IF_TOS(sp--);  {
   IF_FTOS(fp--);    FILE *image_file;
     char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
   
   for(;stack>0;stack--)    image_file=fopen(expfilename,"rb");
     *--sp=entries[stack-1];    if (image_file!=NULL && debug)
       fprintf(stderr, "Opened image file: %s\n", expfilename);
     return image_file;
   }
   
 #if !defined(MSDOS) && !defined(_WIN32) && !defined(__EMX__)  /* try to open image file concat(path[0:len],imagename) */
   get_winsize();  FILE *checkimage(char *path, int len, char *imagename)
 #endif  {
     int dirlen=len;
     char fullfilename[dirlen+strlen(imagename)+2];
   
   install_signal_handlers(); /* right place? */    memcpy(fullfilename, path, dirlen);
     if (fullfilename[dirlen-1]!=DIRSEP)
       fullfilename[dirlen++]=DIRSEP;
     strcpy(fullfilename+dirlen,imagename);
     return openimage(fullfilename);
   }
   
   if ((throw_code=setjmp(throw_jmp_buf))) {  FILE * open_image_file(char * imagename, char * path)
     static Cell signal_data_stack[8];  {
     static Cell signal_return_stack[8];    FILE * image_file=NULL;
     static Float signal_fp_stack[1];    char *origpath=path;
   
     signal_data_stack[7]=throw_code;    if(strchr(imagename, DIRSEP)==NULL) {
       /* first check the directory where the exe file is in !! 01may97jaw */
       if (onlypath(progname))
         image_file=checkimage(progname, onlypath(progname)-progname, imagename);
       if (!image_file)
         do {
           char *pend=strchr(path, PATHSEP);
           if (pend==NULL)
             pend=path+strlen(path);
           if (strlen(path)==0) break;
           image_file=checkimage(path, pend-path, imagename);
           path=pend+(*pend==PATHSEP);
         } while (image_file==NULL);
     } else {
       image_file=openimage(imagename);
     }
   
     return((int)engine(((ImageHeader *)image)->throw_entry,signal_data_stack+7,    if (!image_file) {
                        signal_return_stack+8,signal_fp_stack,0));      fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
               progname, imagename, origpath);
       exit(1);
   }    }
   
   return((int)engine(ip,sp,rp,fp,lp));    return image_file;
 }  }
   #endif
   
   #ifdef HAS_OS
 UCell convsize(char *s, UCell elemsize)  UCell convsize(char *s, UCell elemsize)
 /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number  /* converts s of the format [0-9]+[bekMGT]? (e.g. 25k) into the number
    of bytes.  the letter at the end indicates the unit, where e stands     of bytes.  the letter at the end indicates the unit, where e stands
Line 434 
Line 1145 
       m=1024*1024*1024;        m=1024*1024*1024;
     else if (strcmp(endp,"T")==0) {      else if (strcmp(endp,"T")==0) {
 #if (SIZEOF_CHAR_P > 4)  #if (SIZEOF_CHAR_P > 4)
       m=1024*1024*1024*1024;        m=1024L*1024*1024*1024;
 #else  #else
       fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);        fprintf(stderr,"%s: size specification \"%s\" too large for this machine\n", progname, endp);
       exit(1);        exit(1);
Line 447 
Line 1158 
   return n*m;    return n*m;
 }  }
   
 int onlypath(char *file)  void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
 { int i;  
   i=strlen(file);  
   while (i) {   if (file[i]=='\\' || file[i]=='/') break;  
                 i--; }  
   return (i);  
 }  
   
 FILE *openimage(char *fullfilename)  
 { FILE *image_file;  
   image_file=fopen(fullfilename,"rb");  
   if (image_file!=NULL && debug)  
      fprintf(stderr, "Opened image file: %s\n", fullfilename);  
   return (image_file);  
 }  
   
 FILE *checkimage(char *path, int len, char *imagename)  
 { int dirlen=len;  
   char fullfilename[dirlen+strlen(imagename)+2];  
   memcpy(fullfilename, path, dirlen);  
   if (fullfilename[dirlen-1]!='/')  
     fullfilename[dirlen++]='/';  
   strcpy(fullfilename+dirlen,imagename);  
   return (openimage(fullfilename));  
 }  
   
 int main(int argc, char **argv, char **env)  
 {  {
   char *path, *path1;    int c;
   char *imagename="gforth.fi";  
   FILE *image_file;  
   int c, retvalue;  
   
 #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)  
   /* turn on alignment checks on the 486.  
    * on the 386 this should have no effect. */  
   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");  
   /* this is unusable with Linux' libc.4.6.27, because this library is  
      not alignment-clean; we would have to replace some library  
      functions (e.g., memcpy) to make it work */  
 #endif  
   
   /* buffering of the user output device */  
   if (isatty(fileno(stdout))) {  
     fflush(stdout);  
     setvbuf(stdout,NULL,_IONBF,0);  
   }  
   
   progname = argv[0];  
   if ((path1=getenv("GFORTHPATH"))==NULL)  
     path1 = DEFAULTPATH;  
   
   opterr=0;    opterr=0;
   while (1) {    while (1) {
     int option_index=0;      int option_index=0;
     static struct option opts[] = {      static struct option opts[] = {
         {"appl-image", required_argument, NULL, 'a'},
       {"image-file", required_argument, NULL, 'i'},        {"image-file", required_argument, NULL, 'i'},
       {"dictionary-size", required_argument, NULL, 'm'},        {"dictionary-size", required_argument, NULL, 'm'},
       {"data-stack-size", required_argument, NULL, 'd'},        {"data-stack-size", required_argument, NULL, 'd'},
Line 518 
Line 1182 
       {"clear-dictionary", no_argument, &clear_dictionary, 1},        {"clear-dictionary", no_argument, &clear_dictionary, 1},
       {"die-on-signal", no_argument, &die_on_signal, 1},        {"die-on-signal", no_argument, &die_on_signal, 1},
       {"debug", no_argument, &debug, 1},        {"debug", no_argument, &debug, 1},
         {"no-super", no_argument, &no_super, 1},
         {"no-dynamic", no_argument, &no_dynamic, 1},
         {"dynamic", no_argument, &no_dynamic, 0},
       {0,0,0,0}        {0,0,0,0}
       /* no-init-file, no-rc? */        /* no-init-file, no-rc? */
     };      };
   
     c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vh", opts, &option_index);      c = getopt_long(argc, argv, "+i:m:d:r:f:l:p:vhoncsx", opts, &option_index);
   
     if (c==EOF)  
       break;  
     if (c=='?') {  
       optind--;  
       break;  
     }  
     switch (c) {      switch (c) {
     case 'i': imagename = optarg; break;      case EOF: return;
       case '?': optind--; return;
       case 'a': *imagename = optarg; return;
       case 'i': *imagename = optarg; break;
     case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;      case 'm': dictsize = convsize(optarg,sizeof(Cell)); break;
     case 'd': dsize = convsize(optarg,sizeof(Cell)); break;      case 'd': dsize = convsize(optarg,sizeof(Cell)); break;
     case 'r': rsize = convsize(optarg,sizeof(Cell)); break;      case 'r': rsize = convsize(optarg,sizeof(Cell)); break;
     case 'f': fsize = convsize(optarg,sizeof(Float)); break;      case 'f': fsize = convsize(optarg,sizeof(Float)); break;
     case 'l': lsize = convsize(optarg,sizeof(Cell)); break;      case 'l': lsize = convsize(optarg,sizeof(Cell)); break;
     case 'p': path1 = optarg; break;      case 'p': *path = optarg; break;
     case 'v': fprintf(stderr, "gforth %s\n", VERSION); exit(0);      case 'o': offset_image = 1; break;
       case 'n': offset_image = 0; break;
       case 'c': clear_dictionary = 1; break;
       case 's': die_on_signal = 1; break;
       case 'x': debug = 1; break;
       case 'v': fputs(PACKAGE_STRING"\n", stderr); exit(0);
     case 'h':      case 'h':
       fprintf(stderr, "Usage: %s [engine options] [image arguments]\n\        fprintf(stderr, "Usage: %s [engine options] ['--'] [image arguments]\n\
 Engine Options:\n\  Engine Options:\n\
     --appl-image FILE                 equivalent to '--image-file=FILE --'\n\
  --clear-dictionary                 Initialize the dictionary with 0 bytes\n\   --clear-dictionary                 Initialize the dictionary with 0 bytes\n\
  -d SIZE, --data-stack-size=SIZE    Specify data stack size\n\   -d SIZE, --data-stack-size=SIZE    Specify data stack size\n\
  --debug                            Print debugging information during startup\n\   --debug                            Print debugging information during startup\n\
  --die-on-signal                    exit instead of CATCHing some signals\n\   --die-on-signal                    exit instead of CATCHing some signals\n\
     --dynamic                         use dynamic native code\n\
  -f SIZE, --fp-stack-size=SIZE      Specify floating point stack size\n\   -f SIZE, --fp-stack-size=SIZE      Specify floating point stack size\n\
  -h, --help                         Print this message and exit\n\   -h, --help                         Print this message and exit\n\
  -i FILE, --image-file=FILE         Use image FILE instead of `gforth.fi'\n\   -i FILE, --image-file=FILE         Use image FILE instead of `gforth.fi'\n\
  -l SIZE, --locals-stack-size=SIZE  Specify locals stack size\n\   -l SIZE, --locals-stack-size=SIZE  Specify locals stack size\n\
  -m SIZE, --dictionary-size=SIZE    Specify Forth dictionary size\n\   -m SIZE, --dictionary-size=SIZE    Specify Forth dictionary size\n\
     --no-dynamic                      Use only statically compiled primitives\n\
  --no-offset-im                     Load image at normal position\n\   --no-offset-im                     Load image at normal position\n\
     --no-super                        No dynamically formed superinstructions\n\
  --offset-image                     Load image at a different position\n\   --offset-image                     Load image at a different position\n\
  -p PATH, --path=PATH               Search path for finding image and sources\n\   -p PATH, --path=PATH               Search path for finding image and sources\n\
  -r SIZE, --return-stack-size=SIZE  Specify return stack size\n\   -r SIZE, --return-stack-size=SIZE  Specify return stack size\n\
  -v, --version                      Print version and exit\n\    -v, --version                     Print engine version and exit\n\
 SIZE arguments consist of an integer followed by a unit. The unit can be\n\  SIZE arguments consist of an integer followed by a unit. The unit can be\n\
   `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n\    `b' (byte), `e' (element; default), `k' (KB), `M' (MB), `G' (GB) or `T' (TB).\n",
 \n\                argv[0]);
 Arguments of default image `gforth.fi':\n\        optind--;
  FILE                               load FILE (with `require')\n\        return;
  -e STRING, --evaluate STRING       interpret STRING (with `EVALUATE')\n\n\      }
 Report bugs to <bug-gforth@gnu.ai.mit.edu>\n",  
               argv[0]); exit(0);  
     }      }
   }    }
   path=path1;  #endif
   image_file=NULL;  
   
   if(strchr(imagename, '/')==NULL)  #ifdef INCLUDE_IMAGE
   extern Cell image[];
   extern const char reloc_bits[];
   #endif
   
   int main(int argc, char **argv, char **env)
   {    {
     /* first check the directory where the exe file is in !! 01may97jaw */  #ifdef HAS_OS
     if (onlypath(progname))    char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
       image_file=checkimage(progname, onlypath(progname), imagename);  #else
     if (!image_file)    char *path = DEFAULTPATH;
       do {  #endif
         char *pend=strchr(path, PATHSEP);  #ifndef INCLUDE_IMAGE
         if (pend==NULL)    char *imagename="gforth.fi";
           pend=path+strlen(path);    FILE *image_file;
         if (strlen(path)==0) break;    Address image;
         image_file=checkimage(path, pend-path, imagename);  #endif
         path=pend+(*pend==PATHSEP);    int retvalue;
       } while (image_file==NULL);  
   }  
   else  
   {  image_file=openimage(imagename);  
   }  
   
   if (!image_file)  #if defined(i386) && defined(ALIGNMENT_CHECK)
   { fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",    /* turn on alignment checks on the 486.
                   progname, imagename, path1);     * on the 386 this should have no effect. */
     exit(1);    __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
     /* this is unusable with Linux' libc.4.6.27, because this library is
        not alignment-clean; we would have to replace some library
        functions (e.g., memcpy) to make it work. Also GCC doesn't try to keep
        the stack FP-aligned. */
   #endif
   
     /* buffering of the user output device */
   #ifdef _IONBF
     if (isatty(fileno(stdout))) {
       fflush(stdout);
       setvbuf(stdout,NULL,_IONBF,0);
   }    }
   #endif
   
     progname = argv[0];
   
   #ifdef HAS_OS
     gforth_args(argc, argv, &path, &imagename);
   #endif
   
   #ifdef INCLUDE_IMAGE
     set_stack_sizes((ImageHeader *)image);
     if(((ImageHeader *)image)->base != image)
       relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
                (Label*)engine(0, 0, 0, 0, 0));
     alloc_stacks((ImageHeader *)image);
   #else
     image_file = open_image_file(imagename, path);
     image = loader(image_file, imagename);
   #endif
     gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
   
   {    {
     char path2[strlen(path1)+1];      char path2[strlen(path)+1];
     char *p1, *p2;      char *p1, *p2;
     Cell environ[]= {      Cell environ[]= {
       (Cell)argc-(optind-1),        (Cell)argc-(optind-1),
       (Cell)(argv+(optind-1)),        (Cell)(argv+(optind-1)),
       (Cell)strlen(path1),        (Cell)strlen(path),
       (Cell)path2};        (Cell)path2};
     argv[optind-1] = progname;      argv[optind-1] = progname;
     /*      /*
Line 608 
Line 1308 
        printf("%s\n", ((char **)(environ[1]))[i]);         printf("%s\n", ((char **)(environ[1]))[i]);
        */         */
     /* make path OS-independent by replacing path separators with NUL */      /* make path OS-independent by replacing path separators with NUL */
     for (p1=path1, p2=path2; *p1!='\0'; p1++, p2++)      for (p1=path, p2=path2; *p1!='\0'; p1++, p2++)
       if (*p1==PATHSEP)        if (*p1==PATHSEP)
         *p2 = '\0';          *p2 = '\0';
       else        else
         *p2 = *p1;          *p2 = *p1;
     *p2='\0';      *p2='\0';
     retvalue=go_forth(loader(image_file, imagename),4,environ);      retvalue = go_forth(image, 4, environ);
   #ifdef VM_PROFILING
       vm_print_profile(stderr);
   #endif
     deprep_terminal();      deprep_terminal();
     exit(retvalue);  
   }    }
     return retvalue;
 }  }

Generate output suitable for use with a patch program
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.97
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help