[gforth] / gforth / engine / main.c  

gforth: gforth/engine/main.c

Diff for /gforth/engine/main.c between version 1.29 and 1.237

version 1.29, Sat Jul 24 13:07:23 1999 UTC version 1.237, Fri Nov 11 22:22:05 2011 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,2003,2004,2005,2006,2007,2008,2009,2010 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
   Gforth is free software; you can redistribute it and/or    Gforth is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License    modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2    as published by the Free Software Foundation, either version 3
   of the License, or (at your option) any later version.    of the License, or (at your option) any later version.
   
   This program is distributed in the hope that it will be useful,    This program is distributed in the hope that it will be useful,
Line 16 
Line 16 
   GNU General Public License for more details.    GNU General Public License for more details.
   
   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, see http://www.gnu.org/licenses/.
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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 28 
 #include <string.h>  #include <string.h>
 #include <math.h>  #include <math.h>
 #include <sys/types.h>  #include <sys/types.h>
   #ifdef HAVE_ALLOCA_H
   #include <alloca.h>
   #endif
   #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>
   #include <signal.h>
   
 #ifndef STANDALONE  #ifndef STANDALONE
 #if HAVE_SYS_MMAN_H  #if HAVE_SYS_MMAN_H
 #include <sys/mman.h>  #include <sys/mman.h>
 #endif  #endif
 #endif  #endif
 #include "forth.h"  
 #include "io.h"  #include "io.h"
 #include "getopt.h"  #include "getopt.h"
 #ifdef STANDALONE  #ifndef STANDALONE
 #include <systypes.h>  #include <locale.h>
   #endif
   
   /* output rules etc. for burg with --debug and --print-sequences */
   /* #define BURG_FORMAT*/
   
   typedef enum prim_num {
   /* definitions of N_execute etc. */
   #include PRIM_NUM_I
     N_START_SUPER
   } PrimNum;
   
   /* global variables for engine.c
      We put them here because engine.c is compiled several times in
      different ways for the same engine. */
   Cell *gforth_SP;
   Float *gforth_FP;
   Address gforth_UP=NULL;
   Cell *gforth_RP;
   Address gforth_LP;
   
   #ifndef HAS_LINKBACK
   void * gforth_pointers[] = {
     (void*)&gforth_SP,
     (void*)&gforth_FP,
     (void*)&gforth_LP,
     (void*)&gforth_RP,
     (void*)&gforth_UP,
     (void*)gforth_engine
   #ifdef HAS_FILE
     ,
     (void*)cstr,
     (void*)tilde_cstr
   #endif
   };
   #endif
   
   #ifdef HAS_FFCALL
   
   #include <callback.h>
   
   va_alist gforth_clist;
   
   void gforth_callback(Xt* fcall, void * alist)
   {
     /* save global valiables */
     Cell *rp = gforth_RP;
     Cell *sp = gforth_SP;
     Float *fp = gforth_FP;
     Address lp = gforth_LP;
     va_alist clist = gforth_clist;
   
     gforth_clist = (va_alist)alist;
   
     gforth_engine(fcall, sp, rp, fp, lp sr_call);
   
     /* restore global variables */
     gforth_RP = rp;
     gforth_SP = sp;
     gforth_FP = fp;
     gforth_LP = lp;
     gforth_clist = clist;
   }
 #endif  #endif
   
   #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) */
   #if defined(GLOBALS_NONRELOC)
   saved_regs saved_regs_v;
   saved_regs *saved_regs_p = &saved_regs_v;
   #else /* !defined(GLOBALS_NONRELOC) */
   Xt *saved_ip;
   Cell *rp;
   #endif /* !defined(GLOBALS_NONRELOC) */
   #endif /* !defined(GFORTH_DEBUGGING) */
   
   #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 */
   
 #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 70 
Line 173 
 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;
   int ignore_async_signals=0;
 #ifndef INCLUDE_IMAGE  #ifndef INCLUDE_IMAGE
 static int clear_dictionary=0;  static int clear_dictionary=0;
 UCell pagesize=1;  UCell pagesize=1;
Line 78 
Line 182 
 char *progname = "gforth";  char *progname = "gforth";
 int optind = 1;  int optind = 1;
 #endif  #endif
 static int debug=0;  #ifndef MAP_NORESERVE
   #define MAP_NORESERVE 0
   #endif
   /* IF you have an old Cygwin, this may help:
   #ifdef __CYGWIN__
   #define MAP_NORESERVE 0
   #endif
   */
   static int map_noreserve=MAP_NORESERVE;
   
   #define CODE_BLOCK_SIZE (512*1024) /* !! overflow handling for -native */
   Address code_area=0;
   Cell code_area_size = CODE_BLOCK_SIZE;
   Address code_here; /* does for code-area what HERE does for the dictionary */
   Address start_flush=NULL; /* 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 */
   static int print_metrics=0; /* if true, print metrics on exit */
   static int static_super_number = 10000; /* number of ss used if available */
   #define MAX_STATE 9 /* maximum number of states */
   static int maxstates = MAX_STATE; /* number of states for stack caching */
   static int ss_greedy = 0; /* if true: use greedy, not optimal ss selection */
   static int diag = 0; /* if true: print diagnostic informations */
   static int tpa_noequiv = 0;     /* if true: no state equivalence checking */
   static int tpa_noautomaton = 0; /* if true: no tree parsing automaton */
   static int tpa_trace = 0; /* if true: data for line graph of new states etc. */
   static int print_sequences = 0; /* print primitive sequences for optimization */
   static int relocs = 0;
   static int nonrelocs = 0;
   
   #ifdef HAS_DEBUG
   int debug=0;
   # define debugp(x...) do { if (debug) fprintf(x); } while (0)
   #else
   # define perror(x...)
   # define fprintf(x...)
   # define debugp(x...)
   #endif
   
 ImageHeader *gforth_header;  ImageHeader *gforth_header;
   Label *vm_prims;
   #ifdef DOUBLY_INDIRECT
   Label *xts; /* same content as vm_prims, but should only be used for xts */
   #endif
   
   #ifndef NO_DYNAMIC
   #ifndef CODE_ALIGNMENT
   #define CODE_ALIGNMENT 0
   #endif
   
   #define MAX_IMMARGS 2
   
   typedef struct {
     Label start; /* NULL if not relocatable */
     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;
   
   const char const* const prim_names[]={
   #include PRIM_NAMES_I
   };
   
   void init_ss_cost(void);
   
   static int is_relocatable(int p)
   {
     return !no_dynamic && priminfos[p].start != NULL;
   }
   #else /* defined(NO_DYNAMIC) */
   static int is_relocatable(int p)
   {
     return 0;
   }
   #endif /* defined(NO_DYNAMIC) */
   
   #ifdef MEMCMP_AS_SUBROUTINE
   int gforth_memcmp(const char * s1, const char * s2, size_t n)
   {
     return memcmp(s1, s2, n);
   }
   #endif
   
   static Cell max(Cell a, Cell b)
   {
     return a>b?a:b;
   }
   
   static Cell min(Cell a, Cell b)
   {
     return a<b?a:b;
   }
   
   #ifndef STANDALONE
 /* 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")
  *   padding to a multiple of 8   *   padding to a multiple of 8
  *   magic: "Gforth2x" means format 0.4,   *   magic: "Gforth4x" means format 0.8,
  *              where x is a byte with   *              where x is a byte with
  *              bit 7:   reserved = 0   *              bit 7:   reserved = 0
  *              bit 6:5: address unit size 2^n octets   *              bit 6:5: address unit size 2^n octets
Line 103 
Line 311 
  * If the word =-1 (CF_NIL), the address is NIL,   * If the word =-1 (CF_NIL), the address is NIL,
  * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)   * If the word is <CF_NIL and >CF(DODOES), it's a CFA (:, Create, ...)
  * 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>,   * !! ABI-CODE and ;ABI-CODE
  *                                      possibly containing a jump to dodoes)   * If the word is <CF(DOER_MAX) and bit 14 is set, it's the xt of a primitive
  * If the word is <CF(DOESJUMP), it's a primitive   * If the word is <CF(DOER_MAX) 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
  */   */
   
 void relocate(Cell *image, const char *bitstring, int size, Label symbols[])  Cell groups[32] = {
     0,
     0
   #undef GROUP
   #undef GROUPADD
   #define GROUPADD(n) +n
   #define GROUP(x, n) , 0
   #include PRIM_GRP_I
   #undef GROUP
   #undef GROUPADD
   #define GROUP(x, n)
   #define GROUPADD(n)
   };
   
   static unsigned char *branch_targets(Cell *image, const unsigned char *bitstring,
                                 int size, Cell base)
        /* produce a bitmask marking all the branch targets */
   {
     int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
     Cell token;
     unsigned char bits;
     unsigned char *result=malloc(steps);
   
     memset(result, 0, steps);
     for(k=0; k<steps; k++) {
       for(j=0, bits=bitstring[k]; j<RELINFOBITS; j++, i++, bits<<=1) {
         if(bits & (1U << (RELINFOBITS-1))) {
           assert(i*sizeof(Cell) < size);
           token=image[i];
           if (token>=base) { /* relocatable address */
             UCell bitnum=(token-base)/sizeof(Cell);
             if (bitnum/RELINFOBITS < (UCell)steps)
               result[bitnum/RELINFOBITS] |= 1U << ((~bitnum)&(RELINFOBITS-1));
           }
         }
       }
     }
     return result;
   }
   
   void gforth_relocate(Cell *image, const Char *bitstring,
                        UCell size, Cell base, Label symbols[])
 {  {
   int i=0, j, k, steps=(size/sizeof(Cell))/RELINFOBITS;    int i=0, j, k, steps=(((size-1)/sizeof(Cell))/RELINFOBITS)+1;
   Cell token;    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));
     unsigned char *targets = branch_targets(image, bitstring, size, base);
   
     /* group index into table */
     if(groups[31]==0) {
       int groupsum=0;
       for(i=0; i<32; i++) {
         groupsum += groups[i];
         groups[i] = groupsum;
         /* printf("group[%d]=%d\n",i,groupsum); */
       }
       i=0;
     }
   
   /* printf("relocating to %x[%x] start=%x base=%x\n", image, size, start, base); */
   
 /*  printf("relocating %x[%x]\n", image, size); */    for (max_symbols=0; symbols[max_symbols]!=0; max_symbols++)
       ;
     max_symbols--;
   
   for(k=0; k<=steps; k++)    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(bits & (1U << (RELINFOBITS-1))) {
         /* fprintf(stderr,"relocate: image[%d]=%d\n", i, image[i]);*/          assert(i*sizeof(Cell) < size);
         if((token=image[i])<0)          /* fprintf(stderr,"relocate: image[%d]=%d of %d\n", i, image[i], size/sizeof(Cell)); */
           switch(token)          token=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)   :
             case CF(DOVAR)   :              case CF(DOVAR)   :
             case CF(DOCON)   :              case CF(DOCON)   :
               case CF(DOVAL)   :
             case CF(DOUSER)  :              case CF(DOUSER)  :
             case CF(DODEFER) :              case CF(DODEFER) :
             case CF(DOFIELD) : MAKE_CF(image+i,symbols[CF(token)]); break;              case CF(DOFIELD) :
             case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;  
 #endif /* !defined(DOUBLY_INDIRECT) */  
             case CF(DODOES)  :              case CF(DODOES)  :
               MAKE_DOES_CF(image+i,image[i+1]+((Cell)image));              case CF(DOABICODE) :
               break;              case CF(DOSEMIABICODE):
             default          :                MAKE_CF(image+i,symbols[CF(token)]); break;
 /*            printf("Code field generation image[%x]:=CA(%x)\n",  #endif /* !defined(DOUBLY_INDIRECT) */
               default          : /* backward compatibility */
   /*            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 */
                     if (targets[k] & (1U<<(RELINFOBITS-1-j)))
                       compile_prim1(0);
                     compile_prim1(&image[i]);
                   }
   #endif
                 } else
                   fprintf(stderr,"Primitive %ld used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n",(long)CF(token),(long)&image[i], 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 */
                   if (targets[k] & (1U<<(RELINFOBITS-1-j)))
                     compile_prim1(0);
                   compile_prim1(&image[i]);
                 }
   #endif
               } else
                 fprintf(stderr,"Primitive %lx, %d of group %d used in this image at $%lx (offset $%x) is not implemented by this\n engine (%s); executing this code will crash.\n", (long)-token, tok, group, (long)&image[i],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;  
       }        }
     }      }
       }
     }
     free(targets);
     finish_code();
   ((ImageHeader*)(image))->base = (Address) image;    ((ImageHeader*)(image))->base = (Address) image;
 }  }
   
 UCell checksum(Label symbols[])  #ifndef DOUBLY_INDIRECT
   static UCell checksum(Label symbols[])
 {  {
   UCell r=PRIM_VERSION;    UCell r=PRIM_VERSION;
   Cell i;    Cell i;
   
   for (i=DOCOL; i<=DOESJUMP; i++) {    for (i=DOCOL; i<=DOER_MAX; i++) {
     r ^= (UCell)(symbols[i]);      r ^= (UCell)(symbols[i]);
     r = (r << 5) | (r >> (8*sizeof(Cell)-5));      r = (r << 5) | (r >> (8*sizeof(Cell)-5));
   }    }
Line 173 
Line 486 
 #endif  #endif
   return r;    return r;
 }  }
   #endif
   
 Address verbose_malloc(Cell size)  static Address verbose_malloc(Cell size)
 {  {
   Address r;    Address r;
   /* leave a little room (64B) for stack underflows */    /* leave a little room (64B) for stack underflows */
Line 183 
Line 497 
     exit(1);      exit(1);
   }    }
   r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));    r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
   if (debug)    debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);
     fprintf(stderr, "malloc succeeds, address=$%lx\n", (long)r);  
   return r;    return r;
 }  }
   
 Address my_alloc(Cell size)  static void *next_address=0;
   static void after_alloc(Address r, Cell size)
 {  {
 #if HAVE_MMAP    if (r != (Address)-1) {
   static Address next_address=0;      debugp(stderr, "success, address=$%lx\n", (long) r);
   Address r;  #if 0
       /* not needed now that we protect the stacks with mprotect */
       if (pagesize != 1)
         next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */
   #endif
     } else {
       debugp(stderr, "failed: %s\n", strerror(errno));
     }
   }
   
 #if defined(MAP_ANON)  #ifndef MAP_FAILED
   if (debug)  #define MAP_FAILED ((Address) -1)
     fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_ANON, ...); ", (long)next_address, (long)size);  #endif
   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) */  
 #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
   #ifndef PROT_NONE
   # define PROT_NONE 0
   #endif
   #if !defined(MAP_ANON) && defined(MAP_ANONYMOUS)
   # define MAP_ANON MAP_ANONYMOUS
   #endif
   
   #if defined(HAVE_MMAP)
   static Address alloc_mmap(Cell size)
   {
     void *r;
   
   #if defined(MAP_ANON)
     debugp(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|map_noreserve, -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)      debugp(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",
       fprintf(stderr, "open(\"/dev/zero\"...) failed (%s), no mmap; ",  
               strerror(errno));                strerror(errno));
   } else {    } else {
     if (debug)      debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);
       fprintf(stderr,"try mmap($%lx, $%lx, ..., MAP_FILE, dev_zero, ...); ", (long)next_address, (long)size);      r=mmap(next_address, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FILE|MAP_PRIVATE|map_noreserve, 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 != 1)  
       next_address = (Address)(((((Cell)r)+size-1)&-pagesize)+2*pagesize); /* leave one page unmapped */  
     return r;      return r;
   }    }
   if (debug)  
     fprintf(stderr, "failed: %s\n", strerror(errno));  static void page_noaccess(void *a)
   {
     /* try mprotect first; with munmap the page might be allocated later */
     debugp(stderr, "try mprotect(%p,$%lx,PROT_NONE); ", a, (long)pagesize);
     if (mprotect(a, pagesize, PROT_NONE)==0) {
       debugp(stderr, "ok\n");
       return;
     }
     debugp(stderr, "failed: %s\n", strerror(errno));
     debugp(stderr, "try munmap(%p,$%lx); ", a, (long)pagesize);
     if (munmap(a,pagesize)==0) {
       debugp(stderr, "ok\n");
       return;
     }
     debugp(stderr, "failed: %s\n", strerror(errno));
   }
   
   static size_t wholepage(size_t n)
   {
     return (n+pagesize-1)&~(pagesize-1);
   }
   #endif
   
   Address gforth_alloc(Cell size)
   {
   #if HAVE_MMAP
     Address r;
   
     r=alloc_mmap(size);
     if (r!=(Address)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))  static void *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. */    void *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) {
       image=alloc_mmap(dictsize);
       if (image != (void *)MAP_FAILED) {
         void *image1;
         debugp(stderr,"try mmap($%lx, $%lx, ..., MAP_FIXED|MAP_FILE, imagefile, 0); ", (long)image, (long)imagesize);
         image1 = mmap(image, imagesize, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_FIXED|MAP_FILE|MAP_PRIVATE|map_noreserve, fileno(file), 0);
         after_alloc(image1,dictsize);
         if (image1 == (void *)MAP_FAILED)
           goto read_image;
       }
     }
   #endif /* defined(HAVE_MMAP) */
     if (image == (void *)MAP_FAILED) {
       image = gforth_alloc(dictsize+offset)+offset;
     read_image:
       rewind(file);  /* fseek(imagefile,0L,SEEK_SET); */
       fread(image, 1, imagesize, file);
     }
     return image;
   }
 #endif  #endif
   
 void set_stack_sizes(ImageHeader * header)  void set_stack_sizes(ImageHeader * header)
Line 264 
Line 642 
   fsize=maxaligned(fsize);    fsize=maxaligned(fsize);
 }  }
   
 void alloc_stacks(ImageHeader * header)  #ifdef STANDALONE
   void alloc_stacks(ImageHeader * h)
 {  {
   header->dict_size=dictsize;  #define SSTACKSIZE 0x200
   header->data_stack_size=dsize;    static Cell dstack[SSTACKSIZE+1];
   header->fp_stack_size=fsize;    static Cell rstack[SSTACKSIZE+1];
   header->return_stack_size=rsize;  
   header->locals_stack_size=lsize;    h->dict_size=dictsize;
     h->data_stack_size=dsize;
   header->data_stack_base=my_alloc(dsize);    h->fp_stack_size=fsize;
   header->fp_stack_base=my_alloc(fsize);    h->return_stack_size=rsize;
   header->return_stack_base=my_alloc(rsize);    h->locals_stack_size=lsize;
   header->locals_stack_base=my_alloc(lsize);  
     h->data_stack_base=dstack+SSTACKSIZE;
     //  h->fp_stack_base=gforth_alloc(fsize);
     h->return_stack_base=rstack+SSTACKSIZE;
     //  h->locals_stack_base=gforth_alloc(lsize);
   }
   #else
   void alloc_stacks(ImageHeader * h)
   {
     h->dict_size=dictsize;
     h->data_stack_size=dsize;
     h->fp_stack_size=fsize;
     h->return_stack_size=rsize;
     h->locals_stack_size=lsize;
   
   #if defined(HAVE_MMAP) && !defined(STANDALONE)
     if (pagesize > 1) {
       size_t p = pagesize;
       size_t totalsize =
         wholepage(dsize)+wholepage(fsize)+wholepage(rsize)+wholepage(lsize)+5*p;
       void *a = alloc_mmap(totalsize);
       if (a != (void *)MAP_FAILED) {
         page_noaccess(a); a+=p; h->  data_stack_base=a; a+=wholepage(dsize);
         page_noaccess(a); a+=p; h->    fp_stack_base=a; a+=wholepage(fsize);
         page_noaccess(a); a+=p; h->return_stack_base=a; a+=wholepage(rsize);
         page_noaccess(a); a+=p; h->locals_stack_base=a; a+=wholepage(lsize);
         page_noaccess(a);
         debugp(stderr,"stack addresses: d=%p f=%p r=%p l=%p\n",
                h->data_stack_base,
                h->fp_stack_base,
                h->return_stack_base,
                h->locals_stack_base);
         return;
       }
     }
   #endif
     h->data_stack_base=gforth_alloc(dsize);
     h->fp_stack_base=gforth_alloc(fsize);
     h->return_stack_base=gforth_alloc(rsize);
     h->locals_stack_base=gforth_alloc(lsize);
 }  }
   #endif
   
 int go_forth(Address image, int stack, Cell *entries)  #warning You can ignore the warnings about clobbered variables in gforth_go
   int gforth_go(void *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 291 
Line 714 
 #endif  #endif
   
   /* ensure that the cached elements (if any) are accessible */    /* ensure that the cached elements (if any) are accessible */
   IF_TOS(sp0--);  #if !(defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING))
   IF_FTOS(fp0--);    sp0 -= 8; /* make stuff below bottom accessible for stack caching */
     fp0--;
   #endif
   
   for(;stack>0;stack--)    for(;stack>0;stack--)
     *--sp0=entries[stack-1];      *--sp0=entries[stack-1];
   
   #if defined(SYSSIGNALS) && !defined(STANDALONE)
   get_winsize();    get_winsize();
   
 #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))) {
     static Cell signal_data_stack[8];      static Cell signal_data_stack[24];
     static Cell signal_return_stack[8];      static Cell signal_return_stack[16];
     static Float signal_fp_stack[1];      static Float signal_fp_stack[1];
   
     signal_data_stack[7]=throw_code;      signal_data_stack[15]=throw_code;
   
 #ifdef GFORTH_DEBUGGING  #ifdef GFORTH_DEBUGGING
     if (rp <= rp0 && rp > (Cell *)(image_header->return_stack_base+5)) {      debugp(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 */        /* no rstack overflow or underflow */
       rp0 = rp;        rp0 = rp;
       *--rp0 = (Cell)ip;        *--rp0 = (Cell)saved_ip;
     }      }
     else /* I love non-syntactic ifdefs :-) */      else /* I love non-syntactic ifdefs :-) */
 #endif        rp0 = signal_return_stack+16;
     rp0 = signal_return_stack+8;  #else  /* !defined(GFORTH_DEBUGGING) */
       debugp(stderr,"\ncaught signal, throwing exception %d\n", throw_code);
         rp0 = signal_return_stack+16;
   #endif /* !defined(GFORTH_DEBUGGING) */
     /* fprintf(stderr, "rp=$%x\n",rp0);*/      /* fprintf(stderr, "rp=$%x\n",rp0);*/
   
     return((int)engine(image_header->throw_entry, signal_data_stack+7,      return((int)(Cell)gforth_engine(image_header->throw_entry, signal_data_stack+15,
                        rp0, signal_fp_stack, 0));                         rp0, signal_fp_stack, 0 sr_call));
   }    }
 #endif  #endif
   
   return((int)engine(ip0,sp0,rp0,fp0,lp0));    return((int)(Cell)gforth_engine(ip0,sp0,rp0,fp0,lp0 sr_call));
 }  }
   
   #if !defined(INCLUDE_IMAGE) && !defined(STANDALONE)
 void print_sizes(Cell sizebyte)  static void print_sizes(Cell sizebyte)
      /* print size information */       /* print size information */
 {  {
   static char* endianstring[]= { "   big","little" };    static char* endianstring[]= { "   big","little" };
Line 341 
Line 771 
           1 << ((sizebyte >> 5) & 3));            1 << ((sizebyte >> 5) & 3));
 }  }
   
 #ifndef INCLUDE_IMAGE  /* static superinstruction stuff */
 Address loader(FILE *imagefile, char* filename)  
   struct cost { /* super_info might be a more accurate name */
     char loads;       /* number of stack loads */
     char stores;      /* number of stack stores */
     char updates;     /* number of stack pointer updates */
     char branch;      /* is it a branch (SET_IP) */
     unsigned char state_in;    /* state on entry */
     unsigned char state_out;   /* state on exit */
     unsigned char imm_ops;     /* number of immediate operands */
     short offset;     /* offset into super2 table */
     unsigned char length;      /* number of components */
   };
   
   PrimNum super2[] = {
   #include SUPER2_I
   };
   
   struct cost super_costs[] = {
   #include COSTS_I
   };
   
   struct super_state {
     struct super_state *next;
     PrimNum super;
   };
   
   #define HASH_SIZE 256
   
   struct super_table_entry {
     struct super_table_entry *next;
     PrimNum *start;
     short length;
     struct super_state *ss_list; /* list of supers */
   } *super_table[HASH_SIZE];
   int max_super=2;
   
   struct super_state *state_transitions=NULL;
   
   static int hash_super(PrimNum *start, int length)
   {
     int i, r;
   
     for (i=0, r=0; i<length; i++) {
       r <<= 1;
       r += start[i];
     }
     return r & (HASH_SIZE-1);
   }
   
   static struct super_state **lookup_super(PrimNum *start, int length)
   {
     int hash=hash_super(start,length);
     struct super_table_entry *p = super_table[hash];
   
     /* assert(length >= 2); */
     for (; p!=NULL; p = p->next) {
       if (length == p->length &&
           memcmp((char *)p->start, (char *)start, length*sizeof(PrimNum))==0)
         return &(p->ss_list);
     }
     return NULL;
   }
   
   static void prepare_super_table()
   {
     int i;
     int nsupers = 0;
   
     for (i=0; i<sizeof(super_costs)/sizeof(super_costs[0]); i++) {
       struct cost *c = &super_costs[i];
       if ((c->length < 2 || nsupers < static_super_number) &&
           c->state_in < maxstates && c->state_out < maxstates) {
         struct super_state **ss_listp= lookup_super(super2+c->offset, c->length);
         struct super_state *ss = malloc(sizeof(struct super_state));
         ss->super= i;
         if (c->offset==N_noop && i != N_noop) {
           if (is_relocatable(i)) {
             ss->next = state_transitions;
             state_transitions = ss;
           }
         } else if (ss_listp != NULL) {
           ss->next = *ss_listp;
           *ss_listp = ss;
         } else {
           int hash = hash_super(super2+c->offset, c->length);
           struct super_table_entry **p = &super_table[hash];
           struct super_table_entry *e = malloc(sizeof(struct super_table_entry));
           ss->next = NULL;
           e->next = *p;
           e->start = super2 + c->offset;
           e->length = c->length;
           e->ss_list = ss;
           *p = e;
         }
         if (c->length > max_super)
           max_super = c->length;
         if (c->length >= 2)
           nsupers++;
       }
     }
     debugp(stderr, "Using %d static superinsts\n", nsupers);
     if (nsupers>0 && !tpa_noautomaton && !tpa_noequiv) {
       /* Currently these two things don't work together; see Section 3.2
          of <http://www.complang.tuwien.ac.at/papers/ertl+06pldi.ps.gz>,
          in particular Footnote 6 for the reason; hmm, we should be able
          to use an automaton without state equivalence, but that costs
          significant space so we only do it if the user explicitly
          disables state equivalence. */
       debugp(stderr, "Disabling tpa-automaton, because nsupers>0 and state equivalence is enabled.\n");
       tpa_noautomaton = 1;
     }
   }
   
   /* dynamic replication/superinstruction stuff */
   
   #ifndef NO_DYNAMIC
   static 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) */
   
   static char MAYBE_UNUSED superend[]={
   #include PRIM_SUPEREND_I
   };
   
   Cell npriminfos=0;
   
   Label goto_start;
   Cell goto_len;
   
   #ifndef NO_DYNAMIC
   static int compare_labels(const void *pa, const void *pb)
   {
     Label a = *(Label *)pa;
     Label b = *(Label *)pb;
     return a-b;
   }
   #endif
   
   static Label bsearch_next(Label key, Label *a, UCell n)
        /* a is sorted; return the label >=key that is the closest in a;
           return NULL if there is no label in a >=key */
   {
     int mid = (n-1)/2;
     if (n<1)
       return NULL;
     if (n == 1) {
       if (a[0] < key)
         return NULL;
       else
         return a[0];
     }
     if (a[mid] < key)
       return bsearch_next(key, a+mid+1, n-mid-1);
     else
       return bsearch_next(key, a, mid+1);
   }
   
   static void check_prims(Label symbols1[])
   {
     int i;
   #ifndef NO_DYNAMIC
     Label *symbols2, *symbols3, *ends1, *ends1j, *ends1jsorted, *goto_p;
     int nends1j;
   #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=0; symbols1[i]!=0; i++)
       ;
     npriminfos = i;
   
   #ifndef NO_DYNAMIC
     if (no_dynamic)
       return;
     symbols2=gforth_engine2(0,0,0,0,0 sr_call);
   #if NO_IP
     symbols3=gforth_engine3(0,0,0,0,0 sr_call);
   #else
     symbols3=symbols1;
   #endif
     ends1 = symbols1+i+1;
     ends1j =   ends1+i;
     goto_p = ends1j+i+1; /* goto_p[0]==before; ...[1]==after;*/
     nends1j = i+1;
     ends1jsorted = (Label *)alloca(nends1j*sizeof(Label));
     memcpy(ends1jsorted,ends1j,nends1j*sizeof(Label));
     qsort(ends1jsorted, nends1j, sizeof(Label), compare_labels);
   
     /* check whether the "goto *" is relocatable */
     goto_len = goto_p[1]-goto_p[0];
     debugp(stderr, "goto * %p %p len=%ld\n",
            goto_p[0],symbols2[goto_p-symbols1],(long)goto_len);
     if (memcmp(goto_p[0],symbols2[goto_p-symbols1],goto_len)!=0) { /* unequal */
       no_dynamic=1;
       debugp(stderr,"  not relocatable, disabling dynamic code generation\n");
       init_ss_cost();
       return;
     }
     goto_start = goto_p[0];
   
     priminfos = calloc(i,sizeof(PrimInfo));
     for (i=0; symbols1[i]!=0; i++) {
       int prim_len = ends1[i]-symbols1[i];
       PrimInfo *pi=&priminfos[i];
       struct cost *sc=&super_costs[i];
       int j=0;
       char *s1 = (char *)symbols1[i];
       char *s2 = (char *)symbols2[i];
       char *s3 = (char *)symbols3[i];
       Label endlabel = bsearch_next(symbols1[i]+1,ends1jsorted,nends1j);
   
       pi->start = s1;
       pi->superend = superend[i]|no_super;
       pi->length = prim_len;
       pi->restlength = endlabel - symbols1[i] - pi->length;
       pi->nimmargs = 0;
       relocs++;
   #if defined(BURG_FORMAT)
       { /* output as burg-style rules */
         int p=super_costs[i].offset;
         if (p==N_noop)
           debugp(stderr, "S%d: S%d = %d (%d);", sc->state_in, sc->state_out, i+1, pi->length);
         else
           debugp(stderr, "S%d: op%d(S%d) = %d (%d);", sc->state_in, p, sc->state_out, i+1, pi->length);
       }
   #else
       debugp(stderr, "%-15s %d-%d %4d %p %p %p len=%3ld rest=%2ld send=%1d",
              prim_names[i], sc->state_in, sc->state_out,
              i, s1, s2, s3, (long)(pi->length), (long)(pi->restlength),
              pi->superend);
   #endif
       if (endlabel == NULL) {
         pi->start = NULL; /* not relocatable */
         if (pi->length<0) pi->length=100;
   #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: no J label > start found\n");
   #endif
         relocs--;
         nonrelocs++;
         continue;
       }
       if (ends1[i] > endlabel && !pi->superend) {
         pi->start = NULL; /* not relocatable */
         pi->length = endlabel-symbols1[i];
   #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: there is a J label before the K label (restlength<0)\n");
   #endif
         relocs--;
         nonrelocs++;
         continue;
       }
       if (ends1[i] < pi->start && !pi->superend) {
         pi->start = NULL; /* not relocatable */
         pi->length = endlabel-symbols1[i];
   #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: K label before I label (length<0)\n");
   #endif
         relocs--;
         nonrelocs++;
         continue;
       }
       if (CHECK_PRIM(s1, prim_len)) {
   #ifndef BURG_FORMAT
         debugp(stderr,"\n   non_reloc: architecture specific check failed\n");
   #endif
         pi->start = NULL; /* not relocatable */
         relocs--;
         nonrelocs++;
         continue;
       }
       assert(pi->length>=0);
       assert(pi->restlength >=0);
       while (j<(pi->length+pi->restlength)) {
         if (s1[j]==s3[j]) {
           if (s1[j] != s2[j]) {
             pi->start = NULL; /* not relocatable */
   #ifndef BURG_FORMAT
             debugp(stderr,"\n   non_reloc: engine1!=engine2 offset %3d",j);
   #endif
             /* assert(j<prim_len); */
             relocs--;
             nonrelocs++;
             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;
             debugp(stderr,"\n   absolute immarg: offset %3d",j);
           } else if ((&(s1[j]))+(*(Cell *)&(s1[j]))+4 ==
                      symbols1[DOER_MAX+1]) {
             ia->rel=1;
             debugp(stderr,"\n   relative immarg: offset %3d",j);
           } else {
             pi->start = NULL; /* not relocatable */
   #ifndef BURG_FORMAT
             debugp(stderr,"\n   non_reloc: engine1!=engine3 offset %3d",j);
   #endif
             /* assert(j<prim_len);*/
             relocs--;
             nonrelocs++;
             break;
           }
           j+=4;
         }
       }
       debugp(stderr,"\n");
     }
     decomp_prims = calloc(i,sizeof(PrimInfo *));
     for (i=DOER_MAX+1; i<npriminfos; i++)
       decomp_prims[i] = &(priminfos[i]);
     qsort(decomp_prims+DOER_MAX+1, npriminfos-DOER_MAX-1, sizeof(PrimInfo *),
           compare_priminfo_length);
   #endif
   }
   
   static void flush_to_here(void)
   {
   #ifndef NO_DYNAMIC
     if (start_flush)
       FLUSH_ICACHE((caddr_t)start_flush, code_here-start_flush);
     start_flush=code_here;
   #endif
   }
   
   static void MAYBE_UNUSED align_code(void)
        /* align code_here on some platforms */
   {
   #ifndef NO_DYNAMIC
   #if defined(CODE_PADDING)
     Cell alignment = CODE_ALIGNMENT;
     static char nops[] = CODE_PADDING;
     UCell maxpadding=MAX_PADDING;
     UCell offset = ((UCell)code_here)&(alignment-1);
     UCell length = alignment-offset;
     if (length <= maxpadding) {
       memcpy(code_here,nops+offset,length);
       code_here += length;
     }
   #endif /* defined(CODE_PADDING) */
   #endif /* defined(NO_DYNAMIC */
   }
   
   #ifndef NO_DYNAMIC
   static 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;
       memcpy(code_here, goto_start, goto_len);
       code_here += goto_len;
       align_code();
       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;
   
   static void reserve_code_space(UCell size)
   {
     if (code_area+code_area_size < code_here+size) {
       struct code_block_list *p;
       append_jump();
       debugp(stderr,"Did not use %ld bytes in code block\n",
              (long)(code_area+code_area_size-code_here));
       flush_to_here();
       if (*next_code_blockp == NULL) {
         code_here = start_flush = code_area = gforth_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;
       }
       next_code_blockp = &(p->next);
     }
   }
   
   static Address append_prim(Cell p)
   {
     PrimInfo *pi = &priminfos[p];
     Address old_code_here;
     reserve_code_space(pi->length+pi->restlength+goto_len+CODE_ALIGNMENT-1);
     memcpy(code_here, pi->start, pi->length);
     old_code_here = code_here;
     code_here += pi->length;
     return old_code_here;
   }
   
   static void reserve_code_super(PrimNum origs[], int ninsts)
   {
     int i;
     UCell size = CODE_ALIGNMENT-1; /* alignment may happen first */
     if (no_dynamic)
       return;
     /* use size of the original primitives as an upper bound for the
        size of the superinstruction.  !! This is only safe if we
        optimize for code size (the default) */
     for (i=0; i<ninsts; i++) {
       PrimNum p = origs[i];
       PrimInfo *pi = &priminfos[p];
       if (is_relocatable(p))
         size += pi->length;
       else
         if (i>0)
           size += priminfos[origs[i-1]].restlength+goto_len+CODE_ALIGNMENT-1;
     }
     size += priminfos[origs[i-1]].restlength+goto_len;
     reserve_code_space(size);
   }
   #endif
   
   int forget_dyncode(Address code)
   {
   #ifdef NO_DYNAMIC
     return -1;
   #else
     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) */
   }
   
   static long dyncodesize(void)
   {
   #ifndef NO_DYNAMIC
     struct code_block_list *p;
     long size=0;
     for (p=code_block_list; p!=NULL; p=p->next) {
       if (code_here >= p->block && code_here < p->block+p->size)
         return size + (code_here - p->block);
       else
         size += p->size;
     }
   #endif /* !defined(NO_DYNAMIC) */
     return 0;
   }
   
   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>DOER_MAX; i--) {
       PrimInfo *pi=decomp_prims[i];
       if (pi->start==code || (pi->start && memcmp(code,pi->start,pi->length)==0))
         return vm_prims[super2[super_costs[pi-priminfos].offset]];
       /* return pi->start;*/
     }
     return code;
   #endif /* !defined(NO_DYNAMIC) */
   }
   
   #ifdef NO_IP
   int nbranchinfos=0;
   
   struct branchinfo {
     Label **targetpp; /* **(bi->targetpp) is the target */
     Cell *addressptr; /* store the target here */
   } branchinfos[100000];
   
   int ndoesexecinfos=0;
   struct doesexecinfo {
     int branchinfo; /* fix the targetptr of branchinfos[...->branchinfo] */
     Label *targetp; /*target for branch (because this is not in threaded code)*/
     Cell *xt; /* cfa of word whose does-code needs calling */
   } doesexecinfos[10000];
   
   static void set_rel_target(Cell *source, Label target)
   {
     *source = ((Cell)target)-(((Cell)source)+4);
   }
   
   static void register_branchinfo(Label source, Cell *targetpp)
   {
     struct branchinfo *bi = &(branchinfos[nbranchinfos]);
     bi->targetpp = (Label **)targetpp;
     bi->addressptr = (Cell *)source;
     nbranchinfos++;
   }
   
   static Address compile_prim1arg(PrimNum p, Cell **argp)
   {
     Address old_code_here=append_prim(p);
   
     assert(vm_prims[p]==priminfos[p].start);
     *argp = (Cell*)(old_code_here+priminfos[p].immargs[0].offset);
     return old_code_here;
   }
   
   static Address compile_call2(Cell *targetpp, Cell **next_code_targetp)
   {
     PrimInfo *pi = &priminfos[N_call2];
     Address old_code_here = append_prim(N_call2);
   
     *next_code_targetp = (Cell *)(old_code_here + pi->immargs[0].offset);
     register_branchinfo(old_code_here + pi->immargs[1].offset, targetpp);
     return old_code_here;
   }
   #endif
   
   void finish_code(void)
   {
   #ifdef NO_IP
     Cell i;
   
     compile_prim1(NULL);
     for (i=0; i<ndoesexecinfos; i++) {
       struct doesexecinfo *dei = &doesexecinfos[i];
       dei->targetp = (Label *)DOES_CODE1((dei->xt));
       branchinfos[dei->branchinfo].targetpp = &(dei->targetp);
     }
     ndoesexecinfos = 0;
     for (i=0; i<nbranchinfos; i++) {
       struct branchinfo *bi=&branchinfos[i];
       set_rel_target(bi->addressptr, **(bi->targetpp));
     }
     nbranchinfos = 0;
   #else
     compile_prim1(NULL);
   #endif
     flush_to_here();
   }
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   #ifdef NO_IP
   static Cell compile_prim_dyn(PrimNum p, Cell *tcp)
        /* compile prim #p dynamically (mod flags etc.) and return start
           address of generated code for putting it into the threaded
           code. This function is only called if all the associated
           inline arguments of p are already in place (at tcp[1] etc.) */
   {
     PrimInfo *pi=&priminfos[p];
     Cell *next_code_target=NULL;
     Address codeaddr;
     Address primstart;
   
     assert(p<npriminfos);
     if (p==N_execute || p==N_perform || p==N_lit_perform) {
       codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
       primstart = append_prim(p);
       goto other_prim;
     } else if (p==N_call) {
       codeaddr = compile_call2(tcp+1, &next_code_target);
     } else if (p==N_does_exec) {
       struct doesexecinfo *dei = &doesexecinfos[ndoesexecinfos++];
       Cell *arg;
       codeaddr = compile_prim1arg(N_lit,&arg);
       *arg = (Cell)PFA(tcp[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 *)(tcp[1]);
       compile_call2(0, &next_code_target);
     } else if (!is_relocatable(p)) {
       Cell *branch_target;
       codeaddr = compile_prim1arg(N_set_next_code, &next_code_target);
       compile_prim1arg(N_branch,&branch_target);
       set_rel_target(branch_target,vm_prims[p]);
     } else {
       unsigned j;
   
       codeaddr = primstart = append_prim(p);
     other_prim:
       for (j=0; j<pi->nimmargs; j++) {
         struct immarg *ia = &(pi->immargs[j]);
         Cell *argp = tcp + pi->nimmargs - j;
         Cell argval = *argp; /* !! specific to prims */
         if (ia->rel) { /* !! assumption: relative refs are branches */
           register_branchinfo(primstart + ia->offset, argp);
         } else /* plain argument */
           *(Cell *)(primstart + ia->offset) = argval;
       }
     }
     if (next_code_target!=NULL)
       *next_code_target = (Cell)code_here;
     return (Cell)codeaddr;
   }
   #else /* !defined(NO_IP) */
   static Cell compile_prim_dyn(PrimNum p, Cell *tcp)
        /* compile prim #p dynamically (mod flags etc.) and return start
           address of generated code for putting it into the threaded code */
   {
     Cell static_prim = (Cell)vm_prims[p];
   #if defined(NO_DYNAMIC)
     return static_prim;
   #else /* !defined(NO_DYNAMIC) */
     Address old_code_here;
   
     if (no_dynamic)
       return static_prim;
     if (p>=npriminfos || !is_relocatable(p)) {
       append_jump();
       return static_prim;
     }
     old_code_here = append_prim(p);
     last_jump = p;
     if (priminfos[p].superend)
       append_jump();
     return (Cell)old_code_here;
   #endif  /* !defined(NO_DYNAMIC) */
   }
   #endif /* !defined(NO_IP) */
   #endif
   
   #ifndef NO_DYNAMIC
   static int cost_codesize(int prim)
   {
     return priminfos[prim].length;
   }
   #endif
   
   static int cost_ls(int prim)
   {
     struct cost *c = super_costs+prim;
   
     return c->loads + c->stores;
   }
   
   static int cost_lsu(int prim)
   {
     struct cost *c = super_costs+prim;
   
     return c->loads + c->stores + c->updates;
   }
   
   static int cost_nexts(int prim)
   {
     return 1;
   }
   
   typedef int Costfunc(int);
   Costfunc *ss_cost =  /* cost function for optimize_bb */
   #ifdef NO_DYNAMIC
   cost_lsu;
   #else
   cost_codesize;
   #endif
   
   struct {
     Costfunc *costfunc;
     char *metricname;
     long sum;
   } cost_sums[] = {
   #ifndef NO_DYNAMIC
     { cost_codesize, "codesize", 0 },
   #endif
     { cost_ls,       "ls",       0 },
     { cost_lsu,      "lsu",      0 },
     { cost_nexts,    "nexts",    0 }
   };
   
   #ifndef NO_DYNAMIC
   void init_ss_cost(void) {
     if (no_dynamic && ss_cost == cost_codesize) {
       ss_cost = cost_nexts;
       cost_sums[0] = cost_sums[1]; /* don't use cost_codesize for print-metrics */
       debugp(stderr, "--no-dynamic conflicts with --ss-min-codesize, reverting to --ss-min-nexts\n");
     }
   }
   #endif
   
   #define MAX_BB 128 /* maximum number of instructions in BB */
   #define INF_COST 1000000 /* infinite cost */
   #define CANONICAL_STATE 0
   
   struct waypoint {
     int cost;     /* the cost from here to the end */
     PrimNum inst; /* the inst used from here to the next waypoint */
     char relocatable; /* the last non-transition was relocatable */
     char no_transition; /* don't use the next transition (relocatability)
                          * or this transition (does not change state) */
   };
   
   struct tpa_state { /* tree parsing automaton (like) state */
     /* labeling is back-to-front */
     struct waypoint *inst;  /* in front of instruction */
     struct waypoint *trans; /* in front of instruction and transition */
   };
   
   struct tpa_state *termstate = NULL; /* initialized in loader() */
   
   /* statistics about tree parsing (lazyburg) stuff */
   long lb_basic_blocks = 0;
   long lb_labeler_steps = 0;
   long lb_labeler_automaton = 0;
   long lb_labeler_dynprog = 0;
   long lb_newstate_equiv = 0;
   long lb_newstate_new = 0;
   long lb_applicable_base_rules = 0;
   long lb_applicable_chain_rules = 0;
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static void init_waypoints(struct waypoint ws[])
   {
     int k;
   
     for (k=0; k<maxstates; k++)
       ws[k].cost=INF_COST;
   }
   
   static struct tpa_state *empty_tpa_state()
   {
     struct tpa_state *s = malloc(sizeof(struct tpa_state));
   
     s->inst  = calloc(maxstates,sizeof(struct waypoint));
     init_waypoints(s->inst);
     s->trans = calloc(maxstates,sizeof(struct waypoint));
     /* init_waypoints(s->trans);*/
     return s;
   }
   
   static void transitions(struct tpa_state *t)
   {
     int k;
     struct super_state *l;
   
     for (k=0; k<maxstates; k++) {
       t->trans[k] = t->inst[k];
       t->trans[k].no_transition = 1;
     }
     for (l = state_transitions; l != NULL; l = l->next) {
       PrimNum s = l->super;
       int jcost;
       struct cost *c=super_costs+s;
       struct waypoint *wi=&(t->trans[c->state_in]);
       struct waypoint *wo=&(t->inst[c->state_out]);
       lb_applicable_chain_rules++;
       if (wo->cost == INF_COST)
         continue;
       jcost = wo->cost + ss_cost(s);
       if (jcost <= wi->cost) {
         wi->cost = jcost;
         wi->inst = s;
         wi->relocatable = wo->relocatable;
         wi->no_transition = 0;
         /* if (ss_greedy) wi->cost = wo->cost ? */
       }
     }
   }
   
   static struct tpa_state *make_termstate()
   {
     struct tpa_state *s = empty_tpa_state();
   
     s->inst[CANONICAL_STATE].cost = 0;
     transitions(s);
     return s;
   }
   #endif
   
   #define TPA_SIZE 16384
   
   struct tpa_entry {
     struct tpa_entry *next;
     PrimNum inst;
     struct tpa_state *state_behind;  /* note: brack-to-front labeling */
     struct tpa_state *state_infront; /* note: brack-to-front labeling */
   } *tpa_table[TPA_SIZE];
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static Cell hash_tpa(PrimNum p, struct tpa_state *t)
   {
     UCell it = (UCell )t;
     return (p+it+(it>>14))&(TPA_SIZE-1);
   }
   
   static struct tpa_state **lookup_tpa(PrimNum p, struct tpa_state *t2)
   {
     int hash=hash_tpa(p, t2);
     struct tpa_entry *te = tpa_table[hash];
   
     if (tpa_noautomaton) {
       static struct tpa_state *t;
       t = NULL;
       return &t;
     }
     for (; te!=NULL; te = te->next) {
       if (p == te->inst && t2 == te->state_behind)
         return &(te->state_infront);
     }
     te = (struct tpa_entry *)malloc(sizeof(struct tpa_entry));
     te->next = tpa_table[hash];
     te->inst = p;
     te->state_behind = t2;
     te->state_infront = NULL;
     tpa_table[hash] = te;
     return &(te->state_infront);
   }
   
   static void tpa_state_normalize(struct tpa_state *t)
   {
     /* normalize so cost of canonical state=0; this may result in
        negative costs for some states */
     int d = t->inst[CANONICAL_STATE].cost;
     int i;
   
     for (i=0; i<maxstates; i++) {
       if (t->inst[i].cost != INF_COST)
         t->inst[i].cost -= d;
       if (t->trans[i].cost != INF_COST)
         t->trans[i].cost -= d;
     }
   }
   
   static int tpa_state_equivalent(struct tpa_state *t1, struct tpa_state *t2)
   {
     return (memcmp(t1->inst, t2->inst, maxstates*sizeof(struct waypoint)) == 0 &&
             memcmp(t1->trans,t2->trans,maxstates*sizeof(struct waypoint)) == 0);
   }
   #endif
   
   struct tpa_state_entry {
     struct tpa_state_entry *next;
     struct tpa_state *state;
   } *tpa_state_table[TPA_SIZE];
   
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
   static Cell hash_tpa_state(struct tpa_state *t)
   {
     int *ti = (int *)(t->inst);
     int *tt = (int *)(t->trans);
     int r=0;
     int i;
   
     for (i=0; ti+i < (int *)(t->inst+maxstates); i++)
       r += ti[i]+tt[i];
     return (r+(r>>14)+(r>>22)) & (TPA_SIZE-1);
   }
   
   static struct tpa_state *lookup_tpa_state(struct tpa_state *t)
   {
     Cell hash = hash_tpa_state(t);
     struct tpa_state_entry *te = tpa_state_table[hash];
     struct tpa_state_entry *tn;
   
     if (!tpa_noequiv) {
       for (; te!=NULL; te = te->next) {
         if (tpa_state_equivalent(t, te->state)) {
           lb_newstate_equiv++;
           free(t->inst);
           free(t->trans);
           free(t);
           return te->state;
         }
       }
       tn = (struct tpa_state_entry *)malloc(sizeof(struct tpa_state_entry));
       tn->next = te;
       tn->state = t;
       tpa_state_table[hash] = tn;
     }
     lb_newstate_new++;
     if (tpa_trace)
       fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
     return t;
   }
   
   /* use dynamic programming to find the shortest paths within the basic
      block origs[0..ninsts-1] and rewrite the instructions pointed to by
      instps to use it */
   static void optimize_rewrite(Cell *instps[], PrimNum origs[], int ninsts)
   {
     int i,j;
     struct tpa_state *ts[ninsts+1];
     int nextdyn, nextstate, no_transition;
     Address old_code_area;
   
     lb_basic_blocks++;
     ts[ninsts] = termstate;
   #ifndef NO_DYNAMIC
     if (print_sequences) {
       for (i=0; i<ninsts; i++)
   #if defined(BURG_FORMAT)
         fprintf(stderr, "op%d ", super_costs[origs[i]].offset);
   #else
         fprintf(stderr, "%s ", prim_names[origs[i]]);
   #endif
       fprintf(stderr, "\n");
     }
   #endif
     for (i=ninsts-1; i>=0; i--) {
       struct tpa_state **tp = lookup_tpa(origs[i],ts[i+1]);
       struct tpa_state *t = *tp;
       lb_labeler_steps++;
       if (t) {
         ts[i] = t;
         lb_labeler_automaton++;
       }
       else {
         lb_labeler_dynprog++;
         ts[i] = empty_tpa_state();
         for (j=1; j<=max_super && i+j<=ninsts; j++) {
           struct super_state **superp = lookup_super(origs+i, j);
           if (superp!=NULL) {
             struct super_state *supers = *superp;
             for (; supers!=NULL; supers = supers->next) {
               PrimNum s = supers->super;
               int jcost;
               struct cost *c=super_costs+s;
               struct waypoint *wi=&(ts[i]->inst[c->state_in]);
               struct waypoint *wo=&(ts[i+j]->trans[c->state_out]);
               int no_transition = wo->no_transition;
               lb_applicable_base_rules++;
               if (!(is_relocatable(s)) && !wo->relocatable) {
                 wo=&(ts[i+j]->inst[c->state_out]);
                 no_transition=1;
               }
               if (wo->cost == INF_COST)
                 continue;
               jcost = wo->cost + ss_cost(s);
               if (jcost <= wi->cost) {
                 wi->cost = jcost;
                 wi->inst = s;
                 wi->relocatable = is_relocatable(s);
                 wi->no_transition = no_transition;
                 /* if (ss_greedy) wi->cost = wo->cost ? */
               }
             }
           }
         }
         transitions(ts[i]);
         tpa_state_normalize(ts[i]);
         *tp = ts[i] = lookup_tpa_state(ts[i]);
         if (tpa_trace)
           fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
       }
     }
     /* now rewrite the instructions */
     reserve_code_super(origs,ninsts);
     old_code_area = code_area;
     nextdyn=0;
     nextstate=CANONICAL_STATE;
     no_transition = ((!ts[0]->trans[nextstate].relocatable)
                      ||ts[0]->trans[nextstate].no_transition);
     for (i=0; i<ninsts; i++) {
       Cell tc=0, tc2;
       if (i==nextdyn) {
         if (!no_transition) {
           /* process trans */
           PrimNum p = ts[i]->trans[nextstate].inst;
           struct cost *c = super_costs+p;
           assert(ts[i]->trans[nextstate].cost != INF_COST);
           assert(c->state_in==nextstate);
           tc = compile_prim_dyn(p,NULL);
           nextstate = c->state_out;
         }
         {
           /* process inst */
           PrimNum p = ts[i]->inst[nextstate].inst;
           struct cost *c=super_costs+p;
           assert(c->state_in==nextstate);
           assert(ts[i]->inst[nextstate].cost != INF_COST);
   #if defined(GFORTH_DEBUGGING)
           assert(p == origs[i]);
   #endif
           tc2 = compile_prim_dyn(p,instps[i]);
           if (no_transition || !is_relocatable(p))
             /* !! actually what we care about is if and where
              * compile_prim_dyn() puts NEXTs */
             tc=tc2;
           no_transition = ts[i]->inst[nextstate].no_transition;
           nextstate = c->state_out;
           nextdyn += c->length;
         }
       } else {
   #if defined(GFORTH_DEBUGGING)
         assert(0);
   #endif
         tc=0;
         /* tc= (Cell)vm_prims[ts[i]->inst[CANONICAL_STATE].inst]; */
       }
       *(instps[i]) = tc;
     }
     if (!no_transition) {
       PrimNum p = ts[i]->trans[nextstate].inst;
       struct cost *c = super_costs+p;
       assert(c->state_in==nextstate);
       assert(ts[i]->trans[nextstate].cost != INF_COST);
       assert(i==nextdyn);
       (void)compile_prim_dyn(p,NULL);
       nextstate = c->state_out;
     }
     assert(nextstate==CANONICAL_STATE);
     assert(code_area==old_code_area); /* does reserve_code_super() work? */
   }
   #endif
   
   /* compile *start, possibly rewriting it into a static and/or dynamic
      superinstruction */
   void compile_prim1(Cell *start)
   {
   #if defined(DOUBLY_INDIRECT)
     Label prim;
   
     if (start==NULL)
       return;
     prim = (Label)*start;
     if (prim<((Label)(xts+DOER_MAX)) || 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(INDIRECT_THREADED)
     return;
   #else /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
     static Cell *instps[MAX_BB];
     static PrimNum origs[MAX_BB];
     static int ninsts=0;
     PrimNum prim_num;
   
     if (start==NULL || ninsts >= MAX_BB ||
         (ninsts>0 && superend[origs[ninsts-1]])) {
       /* after bb, or at the start of the next bb */
       optimize_rewrite(instps,origs,ninsts);
       /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts); */
       ninsts=0;
       if (start==NULL) {
         align_code();
         return;
       }
     }
     prim_num = ((Xt)*start)-vm_prims;
     if(prim_num >= npriminfos) {
       /* code word */
       optimize_rewrite(instps,origs,ninsts);
       /* fprintf(stderr,"optimize_rewrite(...,%d)\n",ninsts);*/
       ninsts=0;
       append_jump();
       *start = *(Cell *)*start;
       return;
     }
     assert(ninsts<MAX_BB);
     instps[ninsts] = start;
     origs[ninsts] = prim_num;
     ninsts++;
   #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
   }
   
   #ifndef STANDALONE
   Address gforth_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) */
 {  {
   ImageHeader header;    ImageHeader header;
Line 351 
Line 1882 
   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;
   Cell ausize = ((RELINFOBITS ==  8) ? 0 :    Cell ausize = ((RELINFOBITS ==  8) ? 0 :
Line 371 
Line 1901 
 #endif  #endif
     ;      ;
   
     vm_prims = gforth_engine(0,0,0,0,0 sr_call);
     check_prims(vm_prims);
     prepare_super_table();
 #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) */
   #if !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED))
     termstate = make_termstate();
   #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
   
   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.4) image.\n",        fprintf(stderr,"%s: image %s doesn't seem to be a Gforth (>=0.8) image.\n",
               progname, filename);                progname, filename);
       exit(1);        exit(1);
     }      }
     preamblesize+=8;      preamblesize+=8;
   } while(memcmp(magic,"Gforth2",7));    } while(memcmp(magic,"Gforth4",7));
   magic7 = magic[7];    magic7 = magic[7];
   if (debug) {    if (debug) {
     magic[7]='\0';      magic[7]='\0';
Line 412 
Line 1951 
 #elif PAGESIZE  #elif PAGESIZE
   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */    pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
 #endif  #endif
   if (debug)    debugp(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); */                            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-preamblesize);
     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);      gforth_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 446 
Line 1986 
             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;
 }  }
   #endif
   
 /* index of last '/' or '\' in file, 0 if there is none. !! Hmm, could  /* pointer to last '/' or '\' in file, 0 if there is none. */
    be implemented with strrchr and the separator should be  static char *onlypath(char *filename)
    OS-dependent */  
 int onlypath(char *file)  
 {  {
   int i;    return strrchr(filename, DIRSEP);
   i=strlen(file);  
   while (i) {  
     if (file[i]=='\\' || file[i]=='/') break;  
     i--;  
   }  
   return i;  
 }  }
   
 FILE *openimage(char *fullfilename)  static FILE *openimage(char *fullfilename)
 {  {
   FILE *image_file;    FILE *image_file;
   char * expfilename = tilde_cstr(fullfilename, strlen(fullfilename), 1);    char * expfilename = tilde_cstr((Char *)fullfilename, strlen(fullfilename), 1);
   
   image_file=fopen(expfilename,"rb");    image_file=fopen(expfilename,"rb");
   if (image_file!=NULL && debug)    if (image_file!=NULL && debug)
Line 481 
Line 2016 
 }  }
   
 /* try to open image file concat(path[0:len],imagename) */  /* try to open image file concat(path[0:len],imagename) */
 FILE *checkimage(char *path, int len, char *imagename)  static FILE *checkimage(char *path, int len, char *imagename)
 {  {
   int dirlen=len;    int dirlen=len;
   char fullfilename[dirlen+strlen(imagename)+2];    char fullfilename[dirlen+strlen((char *)imagename)+2];
   
   memcpy(fullfilename, path, dirlen);    memcpy(fullfilename, path, dirlen);
   if (fullfilename[dirlen-1]!='/')    if (fullfilename[dirlen-1]!=DIRSEP)
     fullfilename[dirlen++]='/';      fullfilename[dirlen++]=DIRSEP;
   strcpy(fullfilename+dirlen,imagename);    strcpy(fullfilename+dirlen,imagename);
   return openimage(fullfilename);    return openimage(fullfilename);
 }  }
   
 FILE * open_image_file(char * imagename, char * path)  static FILE * open_image_file(char * imagename, char * path)
 {  {
   FILE * image_file=NULL;    FILE * image_file=NULL;
   char *origpath=path;    char *origpath=path;
   
   if(strchr(imagename, '/')==NULL) {    if(strchr(imagename, DIRSEP)==NULL) {
     /* first check the directory where the exe file is in !! 01may97jaw */      /* first check the directory where the exe file is in !! 01may97jaw */
     if (onlypath(progname))      if (onlypath(progname))
       image_file=checkimage(progname, onlypath(progname), imagename);        image_file=checkimage(progname, onlypath(progname)-progname, imagename);
     if (!image_file)      if (!image_file)
       do {        do {
         char *pend=strchr(path, PATHSEP);          char *pend=strchr(path, PATHSEP);
Line 525 
Line 2060 
 }  }
 #endif  #endif
   
   #ifdef STANDALONE_ALLOC
   Address gforth_alloc(Cell size)
   {
     Address r;
     /* leave a little room (64B) for stack underflows */
     if ((r = malloc(size+64))==NULL) {
       perror(progname);
       exit(1);
     }
     r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
     debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);
     return r;
   }
   #endif
   
 #ifdef HAS_OS  #ifdef HAS_OS
 UCell convsize(char *s, UCell elemsize)  static 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
    for the element size. default is e */     for the element size. default is e */
Line 560 
Line 2110 
   return n*m;    return n*m;
 }  }
   
   enum {
     ss_number = 256,
     ss_states,
     ss_min_codesize,
     ss_min_ls,
     ss_min_lsu,
     ss_min_nexts,
     opt_code_block_size,
   };
   
   #ifndef STANDALONE
 void gforth_args(int argc, char ** argv, char ** path, char ** imagename)  void gforth_args(int argc, char ** argv, char ** path, char ** imagename)
 {  {
   int c;    int c;
Line 575 
Line 2136 
       {"return-stack-size", required_argument, NULL, 'r'},        {"return-stack-size", required_argument, NULL, 'r'},
       {"fp-stack-size", required_argument, NULL, 'f'},        {"fp-stack-size", required_argument, NULL, 'f'},
       {"locals-stack-size", required_argument, NULL, 'l'},        {"locals-stack-size", required_argument, NULL, 'l'},
         {"vm-commit", no_argument, &map_noreserve, 0},
       {"path", required_argument, NULL, 'p'},        {"path", required_argument, NULL, 'p'},
       {"version", no_argument, NULL, 'v'},        {"version", no_argument, NULL, 'v'},
       {"help", no_argument, NULL, 'h'},        {"help", no_argument, NULL, 'h'},
Line 582 
Line 2144 
       {"offset-image", no_argument, &offset_image, 1},        {"offset-image", no_argument, &offset_image, 1},
       {"no-offset-im", no_argument, &offset_image, 0},        {"no-offset-im", no_argument, &offset_image, 0},
       {"clear-dictionary", no_argument, &clear_dictionary, 1},        {"clear-dictionary", no_argument, &clear_dictionary, 1},
       {"die-on-signal", no_argument, &die_on_signal, 1},  
       {"debug", no_argument, &debug, 1},        {"debug", no_argument, &debug, 1},
         {"diag", no_argument, &diag, 1},
         {"die-on-signal", no_argument, &die_on_signal, 1},
         {"ignore-async-signals", no_argument, &ignore_async_signals, 1},
         {"no-super", no_argument, &no_super, 1},
         {"no-dynamic", no_argument, &no_dynamic, 1},
         {"dynamic", no_argument, &no_dynamic, 0},
         {"code-block-size", required_argument, NULL, opt_code_block_size},
         {"print-metrics", no_argument, &print_metrics, 1},
         {"print-sequences", no_argument, &print_sequences, 1},
         {"ss-number", required_argument, NULL, ss_number},
         {"ss-states", required_argument, NULL, ss_states},
   #ifndef NO_DYNAMIC
         {"ss-min-codesize", no_argument, NULL, ss_min_codesize},
   #endif
         {"ss-min-ls",       no_argument, NULL, ss_min_ls},
         {"ss-min-lsu",      no_argument, NULL, ss_min_lsu},
         {"ss-min-nexts",    no_argument, NULL, ss_min_nexts},
         {"ss-greedy",       no_argument, &ss_greedy, 1},
         {"tpa-noequiv",     no_argument, &tpa_noequiv, 1},
         {"tpa-noautomaton", no_argument, &tpa_noautomaton, 1},
         {"tpa-trace",       no_argument, &tpa_trace, 1},
       {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);
   
     switch (c) {      switch (c) {
     case EOF: return;      case EOF: return;
Line 601 
Line 2183 
     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 '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 opt_code_block_size: code_area_size = atoi(optarg); break;
       case ss_number: static_super_number = atoi(optarg); break;
       case ss_states: maxstates = max(min(atoi(optarg),MAX_STATE),1); break;
   #ifndef NO_DYNAMIC
       case ss_min_codesize: ss_cost = cost_codesize; break;
   #endif
       case ss_min_ls:       ss_cost = cost_ls;       break;
       case ss_min_lsu:      ss_cost = cost_lsu;      break;
       case ss_min_nexts:    ss_cost = cost_nexts;    break;
     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\    --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\
     --code-block-size=SIZE            size of native code blocks [512KB]\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\    --diag                            Print diagnostic information during startup\n\
     --die-on-signal                   Exit instead of THROWing 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\
     --ignore-async-signals            Ignore instead of THROWing async. signals\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\
     --print-metrics                   Print some code generation metrics on exit\n\
     --print-sequences                 Print primitive sequences for optimization\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\    --ss-greedy                       Greedy, not optimal superinst selection\n\
     --ss-min-codesize                 Select superinsts for smallest native code\n\
     --ss-min-ls                       Minimize loads and stores\n\
     --ss-min-lsu                      Minimize loads, stores, and pointer updates\n\
     --ss-min-nexts                    Minimize the number of static superinsts\n\
     --ss-number=N                     Use N static superinsts (default max)\n\
     --ss-states=N                     N states for stack caching (default max)\n\
     --tpa-noequiv                     Automaton without state equivalence\n\
     --tpa-noautomaton                 Dynamic programming only\n\
     --tpa-trace                       Report new states etc.\n\
     -v, --version                     Print engine version and exit\n\
     --vm-commit                       Use OS default for memory overcommit\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]);
Line 629 
Line 2244 
   }    }
 }  }
 #endif  #endif
   #endif
   
   static void print_diag()
   {
   
 #ifdef INCLUDE_IMAGE  #if !defined(HAVE_GETRUSAGE)
 extern Cell image[];    fprintf(stderr, "*** missing functionality ***\n"
 extern const char reloc_bits[];  #ifndef HAVE_GETRUSAGE
             "    no getrusage -> CPUTIME broken\n"
   #endif
             );
   #endif
     if((relocs < nonrelocs) ||
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
        1
   #else
        0
   #endif
        )
       debugp(stderr, "relocs: %d:%d\n", relocs, nonrelocs);
       fprintf(stderr, "*** %sperformance problems ***\n%s%s",
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D) || !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY)) || defined(BUGGY_LONG_LONG)
               "",
   #else
               "no ",
   #endif
   #if defined(BUGGY_LL_CMP) || defined(BUGGY_LL_MUL) || defined(BUGGY_LL_DIV) || defined(BUGGY_LL_ADD) || defined(BUGGY_LL_SHIFT) || defined(BUGGY_LL_D2F) || defined(BUGGY_LL_F2D)
               "    double-cell integer type buggy ->\n        "
   #ifdef BUGGY_LL_CMP
               "double comparisons, "
   #endif
   #ifdef BUGGY_LL_MUL
               "*/MOD */ M* UM* "
   #endif
   #ifdef BUGGY_LL_DIV
               /* currently nothing is affected */
   #endif
   #ifdef BUGGY_LL_ADD
               "M+ D+ D- DNEGATE "
   #endif
   #ifdef BUGGY_LL_SHIFT
               "D2/ "
   #endif
   #ifdef BUGGY_LL_D2F
               "D>F "
   #endif
   #ifdef BUGGY_LL_F2D
               "F>D "
   #endif
               "\b\b slow\n"
   #endif
   #if !(defined(FORCE_REG) || defined(FORCE_REG_UNNECESSARY))
               "    automatic register allocation: performance degradation possible\n"
   #endif
               "",
               (relocs < nonrelocs) ? "no dynamic code generation (--debug for details) -> factor 2 slowdown\n" : "");
   }
   
   #ifdef STANDALONE
   Cell data_abort_pc;
   
   void data_abort_C(void)
   {
     while(1) {
     }
   }
 #endif  #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;
   Address image;    Address image;
 #endif  #endif
   int retvalue;    int retvalue;
   #if 0 && defined(__i386)
     /* disabled because the drawbacks may be worse than the benefits */
     /* set 387 precision control to use 53-bit mantissae to avoid most
        cases of double rounding */
     short fpu_control = 0x027f ;
     asm("fldcw %0" : : "m"(fpu_control));
   #endif /* defined(__i386) */
   
 #if defined(i386) && defined(ALIGNMENT_CHECK) && !defined(DIRECT_THREADED)  #ifdef MACOSX_DEPLOYMENT_TARGET
   /* turn on alignment checks on the 486.    setenv("MACOSX_DEPLOYMENT_TARGET", MACOSX_DEPLOYMENT_TARGET, 0);
    * 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. Also GCC doesn't try to keep  
      the stack FP-aligned. */  
 #endif  #endif
   #ifdef LTDL_LIBRARY_PATH
     setenv("LTDL_LIBRARY_PATH", LTDL_LIBRARY_PATH, 0);
   #endif
   #ifndef STANDALONE
   /* buffering of the user output device */    /* buffering of the user output device */
 #ifdef _IONBF  #ifdef _IONBF
   if (isatty(fileno(stdout))) {    if (isatty(fileno(stdout))) {
Line 662 
Line 2347 
     setvbuf(stdout,NULL,_IONBF,0);      setvbuf(stdout,NULL,_IONBF,0);
   }    }
 #endif  #endif
     setlocale(LC_ALL, "");
     setlocale(LC_NUMERIC, "C");
   #else
     prep_terminal();
   #endif
   
   progname = argv[0];    progname = argv[0];
   
   #ifndef STANDALONE
   #ifdef HAVE_LIBLTDL
     if (lt_dlinit()!=0) {
       fprintf(stderr,"%s: lt_dlinit failed", progname);
       exit(1);
     }
   #endif
   
 #ifdef HAS_OS  #ifdef HAS_OS
   gforth_args(argc, argv, &path, &imagename);    gforth_args(argc, argv, &path, &imagename);
   #ifndef NO_DYNAMIC
     init_ss_cost();
   #endif /* !defined(NO_DYNAMIC) */
   #endif /* defined(HAS_OS) */
 #endif  #endif
     code_here = ((void *)0)+code_area_size;
 #ifdef INCLUDE_IMAGE  #ifdef STANDALONE
   set_stack_sizes((ImageHeader *)image);    image = gforth_engine(0, 0, 0, 0, 0 sr_call);
   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 = gforth_loader(image_file, imagename);
 #endif  #endif
   gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */    gforth_header=(ImageHeader *)image; /* used in SIGSEGV handler */
   
     if (diag)
       print_diag();
   {    {
     char path2[strlen(path)+1];      char path2[strlen(path)+1];
     char *p1, *p2;      char *p1, *p2;
Line 701 
Line 2402 
       else        else
         *p2 = *p1;          *p2 = *p1;
     *p2='\0';      *p2='\0';
     retvalue = go_forth(image, 4, environ);      retvalue = gforth_go(image, 4, environ);
   #if defined(SIGPIPE) && !defined(STANDALONE)
       bsd_signal(SIGPIPE, SIG_IGN);
   #endif
   #ifdef VM_PROFILING
       vm_print_profile(stderr);
   #endif
     deprep_terminal();      deprep_terminal();
   #ifndef STANDALONE
   #ifdef HAVE_LIBLTDL
       if (lt_dlexit()!=0)
         fprintf(stderr,"%s: lt_dlexit failed", progname);
   #endif
   #endif
     }
     if (print_metrics) {
       int i;
       fprintf(stderr, "code size = %8ld\n", dyncodesize());
   #ifndef STANDALONE
       for (i=0; i<sizeof(cost_sums)/sizeof(cost_sums[0]); i++)
         fprintf(stderr, "metric %8s: %8ld\n",
                 cost_sums[i].metricname, cost_sums[i].sum);
   #endif
       fprintf(stderr,"lb_basic_blocks = %ld\n", lb_basic_blocks);
       fprintf(stderr,"lb_labeler_steps = %ld\n", lb_labeler_steps);
       fprintf(stderr,"lb_labeler_automaton = %ld\n", lb_labeler_automaton);
       fprintf(stderr,"lb_labeler_dynprog = %ld\n", lb_labeler_dynprog);
       fprintf(stderr,"lb_newstate_equiv = %ld\n", lb_newstate_equiv);
       fprintf(stderr,"lb_newstate_new = %ld\n", lb_newstate_new);
       fprintf(stderr,"lb_applicable_base_rules = %ld\n", lb_applicable_base_rules);
       fprintf(stderr,"lb_applicable_chain_rules = %ld\n", lb_applicable_chain_rules);
     }
     if (tpa_trace) {
       fprintf(stderr, "%ld %ld lb_states\n", lb_labeler_steps, lb_newstate_new);
       fprintf(stderr, "%ld %ld lb_table_entries\n", lb_labeler_steps, lb_labeler_dynprog);
   }    }
   return retvalue;    return retvalue;
 }  }

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help