[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.19 and 1.67

version 1.19, Sun Jan 10 22:00:23 1999 UTC version 1.67, Fri Oct 4 19:17:06 2002 UTC
Line 1 
Line 1 
 /* command line interpretation, image loading etc. for Gforth  /* command line interpretation, image loading etc. for Gforth
   
   
   Copyright (C) 1995,1996,1997,1998 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"
Line 28 
Line 28 
 #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>
Line 48 
Line 50 
 /* increment this whenever the primitives change in an incompatible way */  /* increment this whenever the primitives change in an incompatible way */
   
 #ifndef DEFAULTPATH  #ifndef DEFAULTPATH
 #  define DEFAULTPATH "~+"  #  define DEFAULTPATH "."
 #endif  #endif
   
 #ifdef MSDOS  #ifdef MSDOS
 jmp_buf throw_jmp_buf;  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 72 
Line 74 
 int die_on_signal=0;  int die_on_signal=0;
 #ifndef INCLUDE_IMAGE  #ifndef INCLUDE_IMAGE
 static int clear_dictionary=0;  static int clear_dictionary=0;
 static size_t pagesize=0;  UCell pagesize=1;
   char *progname;
   #else
   char *progname = "gforth";
   int optind = 1;
 #endif  #endif
   
   Address code_area=0;
   Address code_here=0; /* does for code-area what HERE does for the dictionary */
   Address start_flush=0; /* start of unflushed code */
   
   static int no_super=0;   /* true if compile_prim should not fuse prims */
   /* --no-dynamic by default on gcc versions >=3.1 (it works with 3.0.4,
      but not with 3.2) */
   #if (__GNUC__>2 && __GNUC_MINOR__>=1)
   static int no_dynamic=1; /* true if compile_prim should not generate code */
   #else
   static int no_dynamic=0; /* true if compile_prim should not generate code */
   #endif
   
   #ifdef HAS_DEBUG
 static int debug=0;  static int debug=0;
 char *progname;  #else
   # define debug 0
   # 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.4.0 -i\n")   *  "#! binary-path -i\n" (e.g., "#! /usr/local/bin/gforth-0.4.0 -i\n")
Line 89 
Line 127 
  *              bit 0:   endian, big=0, little=1.   *              bit 0:   endian, big=0, little=1.
  *  The magic are always 8 octets, no matter what the native AU/character size is   *  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 101 
Line 139 
  * 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
  */   */
   
 typedef struct {  void relocate(Cell *image, const char *bitstring,
   Address base;         /* base address of image (0 if relocatable) */                int size, int base, Label symbols[])
   UCell checksum;       /* checksum of ca's to protect against some  
                            incompatible binary/executable combinations  
                            (0 if relocatable) */  
   UCell image_size;     /* all sizes in bytes */  
   UCell dict_size;  
   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, const char *bitstring, int size, Label symbols[])  
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;    int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;
   Cell token;    Cell token;
   char bits;    char bits;
 /*   static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/    Cell max_symbols;
     /*
      * A virtial 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); */  
   
   for(k=0; k<=steps; k++)  /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
   
     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) {      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 & (1U << (RELINFOBITS-1))) {        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((token=image[i])<0)          token=image[i];
           switch(token)          if(token<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)
Line 154 
Line 185 
             case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;              case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); 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          :
 /*            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(token));                if (CF((token | 0x4000))<max_symbols) {
                   image[i]=(Cell)CFA(CF(token));
   #ifdef DIRECT_THREADED
                   if ((token & 0x4000) == 0) /* threade code, no CFA */
                     image[i] = (Cell)compile_prim((Label)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],VERSION);
             }              }
         else          else {
           image[i]+=(Cell)image;            // if base is > 0: 0 is a null reference so don't adjust
             if (token>=base) {
               image[i]+=(Cell)start;
       }        }
     }      }
 }  }
       }
     }
     ((ImageHeader*)(image))->base = (Address) image;
   }
   
 UCell checksum(Label symbols[])  UCell checksum(Label symbols[])
 {  {
Line 205 
Line 249 
   return r;    return r;
 }  }
   
 Address my_alloc(Cell size)  
 {  
 #if HAVE_MMAP  
   static Address next_address=0;    static Address next_address=0;
   void after_alloc(Address r, Cell size)
   {
     if (r != (Address)-1) {
       if (debug)
         fprintf(stderr, "success, address=$%lx\n", (long) r);
       if (pagesize != 1)
         next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
     } else {
       if (debug)
         fprintf(stderr, "failed: %s\n", strerror(errno));
     }
   }
   
   #ifndef MAP_FAILED
   #define MAP_FAILED ((Address) -1)
   #endif
   #ifndef MAP_FILE
   # define MAP_FILE 0
   #endif
   #ifndef MAP_PRIVATE
   # define MAP_PRIVATE 0
   #endif
   
   #if defined(HAVE_MMAP)
   static Address alloc_mmap(Cell size)
   {
   Address r;    Address r;
   
 #if defined(MAP_ANON)  #if defined(MAP_ANON)
Line 218 
Line 285 
 #else /* !defined(MAP_ANON) */  #else /* !defined(MAP_ANON) */
   /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are    /* Ultrix (at least) does not define MAP_FILE and MAP_PRIVATE (both are
      apparently defaults) */       apparently defaults) */
 #ifndef MAP_FILE  
 # define MAP_FILE 0  
 #endif  
 #ifndef MAP_PRIVATE  
 # define MAP_PRIVATE 0  
 #endif  
   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 239 
Line 300 
     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)  
 #else  #if defined(HAVE_MMAP)
 #define dict_alloc(size) my_alloc(size)    if (offset==0) {
 #endif      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)  void set_stack_sizes(ImageHeader * header)
 {  {
Line 293 
Line 370 
   header->fp_stack_base=my_alloc(fsize);    header->fp_stack_base=my_alloc(fsize);
   header->return_stack_base=my_alloc(rsize);    header->return_stack_base=my_alloc(rsize);
   header->locals_stack_base=my_alloc(lsize);    header->locals_stack_base=my_alloc(lsize);
     code_here = start_flush = code_area = my_alloc(dictsize);
 }  }
   
   #warning You can ignore the warnings about clobbered variables in go_forth
 int go_forth(Address image, int stack, Cell *entries)  int go_forth(Address image, int stack, Cell *entries)
 {  {
   ImageHeader *image_header = (ImageHeader *)image;    volatile ImageHeader *image_header = (ImageHeader *)image;
   Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);    Cell *sp0=(Cell*)(image_header->data_stack_base + dsize);
   Float *fp0=(Float *)(image_header->fp_stack_base + fsize);  
   Cell *rp0=(Cell *)(image_header->return_stack_base + rsize);    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;    Address lp0=image_header->locals_stack_base + lsize;
   Xt *ip0=(Xt *)(image_header->boot_entry);    Xt *ip0=(Xt *)(image_header->boot_entry);
 #ifdef SYSSIGNALS  #ifdef SYSSIGNALS
Line 308 
Line 390 
 #endif  #endif
   
   /* ensure that the cached elements (if any) are accessible */    /* ensure that the cached elements (if any) are accessible */
   IF_TOS(sp0--);    IF_spTOS(sp0--);
   IF_FTOS(fp0--);    IF_fpTOS(fp0--);
   
   for(;stack>0;stack--)    for(;stack>0;stack--)
     *--sp0=entries[stack-1];      *--sp0=entries[stack-1];
   
 #if !defined(MSDOS) && !defined(SHARC) && !defined(_WIN32) && !defined(__EMX__)  #ifdef SYSSIGNALS
   get_winsize();    get_winsize();
 #endif  
   
 #ifdef SYSSIGNALS  
   install_signal_handlers(); /* right place? */    install_signal_handlers(); /* right place? */
   
   if ((throw_code=setjmp(throw_jmp_buf))) {    if ((throw_code=setjmp(throw_jmp_buf))) {
Line 329 
Line 409 
     signal_data_stack[7]=throw_code;      signal_data_stack[7]=throw_code;
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
     if (rp <= rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {      /* fprintf(stderr,"\nrp=%ld\n",(long)rp); */
       if (rp <= orig_rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {
       /* no rstack overflow or underflow */        /* no rstack overflow or underflow */
       rp0 = rp;        rp0 = rp;
       *--rp0 = ip;        *--rp0 = (Cell)saved_ip;
     }      }
     else /* I love non-syntactic ifdefs :-) */      else /* I love non-syntactic ifdefs :-) */
 #endif  #endif
     rp0 = signal_return_stack+8;      rp0 = signal_return_stack+8;
       /* fprintf(stderr, "rp=$%x\n",rp0);*/
   
     return((int)engine(image_header->throw_entry, signal_data_stack+7,      return((int)(Cell)engine(image_header->throw_entry, signal_data_stack+7,
                        rp0, signal_fp_stack, 0));                         rp0, signal_fp_stack, 0));
   }    }
 #endif  #endif
   
   return((int)engine(ip0,sp0,rp0,fp0,lp0));    return((int)(Cell)engine(ip0,sp0,rp0,fp0,lp0));
 }  }
   
   
 #ifndef INCLUDE_IMAGE  #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));
   }
   
   typedef struct {
     Label start;
     Cell length; /* excluding the jump */
     char super_end; /* true if primitive ends superinstruction, i.e.,
                        unconditional branch, execute, etc. */
   } PrimInfo;
   
   PrimInfo *priminfos;
   Cell npriminfos=0;
   
   void check_prims(Label symbols1[])
   {
     int i;
     Label *symbols2;
     static char superend[]={
   #include "prim_superend.i"
     };
   
     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;
   
   #if defined(IS_NEXT_JUMP) && !defined(DOUBLY_INDIRECT)
     if (no_dynamic)
       return;
     symbols2=engine2(0,0,0,0,0);
     priminfos = calloc(i,sizeof(PrimInfo));
     for (i=DOESJUMP+1; symbols1[i+1]!=0; i++) {
       int prim_len=symbols1[i+1]-symbols1[i];
       PrimInfo *pi=&priminfos[i];
       int j;
       pi->super_end = superend[i-DOESJUMP-1]|no_super;
       for (j=prim_len-IND_JUMP_LENGTH; ; j--) {
         if (IS_NEXT_JUMP(symbols1[i]+j)) {
           prim_len = j;
           if (pi->super_end)
             prim_len += IND_JUMP_LENGTH; /* include the jump */
           break;
         }
         if (j==0) { /* NEXT jump not found, e.g., execute */
           if (!pi->super_end && debug)
             fprintf(stderr, "NEXT jump not found for primitive %d, making it super_end\n", i);
           pi->super_end = 1;
           break;
         }
       }
       pi->length = prim_len;
       /* fprintf(stderr,"checking primitive %d: memcmp(%p, %p, %d)\n",
          i, symbols1[i], symbols2[i], prim_len);*/
       if (memcmp(symbols1[i],symbols2[i],prim_len)!=0) {
         if (debug)
           fprintf(stderr,"Primitive %d not relocatable: memcmp(%p, %p, %d)\n",
                   i, symbols1[i], symbols2[i], prim_len);
       } else {
         pi->start = symbols1[i];
         if (debug)
           fprintf(stderr,"Primitive %d relocatable: start %p, length %ld, super_end %d\n",
                   i, pi->start, pi->length, pi->super_end);
       }
     }
   #endif
   }
   
   Label compile_prim(Label prim)
   {
   #if defined(DOUBLY_INDIRECT)
     if (prim<((Label)(xts+DOESJUMP)) || prim>((Label)(xts+npriminfos))) {
       fprintf(stderr,"compile_prim encountered xt %p\n", prim);
       return prim;
     } else
       return prim-((Label)xts)+((Label)vm_prims);
   #elif defined(IND_JUMP_LENGTH) && !defined(VM_PROFILING) && !defined(INDIRECT_THREADED)
     unsigned i;
     Address old_code_here=code_here;
     static Address last_jump=0;
   
     i = ((Xt)prim)-vm_prims;
     prim = *(Xt)prim;
     if (no_dynamic)
       return prim;
     if (i>=npriminfos || priminfos[i].start == 0) { /* not a relocatable prim */
       if (last_jump) { /* make sure the last sequence is complete */
         memcpy(code_here, last_jump, IND_JUMP_LENGTH);
         code_here += IND_JUMP_LENGTH;
         last_jump = 0;
         FLUSH_ICACHE(start_flush, code_here-start_flush);
         start_flush=code_here;
       }
       return prim;
     }
     assert(priminfos[i].start = prim);
   #ifdef ALIGN_CODE
     ALIGN_CODE;
   #endif
     memcpy(code_here, (Address)prim, priminfos[i].length);
     code_here += priminfos[i].length;
     last_jump = (priminfos[i].super_end) ? 0 : (prim+priminfos[i].length);
     if (last_jump == 0) {
       FLUSH_ICACHE(start_flush, code_here-start_flush);
       start_flush=code_here;
     }
     return (Label)old_code_here;
   #else /* !defined(DOUBLY_INDIRECT), no code replication */
   #if !defined(INDIRECT_THREADED)
     prim = *(Xt)prim;
   #endif
     return prim;
   #endif /* !defined(DOUBLY_INDIRECT) */
   }
   
   #ifdef PRINT_SUPER_LENGTHS
   Cell prim_length(Cell prim)
   {
     return priminfos[prim+DOESJUMP+1].length;
   }
   #endif
   
 Address loader(FILE *imagefile, char* filename)  Address loader(FILE *imagefile, char* filename)
 /* returns the address of the image proper (after the preamble) */  /* returns the address of the image proper (after the preamble) */
 {  {
Line 356 
Line 576 
   Char magic[8];    Char magic[8];
   char magic7; /* size byte of magic number */    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 :    Cell ausize = ((RELINFOBITS ==  8) ? 0 :
                  (RELINFOBITS == 16) ? 1 :                   (RELINFOBITS == 16) ? 1 :
                  (RELINFOBITS == 32) ? 2 : 3);                   (RELINFOBITS == 32) ? 2 : 3);
Line 369 
Line 587 
   Cell cellsize = ((sizeof(Cell) == 1) ? 0 :    Cell cellsize = ((sizeof(Cell) == 1) ? 0 :
                    (sizeof(Cell) == 2) ? 1 :                     (sizeof(Cell) == 2) ? 1 :
                    (sizeof(Cell) == 4) ? 2 : 3) + ausize;                     (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 {
Line 388 
Line 617 
   magic7 = magic[7];    magic7 = magic[7];
   if (debug) {    if (debug) {
     magic[7]='\0';      magic[7]='\0';
     fprintf(stderr,"Magic found: %s %s endian, cell=%d bytes, char=%d bytes, au=%d bytes\n",      fprintf(stderr,"Magic found: %s ", magic);
             magic,      print_sizes(magic7);
             endianstring[!(magic[7] & 1)],  
             1 << ((magic7 >> 1) & 3),  
             1 << ((magic7 >> 3) & 3),  
             1 << ((magic7 >> 5) & 3));  
   }    }
   
   if(magic7 != (ausize << 5) + (charsize << 3) + (cellsize << 1) +    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 cell, %d bit char, %d bit address unit %s-endian,\n"  
               "whereas the machine is %d bit cell, %d bit char, %d bit address unit, %s-endian.\n",  
               (1<<((magic7>>1)&3))*8,  
               (1<<((magic7>>3)&3))*8,  
               (1<<((magic7>>5)&3))*8,  
               endianstring[magic7&1],  
               (1<<cellsize)*8,  
               (1<<charsize)*8,  
               (1<<ausize)*8,  
               endianstring[  
 #ifdef WORDS_BIGENDIAN  
                       0  
 #else  
                       1  
 #endif  
                       ]);  
       exit(-2);        exit(-2);
     };      };
   
Line 436 
Line 644 
   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  == 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, 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 467 
Line 676 
             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);
   
   alloc_stacks((ImageHeader *)imp);    /* unnecessary, except maybe for CODE words */
     /* FLUSH_ICACHE(imp, header.image_size);*/
   CACHE_FLUSH(imp, header.image_size);  
   
   return imp;    return imp;
 }  }
   
   /* index of last '/' or '\' in file, 0 if there is none. !! Hmm, could
      be implemented with strrchr and the separator should be
      OS-dependent */
 int onlypath(char *file)  int onlypath(char *file)
 {  {
   int i;    int i;
Line 490 
Line 704 
 FILE *openimage(char *fullfilename)  FILE *openimage(char *fullfilename)
 {  {
   FILE *image_file;    FILE *image_file;
     char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);
   
   image_file=fopen(fullfilename,"rb");    image_file=fopen(expfilename,"rb");
   if (image_file!=NULL && debug)    if (image_file!=NULL && debug)
     fprintf(stderr, "Opened image file: %s\n", fullfilename);      fprintf(stderr, "Opened image file: %s\n", expfilename);
   return image_file;    return image_file;
 }  }
   
   /* try to open image file concat(path[0:len],imagename) */
 FILE *checkimage(char *path, int len, char *imagename)  FILE *checkimage(char *path, int len, char *imagename)
 {  {
   int dirlen=len;    int dirlen=len;
Line 512 
Line 728 
 FILE * open_image_file(char * imagename, char * path)  FILE * open_image_file(char * imagename, char * path)
 {  {
   FILE * image_file=NULL;    FILE * image_file=NULL;
     char *origpath=path;
   
   if(strchr(imagename, '/')==NULL) {    if(strchr(imagename, '/')==NULL) {
     /* first check the directory where the exe file is in !! 01may97jaw */      /* first check the directory where the exe file is in !! 01may97jaw */
Line 532 
Line 749 
   
   if (!image_file) {    if (!image_file) {
     fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",      fprintf(stderr,"%s: cannot open image file %s in path %s for reading\n",
             progname, imagename, path);              progname, imagename, origpath);
     exit(1);      exit(1);
   }    }
   
Line 562 
Line 779 
       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 583 
Line 800 
   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 598 
Line 816 
       {"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 EOF: return;
       case '?': optind--; return;
       case 'a': *imagename = optarg; return;
     case 'i': *imagename = optarg; break;      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;
Line 618 
Line 836 
     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': *path = optarg; break;      case 'p': *path = optarg; break;
       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': fprintf(stderr, "gforth %s\n", VERSION); exit(0);      case 'v': fprintf(stderr, "gforth %s\n", VERSION); 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",
               argv[0]);                argv[0]);
       optind--;        optind--;
       return;        return;
       exit(0);  
     }      }
   }    }
 }  }
Line 652 
Line 878 
 extern const char reloc_bits[];  extern const char reloc_bits[];
 #endif  #endif
   
   DCell double2ll(Float r)
   {
   #ifndef BUGGY_LONG_LONG
     return (DCell)(r);
   #else
     DCell d;
     d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
     d.lo = r-ldexp((Float)d.hi,CELL_BITS);
     return d;
   #endif
   }
   
 int main(int argc, char **argv, char **env)  int main(int argc, char **argv, char **env)
 {  {
   #ifdef HAS_OS
   char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;    char *path = getenv("GFORTHPATH") ? : DEFAULTPATH;
   #else
     char *path = DEFAULTPATH;
   #endif
 #ifndef INCLUDE_IMAGE  #ifndef INCLUDE_IMAGE
   char *imagename="gforth.fi";    char *imagename="gforth.fi";
   FILE *image_file;    FILE *image_file;
Line 662 
Line 904 
 #endif  #endif
   int retvalue;    int retvalue;
   
 #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)  #if defined(i386) && defined(ALIGNMENT_CHECK)
   /* turn on alignment checks on the 486.    /* turn on alignment checks on the 486.
    * on the 386 this should have no effect. */     * on the 386 this should have no effect. */
   __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");    __asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
Line 688 
Line 930 
   
 #ifdef INCLUDE_IMAGE  #ifdef INCLUDE_IMAGE
   set_stack_sizes((ImageHeader *)image);    set_stack_sizes((ImageHeader *)image);
   relocate(image, reloc_bits, ((ImageHeader*)&image)->image_size, (Label*)engine(0, 0, 0, 0, 0));    if(((ImageHeader *)image)->base != image)
       relocate(image, reloc_bits, ((ImageHeader *)image)->image_size,
                (Label*)engine(0, 0, 0, 0, 0));
   alloc_stacks((ImageHeader *)image);    alloc_stacks((ImageHeader *)image);
 #else  #else
   image_file = open_image_file(imagename, path);    image_file = open_image_file(imagename, path);
   image = loader(image_file, imagename);    image = loader(image_file, imagename);
 #endif  #endif
     gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
   
   {    {
     char path2[strlen(path)+1];      char path2[strlen(path)+1];
Line 716 
Line 961 
         *p2 = *p1;          *p2 = *p1;
     *p2='\0';      *p2='\0';
     retvalue = go_forth(image, 4, environ);      retvalue = go_forth(image, 4, environ);
   #ifdef VM_PROFILING
       vm_print_profile(stderr);
   #endif
     deprep_terminal();      deprep_terminal();
   }    }
   return retvalue;    return retvalue;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help