/* MIRANDA DATA REPRESENTATIONS */

/**************************************************************************
 * Copyright (C) Research Software Limited 1985-90.  All rights reserved. *
 * The Miranda system is distributed as free software under the terms in  *
 * the file "COPYING" which is included in the distribution.              *
 *------------------------------------------------------------------------*/

#include "data.h"
#include "big.h"
#define INITSPACE 250000
word SPACE=INITSPACE; /* false ceiling in heap to improve paging behaviour
			during compilation */
extern word SPACELIMIT; /* see steer.c for default value */
     /* SPACELIMIT controls the size of the heap (i.e. the number of list
	cells available) - the minimum survivable number given the need to 
	compile the prelude etc is probably about 6000 */
     /* Note: the size of a list cell is 2 ints + 1 char  */
#define BIGTOP (SPACELIMIT + ATOMLIMIT)
word listp=ATOMLIMIT-1;
word *hdspace,*tlspace;
long long cellcount=0;
long claims=0;
long nogcs=0;
extern word atgc; /* flag, set in steer.c */
#define poschar(c) !(negchar((c)-1))
#define negchar(c) (c&128)
   /* safest to test for -ve chars this way, since not all m/c's do sign
      extension - DT Jan 84 */

trueheapsize()
{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); }

setupheap()
{ hdspace=(word *)malloc(SPACELIMIT*sizeof(word));
  tlspace=(word *)malloc(SPACELIMIT*sizeof(word));
  hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT;
  if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
  tag=(char *)calloc(BIGTOP+1,sizeof(char));
  /* NB use calloc because it sets contents to zero */
  /* tag[TOP] must be zero and exists as a sentinel */
  if(hdspace==NULL||tlspace==NULL||tag==NULL)mallocfail("heap");
}

resetheap()  /* warning - cannot do this dynamically, because both the 
		compiler and the reducer hold onto absolute heap addresses
		during certain space consuming computations */
{ if(SPACELIMIT<trueheapsize())
    fprintf(stderr,"impossible event in resetheap\n"),exit(1);
  hdspace=(word *)realloc((char *)hdspace,SPACELIMIT*sizeof(word));
  if(hdspace==NULL)mallocfail("heap");
  tlspace=(word *)realloc((char *)tlspace,SPACELIMIT*sizeof(word));
  if(tlspace==NULL)mallocfail("heap");
  hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT;
  tag=(char *)realloc(tag,BIGTOP+1); 
  if(tag==NULL)mallocfail("heap");
  tag[BIGTOP]=0;
  if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
  if(SPACE<INITSPACE&&INITSPACE<=SPACELIMIT)SPACE=INITSPACE,tag[TOP]=0;
  /* tag[TOP] is always zero and exists as a sentinel */
}

mallocfail(x)
char *x;
{ fprintf(stderr,"panic: cannot find enough free space for %s\n",x);
  exit(1);
}

resetgcstats()
{ cellcount= -claims;
  nogcs = 0;
  initclock();
}

make(t,x,y)  /* creates a new cell with "tag" t, "hd" x and "tl" y  */
word t,x,y;
{ while(poschar(tag[++listp]));
       /* find next cell with zero or negative tag (=unwanted) */
  if(listp==TOP)
    { if(SPACE!=SPACELIMIT)
      if(!compiling)SPACE=SPACELIMIT; else
      if(claims<=SPACE/4&&nogcs>1)
        { /* during compilation we raise false ceiling whenever residency 
	     reaches 75% on 2 successive gc's */
          static word wait=0;
	  word sp=SPACE;
	  if(wait)wait--; else
            SPACE+= SPACE/2,wait=2,
	    SPACE=5000*(1+(SPACE-1)/5000); /* round upwards */
          if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
          if(atgc&&SPACE>sp)
	    printf( "\n<<increase heap from %d to %d>>\n",sp,SPACE);
        }
      if(listp==TOP)
        {
#if defined ORION105
          asm("savew6");
          gc();
          asm("restw6");
#elif defined sparc
	  asm("ta	0x03"); /* see /usr/include/sun4/trap.h */
	  /* asm("ta	ST_FLUSH_WINDOWS"); */
          gc();
#else
          gc();
#endif
          if(t>STRCONS)mark(x);
          if(t>=INT)mark(y);
          return(make(t,x,y)); }
    }
  claims++;
  tag[listp]= t;
  hd[listp]= x;
  tl[listp]= y;
  return(listp); }

/* cons ap ap2 ap3 are all #defined in terms of make
   - see MIRANDA DECLARATIONS */

setwd(x,a,b)
word x,a,b;
{ hd[x]= a;
  tl[x]= b; }

word collecting=0;  /* flag for reset(), in case interrupt strikes in gc */

gc()       /*  the "garbage collector"  */
{ char *p1;
  extern word making;
  collecting=1;
  p1= &(tag[ATOMLIMIT]);
  if(atgc)
    printf("\n<<gc after %ld claims>>\n",claims);
  if(claims<=SPACE/10 && nogcs>1 && SPACE==SPACELIMIT)
  { /* if heap utilisation exceeds 90% on 2 successive gc's, give up */
    static word hnogcs=0;
    if(nogcs==hnogcs)
      { extern word ideep;
        extern char *current_script;
        fprintf(stderr,"<<not enough heap space -- task abandoned>>\n");
	if(!compiling)outstats();
        if(compiling&&ideep==0)
          fprintf(stderr,"not enough heap to compile current script\n"),
          fprintf(stderr,"script = \"%s\", heap = %d\n",current_script,SPACE);
        exit(1); } /* if compiling should reset() instead - FIX LATER */
    else hnogcs=nogcs+1; }
  nogcs++;
  while(*p1= -*p1)p1++;  /* make all tags -ve (= unwanted) */
/*if(atgc)
    { extern int lasthead;
#define BACKSTOP 020000000000
      printf("bases() called\n");
      printf("lasthead= ");
      if(lasthead==BACKSTOP)printf("BACKSTOP");
      else out(stdout,lasthead);
      putchar('\n'); } /* DEBUG */
  bases();
/*if(atgc)printf("bases() done\n"); /* DEBUG */
  listp= ATOMLIMIT - 1;
  cellcount+= claims;
  claims= 0;
  collecting=0;
}
/* int Icount; /* DEBUG */

gcpatch() /* called when gc interrupted - see reset in steer.c */
/* must not allocate any cells between calling this and next gc() */
{ char *p1; 
  for(p1= &(tag[ATOMLIMIT]);*p1;p1++)if(negchar(*p1))*p1= -*p1;
 /* otherwise mutator crashes on funny tags */
}

bases()  /*  marks everthing that must be saved  */
{ word *p;
  extern YYSTYPE yyval;
  extern word *cstack;
  extern word fileq,primenv;
  extern word cook_stdin,common_stdin,common_stdinb,rv_expr,rv_script;
  extern word margstack,vergstack,litstack,linostack,prefixstack;
  extern word idsused,suppressids,lastname,
             eprodnts,nonterminals,ntmap,ihlist,ntspecmap,gvars,lexvar;
  extern word R,TABSTRS,SGC,ND,SBND,NT,current_id,meta_pending;
  extern word showchain,newtyps,algshfns,errs,speclocs;
  extern word SUBST[],tvmap,localtvmap;
  extern word tfnum,tfbool,tfbool2,tfnum2,tfstrstr,
	     tfnumnum,ltchar,bnf_t,tstep,tstepuntil;
  extern word exec_t,read_t,filestat_t;
  extern word big_one;
  extern word nill,standardout;
  extern word lexstates,lexdefs,oldfiles,includees,embargoes,exportfiles,
             exports,internals, freeids,tlost,detrop,rfl,bereaved,ld_stuff;
  extern word CLASHES,ALIASES,SUPPRESSED,TSUPPRESSED,DETROP,MISSING,fnts,FBS;
  extern word outfilq,waiting;
  /* Icount=0; /* DEBUG */
  p= (word *)&p;
/* we follow everything on the C stack that looks like  a  pointer  into
list space. This is failsafe in that the worst that can happen,if e.g. a
stray integer happens to point into list  space,  is  that  the  garbage
collector will collect less garbage than it could have done */
  if(p<cstack) /* which way does stack grow? */
    while(++p!=cstack)mark(*p);/* for machines with stack growing downwards */
  else
    while(--p!=cstack)mark(*p);/* for machines with stack growing upwards */
  mark(*cstack);
/* now follow all pointer-containing external variables */
  mark(outfilq);
  mark(waiting);
  if(compiling||rv_expr||rv_script) /* rv flags indicate `readvals' in use */
  { extern YYSTYPE *yyvs, *yyvsp;
    extern word namebucket[];
    extern word *dstack,*stackp; /* undump stack - see load_script(), below */
    extern word *pnvec,nextpn,loading;  /* private name vector */
    extern word make_status;
    word i;
    mark(make_status);
    mark(primenv);
    mark(fileq);
    mark(idsused);
    mark(eprodnts);
    mark(nonterminals);
    mark(ntmap);
    mark(ihlist);
    mark(ntspecmap);
    mark(gvars);
    mark(lexvar);
    mark(common_stdin);
    mark(common_stdinb);
    mark(cook_stdin);
    mark(margstack);
    mark(vergstack);
    mark(litstack);
    mark(linostack);
    mark(prefixstack);
    mark(files);
    mark(oldfiles);
    mark(includees);
    mark(freeids);
    mark(exports);
    mark(internals);
    mark(CLASHES);
    mark(ALIASES);
    mark(SUPPRESSED);
    mark(TSUPPRESSED);
    mark(DETROP);
    mark(MISSING);
    mark(FBS);
    mark(lexstates);
    mark(lexdefs);
    for(i=0;i<128;i++)
       if(namebucket[i])mark(namebucket[i]);
    for(p=dstack;p<stackp;p++)mark(*p);
    if(loading)
      { mark(algshfns);
	mark(speclocs);
        mark(exportfiles);
        mark(embargoes);
        mark(rfl);
        mark(detrop);
        mark(bereaved);
        mark(ld_stuff);
        mark(tlost);
        for(i=0;i<nextpn;i++)mark(pnvec[i]); }
    mark(lastname);
    mark(suppressids);
    mark(lastexp);
    mark(nill);
    mark(standardout);
    mark(big_one);
    mark(yyval);
/*  for(vp= yyvs;vp<=yyvsp;vp++)mark(*vp); */
    mark(yylval);
    mark(R);
    mark(TABSTRS);
    mark(SGC);
    mark(ND);
    mark(SBND);
    mark(NT);
    mark(current_id);
    mark(meta_pending);
    mark(newtyps);
    mark(showchain);
    mark(errs);
    mark(tfnum);
    mark(tfbool);
    mark(tfbool2);
    mark(tfnum2);
    mark(tfstrstr);
    mark(tfnumnum);
    mark(ltchar);
    mark(bnf_t);
    mark(exec_t);
    mark(read_t);
    mark(filestat_t);
    mark(tstep);
    mark(tstepuntil);
    mark(tvmap);
    mark(localtvmap);
    for(i=0;i<hashsize;i++)mark(SUBST[i]); }
/*  if(atgc)printf("<<%d I-nodes>>\n",Icount); /* DEBUG */
}

#define tlptrbits 030000000000
/* see reduce.c */

mark(x)   /* a marked cell is distinguished by having a +ve "tag" */
word x;
{ x&= ~tlptrbits; /* x may be a `reversed pointer' (see reduce.c) */
  while(isptr(x)&&negchar(tag[x]))
  { /*if(hd[x]==I)Icount++; /* DEBUG */
    if((tag[x]= -tag[x])<INT)return;
    if(tag[x]>STRCONS)mark(hd[x]);
    x= tl[x]&~tlptrbits; }
}

union numparts {double real; struct{word left;word right;} parts;};

double get_dbl(x)
word x;
{ union numparts r;
  r.parts.left= hd[x];
  r.parts.right= tl[x];
  return(r.real); }

/* Miranda's arithmetic model requires fp overflow trapped.  On sparc this
   can be done by setting a trap with ieee_handler (see steer.c) otherwise
   we test for overflow with finite(), see IEEE754-1985 (Appendix) */

sto_dbl(R)
double R;
{ union numparts r;
#if !defined sparc /* */
  if(!finite(R))fpe_error(); /* see note on arithmetic model above */
#endif /* */
  r.real=R;
  return(make(DOUBLE,r.parts.left,r.parts.right));
}

setdbl(x,R)
double R;
{ union numparts r;
#if !defined sparc /* */
  if(!finite(R))fpe_error(); /* see note on arithmetic model above */
#endif /* */
  r.real=R;
  tag[x]=DOUBLE; hd[x]=r.parts.left; tl[x]=r.parts.right;
}

sto_char(c) /* assumes 0<=c<=UMAX */
word c;
{ return c<256?c:make(UNICODE,c,0); }

get_char(x)
word x;
{ if(x<256)return x;
  if(tag[x]==UNICODE)return hd[x];
  fprintf(stderr,"impossible event in get_char(x), tag[x]==%d\n",tag[x]);
  exit(1);
}

is_char(x)
word x;
{ return 0<=x && x<256 || tag[x]==UNICODE; }

sto_id(p1)
char *p1;
{ return(make(ID,cons(strcons(p1,NIL),undef_t),UNDEF)); }
  /* the hd of an ID contains cons(strcons(name,who),type) and 
     the tl has the value */
  /* who is NIL, hereinfo, or cons(aka,hereinfo) where aka
     is of the form datapair(oldname,0) oldname being a string */
  /* hereinfo is fileinfo(script,line_no) */

/* hereafter is stuff for dumping and undumping compiled scripts

   (internal heap object)       (external file rep - char sequence)
   ----------------------       -----------------------------------
   0..127                       self
   128..383                     CHAR_X (self-128)
   384..ATOMLIMIT-1             (self-256)
   integer (-127..127)          SHORT_X <byte>
   integer                      INT_X <4n bytes> (-1)
   double                       DBL_X <8 bytes>
   unicode_char                 UNICODE_X <4 bytes>
   typevar                      TVAR_X <byte>
   ap(x,y)                      [x] [y] AP_X
   cons(x,y)                    [y] [x] CONS_X
   id (=occurrence)             ID_X <string terminated by '\0'>
   pname (=occurrence)          PN_X <2 bytes>
                                PN1_X <4 bytes>
   datapair(string,0)           AKA_X <string...\0>
   fileinfo(script,line_no)     HERE_X <string...\0> <2 bytes>     (**)
   constructor(n,x)             [x] CONSTRUCT_X <2 bytes>
   readvals(h,t)                [t] RV_X
   definition                   [val] [type] [who] [id] DEF_X
                                [val] [pname] DEF_X
   definition-list              [definition*] DEF_X
   filename                     <string terminated by '\0'>
   mtime                        <4 bytes>

   complete script              XVERSION
                                [ [filename]
                                  [mtime]
                                  [shareable]          (=0 or 1)
                                  [definition-list] ]+
                                '\0'
                                [definition-list]      (algshfns)
                                [ND] or [True]         (see below)
                                DEF_X
                                [SGC]
                                DEF_X
                                [freeids]
                                DEF_X
                                [definition-list]      (internals)

   type-error script            XVERSION
                                '\1'
                                <4 bytes>  (=errline)
                                ... (rest as normal script)

   syntax-error script          XVERSION
                                `\0'
                                <4 bytes>  (=errline)
                                [ [filename]
                                  [mtime] ]+

   Notes
   -----
   first filename in dump must be that of `current_script' (ie the
   main source file).  All pathnames in dump are correct wrt the
   directory of the main source.
   (**) empty string is abbreviation for current filename in hereinfo
   True in ND position indicates an otherwise correct dump whose exports
   include type orphans

   Pending:
   --------
   could have abbreviation for iterated ap and cons

   remaining issue - external format should be machine and version
   independent - not clear how to do this
*/

#define XBASE ATOMLIMIT-256
#define CHAR_X (XBASE)
#define SHORT_X (XBASE+1)
#define INT_X (XBASE+2)
#define DBL_X (XBASE+3)
#define ID_X (XBASE+4)
#define AKA_X (XBASE+5)
#define HERE_X (XBASE+6)
#define CONSTRUCT_X (XBASE+7)
#define RV_X (XBASE+8)
#define PN_X (XBASE+9)
#define PN1_X (XBASE+10)
#define DEF_X (XBASE+11)
#define AP_X (XBASE+12)
#define CONS_X (XBASE+13)
#define TVAR_X (XBASE+14)
#define UNICODE_X (XBASE+15)
#define XLIMIT (XBASE+16)
#if XLIMIT>512
SEE ME!!! /* coding scheme breaks down if this occurs */
#else

static char prefix[pnlim];
word preflen;

setprefix(p)  /* to that of pathname p */
char *p;
{ char *g;
  (void)strcpy(prefix,p);
  g=rindex(prefix,'/');
  if(g)g[1]='\0';
  else *prefix='\0'; 
  preflen = strlen(prefix);
} /* before calling dump_script or load_script must setprefix() to that
     of current pathname of file being dumped/loaded - to get correct
     translation between internal pathnames (relative to dump script)
     and external pathnames */

char *mkrel(p) /* makes pathname p correct relative to prefix */
char *p;       /* must use when writing pathnames to dump */
{ if(strncmp(prefix,p,preflen)==0)return(p+preflen);
  if(p[0]=='/')return(p);
  fprintf(stderr,"impossible event in mkrelative\n"); /* or use getwd */
  /* not possible because all relative pathnames in files were computed
     wrt current script */
  return(p); /* proforma only */
}

#define bits_15 0177777
char *CFN;

dump_script(files,f) /* write compiled script files to file f */
word files;
FILE *f;
{ extern word ND,bereaved,errline,algshfns,internals,freeids,SGC;
  putc(XVERSION,f);  /* identifies dump format */
  if(files==NIL){ /* source contains syntax or metatype error */
		  extern word oldfiles;
		  word x;
		  putc(0,f);
		  putw(errline,f);
		  for(x=oldfiles;x!=NIL;x=tl[x])
                     fprintf(f,"%s",mkrel(get_fil(hd[x]))),putc(0,f),
				    /*filename*/
                     putw(fil_time(hd[x]),f); /* mtime */
		  return; }
  if(ND!=NIL)putc(1,f),putw(errline,f);
  for(;files!=NIL;files=tl[files])
     { fprintf(f,"%s",mkrel(CFN=get_fil(hd[files]))); /* filename */
       putc(0,f);
       putw(fil_time(hd[files]),f);
       putc(fil_share(hd[files]),f);
       dump_defs(fil_defs(hd[files]),f);
     }
 putc(0,f); /* header - not a possible filename */
 dump_defs(algshfns,f);
 if(ND==NIL&&bereaved!=NIL)dump_ob(True,f); /* special flag */
 else dump_ob(ND,f); 
 putc(DEF_X,f);
 dump_ob(SGC,f);
 putc(DEF_X,f);
 dump_ob(freeids,f);
 putc(DEF_X,f);
 dump_defs(internals,f);
}

dump_defs(defs,f)  /* write list of defs to file f */
word defs;
FILE *f;
{ while(defs!=NIL)
       if(tag[hd[defs]]==STRCONS) /* pname */
	 { word v=get_pn(hd[defs]);
	   dump_ob(pn_val(hd[defs]),f);
	   if(v>bits_15)
	     putc(PN1_X,f),
	     putw(v,f);
	   else
	     putc(PN_X,f),
	     putc(v&255,f),
             putc(v >> 8,f);
           putc(DEF_X,f);
           defs=tl[defs]; }
       else
       { dump_ob(id_val(hd[defs]),f);
         dump_ob(id_type(hd[defs]),f);
         dump_ob(id_who(hd[defs]),f);
         putc(ID_X,f);
         fprintf(f,"%s",(char *)get_id(hd[defs]));
         putc(0,f);
         putc(DEF_X,f);
         defs=tl[defs]; }
  putc(DEF_X,f); /* delimiter */
}

dump_ob(x,f)  /* write combinatory expression x to file f */
word x;
FILE *f;
{ /* printob("dumping: ",x); /* DEBUG */
  switch(tag[x])
  { case ATOM: if(x<128)putc(x,f); else
               if(x>=384)putc(x-256,f); else
               putc(CHAR_X,f),putc(x-128,f);
               return;
    case TVAR: putc(TVAR_X,f), putc(gettvar(x),f);
	       if(gettvar(x)>255)
		 fprintf(stderr,"panic, tvar too large\n");
	       return;
    case INT: { /* 32 bit version (suppressed)
		int d=get_int(x);
		if(abs(d)<=127)
		  { putc(SHORT_X,f); putc(d,f); return; }
		putc(INT_X,f);
		putw(d,f);
		/* variable length version */
		word d=digit(x);
		if(rest(x)==0&&(d&MAXDIGIT)<=127)
		  { if(d&SIGNBIT)d= -(d&MAXDIGIT);
		    putc(SHORT_X,f); putc(d,f); return; }
		putc(INT_X,f);
		putw(d,f);
		x=rest(x);
		while(x)
		     putw(digit(x),f),x=rest(x);
		putw(-1,f);
		/* end of variable length version */
		return; }
		/* 4 bytes per digit wasteful at current value of IBASE */
    case DOUBLE: putc(DBL_X,f);
		 putw(hd[x],f);
		 putw(tl[x],f);
		 return;
    case UNICODE: putc(UNICODE_X,f);
                  putw(hd[x],f);
                  return;
    case DATAPAIR: fprintf(f,"%c%s",AKA_X,(char *)hd[x]);
	           putc(0,f);
	           return;
    case FILEINFO: { word line=tl[x];
		     if((char *)hd[x]==CFN)putc(HERE_X,f);
		     else fprintf(f,"%c%s",HERE_X,mkrel(hd[x]));
		     putc(0,f);
		     putc(line&255,f);
		     putc((line >>= 8)&255,f);
		     if(line>255)fprintf(stderr,
		     "impossible line number %d in dump_ob\n",tl[x]);
		     return; }
    case CONSTRUCTOR: dump_ob(tl[x],f);
		      putc(CONSTRUCT_X,f);
		      putc(hd[x]&255,f);
		      putc(hd[x]>>8,f);
		      return;
    case STARTREADVALS: dump_ob(tl[x],f);
			putc(RV_X,f);
			return;
    case ID: fprintf(f,"%c%s",ID_X,get_id(x));
	     putc(0,f);
	     return;
    case STRCONS: { word v=get_pn(x); /* private name */
	            if(v>bits_15)
	              putc(PN1_X,f),
	              putw(v,f);
	            else
		      putc(PN_X,f),
		      putc(v&255,f),
		      putc(v >> 8,f);
		    return; }
    case AP: dump_ob(hd[x],f);
	     dump_ob(tl[x],f);
	     putc(AP_X,f);
	     return;
    case CONS: dump_ob(tl[x],f);
	       dump_ob(hd[x],f);
	       putc(CONS_X,f);
	       return;
    default: fprintf(stderr,"impossible tag %d in dump_ob\n",tag[x]);
    }
}

#define ovflocheck if(dicq-dic>DICSPACE)dicovflo()
extern char *dic; extern word DICSPACE;

word BAD_DUMP=0,CLASHES=NIL,ALIASES=NIL,PNBASE=0,SUPPRESSED=NIL,
    TSUPPRESSED=NIL,TORPHANS=0;

load_script(f,src,aliases,params,main)
	     /* loads a compiled script from file f for source src */
	     /* main=1 if is being loaded as main script, 0 otherwise */
FILE *f;
char *src;
word aliases,params,main;
{ extern word nextpn,ND,errline,algshfns,internals,freeids,includees,SGC;
  extern char *dicp, *dicq;
  word ch,files=NIL;
  TORPHANS=BAD_DUMP=0;
  CLASHES=NIL;
  dsetup();
  setprefix(src);
  if(getc(f)!=XVERSION){ BAD_DUMP= -1; return(NIL); }
  if(aliases!=NIL)
    { /* for each `old' install diversion to `new' */
      /* if alias is of form -old `new' is a pname */
      word a,hold;
      ALIASES=aliases;
      for(a=aliases;a!=NIL;a=tl[a])
	 { word old=tl[hd[a]],new=hd[hd[a]];
	   hold=cons(id_who(old),cons(id_type(old),id_val(old)));
	   id_type(old)=alias_t;
	   id_val(old)=new;
	   if(tag[new]==ID)
           if((id_type(new)!=undef_t||id_val(new)!=UNDEF)
	      &&id_type(new)!=alias_t)
	     CLASHES=add1(new,CLASHES);
	   hd[hd[a]]=hold;
         }
      if(CLASHES!=NIL){ BAD_DUMP= -2; unscramble(aliases); return(NIL); }
      for(a=aliases;a!=NIL;a=tl[a]) /* FIX1 */
	 if(tag[ch=id_val(tl[hd[a]])]==ID) /* FIX1 */
	 if(id_type(ch)!=alias_t) /* FIX1 */
	    id_type(ch)=new_t; /* FIX1 */
    }
  PNBASE=nextpn;  /* base for relocation of internal names in dump */
  SUPPRESSED=NIL; /* list of `-id' aliases successfully obeyed */
  TSUPPRESSED=NIL;  /* list of -typename aliases (illegal just now) */
  while((ch=getc(f))!=0&&ch!=EOF&&!BAD_DUMP)
       { word s,holde=0;
	 dicq=dicp;
	 if(files==NIL&&ch==1) /* type error script */
           { holde=getw(f),ch=getc(f);
	     if(main)errline=holde; }
	 if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
		   /* locate wrt current posn */
         *dicq++ = ch;
         while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */
	 ovflocheck;
         ch=getw(f); /* mtime */
	 s=getc(f); /* share bit */
         /*printf("loading: %s(%d)\n",dicp,ch); /* DEBUG */
	 if(files==NIL) /* is this the right dump? */
	 if(strcmp(dicp,src))
	   { BAD_DUMP=1;
	     if(aliases!=NIL)unscramble(aliases);
	     return(NIL); }
	 CFN=get_id(name()); /* wasteful way to share filename */
         files = cons(make_fil(CFN,ch,s,load_defs(f)),
		      files);
       }
/* warning: load_defs side effects id's in namebuckets, cannot  be  undone  by
unload  until  attached  to  global `files', so interrupts are disabled during
load_script - see steer.c */ /* for big dumps this may be too coarse - FIX */
  if(ch==EOF||BAD_DUMP){ if(!BAD_DUMP)BAD_DUMP=2; 
	                 if(aliases!=NIL)unscramble(aliases);
	                 return(files); }
  if(files==NIL){ /* dump of syntax error state */
		  extern word oldfiles;
		  ch=getw(f);
		  if(main)errline=ch;
                  while((ch=getc(f))!=EOF)
                       { dicq=dicp;
	                 if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
		                   /* locate wrt current posn */
                         *dicq++ = ch;
                         while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */
			 ovflocheck;
                         ch=getw(f); /* mtime */
	                 if(oldfiles==NIL) /* is this the right dump? */
	                 if(strcmp(dicp,src))
	                   { BAD_DUMP=1; 
	                     if(aliases!=NIL)unscramble(aliases);
			     return(NIL); }
                         oldfiles = cons(make_fil(get_id(name()),ch,0,NIL),
		                    oldfiles);
		       }
	          if(aliases!=NIL)unscramble(aliases);
		  return(NIL); }
  algshfns=append1(algshfns,load_defs(f));
  ND=load_defs(f);
  if(ND==True)ND=NIL,TORPHANS=1;
  SGC=append1(SGC,load_defs(f));
  if(main||includees==NIL)freeids=load_defs(f);
  else bindparams(load_defs(f),hdsort(params));
  if(aliases!=NIL)unscramble(aliases);
  if(main)internals=load_defs(f);
  return(reverse(files));
}/* was it necessary to unscramble aliases before error returns?
    check this later */
/* actions labelled FIX1 were inserted to deal with the pathological case
   that the destination of an alias (not part of a cyclic alias) has a direct
   definition in the file and the aliasee is missing from the file
   - this is both nameclash and missing aliasee, but without fix the two
   errors cancel each other out and are unreported */

word DETROP=NIL,MISSING=NIL;

bindparams(formal,actual) /* process bindings of free ids */
/* formal is list of cons(id,cons(original_name,type)) */
/* actual is list of cons(name,value) | ap(name,typevalue)) */
/* both in alpha order of original name */
word formal,actual;
{ extern word FBS; word badkind=NIL;
  DETROP=MISSING=NIL;
  FBS=cons(formal,FBS);
  /* FBS is list of list of formals bound in current script */
  for(;;)
     { word a; char *f;
       while(formal!=NIL && (actual==NIL ||
   strcmp((f=(char *)hd[hd[tl[hd[formal]]]]),get_id(a=hd[hd[actual]]))<0))
	 /* the_val(hd[hd[formal]])=findid((char *)hd[hd[tl[hd[formal]]]]),
	    above line picks up identifier of that name in current scope */
	    MISSING=cons(hd[tl[hd[formal]]],MISSING),
	    formal=tl[formal];
       if(actual==NIL)break;
       if(formal==NIL||strcmp(f,get_id(a)))DETROP=cons(a,DETROP);
       else { word fa=tl[tl[hd[formal]]]==type_t?t_arity(hd[hd[formal]]):-1;
	      word ta=tag[hd[actual]]==AP?t_arity(hd[actual]):-1;
	      if(fa!=ta)
		badkind=cons(cons(hd[hd[actual]],datapair(fa,ta)),badkind);
	      the_val(hd[hd[formal]])=tl[hd[actual]];
	      formal=tl[formal]; }
       actual=tl[actual];
     }
for(;badkind!=NIL;badkind=tl[badkind])
   DETROP=cons(hd[badkind],DETROP);
}

unscramble(aliases) /* remove old to new diversions installed above */
word aliases;
{ word a=NIL;
  for(;aliases!=NIL;aliases=tl[aliases])
     { word old=tl[hd[aliases]],hold=hd[hd[aliases]];
       word new=id_val(old); 
       hd[hd[aliases]]=new; /* put back for missing check, see below */
       id_who(old)=hd[hold]; hold=tl[hold];
       id_type(old)=hd[hold];
       id_val(old)=tl[hold]; }
  for(;ALIASES!=NIL;ALIASES=tl[ALIASES])
     { word new=hd[hd[ALIASES]];
       word old=tl[hd[ALIASES]];
       if(tag[new]!=ID)
	 { if(!member(SUPPRESSED,new))a=cons(old,a);
	   continue; } /* aka stuff irrelevant to pnames */
       if(id_type(new)==new_t)id_type(new)=undef_t;  /* FIX1 */
       if(id_type(new)==undef_t)a=cons(old,a); else
       if(!member(CLASHES,new))
	 /* install aka info in new */
	 if(tag[id_who(new)]!=CONS)
	   id_who(new)=cons(datapair(get_id(old),0),id_who(new)); }
  ALIASES=a; /* transmits info about missing aliasees */
}

char *getaka(x) /* returns original name of x (as a string) */
word x;
{ word y=id_who(x);
  return(tag[y]!=CONS?get_id(x):(char *)hd[hd[y]]);
}

get_here(x) /* here info for id x */
word x;
{ word y=id_who(x);
  return(tag[y]==CONS?tl[y]:y);
}

word *dstack=0,*stackp,*dlim;
/* stackp=dstack; /* if load_script made interruptible, add to reset */

dsetup()
{ if(!dstack)
    { dstack=(word *)malloc(1000*sizeof(word));
      if(dstack==NULL)mallocfail("dstack");
      dlim=dstack+1000; }
  stackp=dstack;
}

dgrow()
{ word *hold=dstack;
  dstack=(word *)realloc(dstack,2*(dlim-dstack)*sizeof(word));
  if(dstack==NULL)mallocfail("dstack");
  dlim=dstack+2*(dlim-hold);
  stackp += dstack-hold;
  /*printf("dsize=%d\n",dlim-dstack);  /* DEBUG */
}

load_defs(f)  /* load a sequence of definitions from file f, terminated
		 by DEF_X, or a single object terminated by DEF_X */
FILE *f;
{ extern char *dicp, *dicq;
  extern word *pnvec,common_stdin,common_stdinb,nextpn,rv_script;
  word ch,defs=NIL;
  while((ch=getc(f))!=EOF)
  { if(stackp==dlim)dgrow();
    switch(ch)
    { case CHAR_X: *stackp++ = getc(f)+128;
		   continue;
      case TVAR_X: *stackp++ = mktvar(getc(f));
		   continue;
      case SHORT_X: ch = getc(f);
		    if(ch&128)ch= ch|(~127); /*force a sign extension*/
		    *stackp++ = stosmallint(ch);
		    continue;
      case INT_X: { word *x;
		    ch = getw(f);
		    *stackp++ = make(INT,ch,0);
		    /* for 32 bit version suppress to end of varpart */
		    x = &rest(stackp[-1]);
		    ch = getw(f);
		    while(ch!= -1)
			 *x=make(INT,ch,0),ch=getw(f),x= &rest(*x);
		    /* end of variable length part */
		    continue; }
      case DBL_X: ch=getw(f);
		  *stackp++ = make(DOUBLE,ch,getw(f));
		  continue;
      case UNICODE_X: *stackp++ = make(UNICODE,getw(f),0);
                      continue;
      case PN_X: ch = getc(f);
		 ch = PNBASE+(ch|(getc(f)<<8));
		 *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch);
		 /* efficiency hack for *stackp++ = sto_pn(ch); */
		 continue;
      case PN1_X: ch=PNBASE+getw(f);
		  *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch);
		  /* efficiency hack for *stackp++ = sto_pn(ch); */
		  continue;
      case CONSTRUCT_X: ch = getc(f);
		        ch = ch|(getc(f)<<8);
	                stackp[-1] = constructor(ch,stackp[-1]);
		        continue;
      case RV_X: stackp[-1] = readvals(0,stackp[-1]);
		 rv_script=1;
		 continue;
      case ID_X: dicq=dicp;
                 while((*dicq++ =ch=getc(f))&&ch!=EOF);
		 ovflocheck;
	         *stackp++=name(); /* see lex.c */
		 if(id_type(stackp[-1])==new_t) /* FIX1 (& next 2 lines) */
		   CLASHES=add1(stackp[-1],CLASHES),stackp[-1]=NIL;
		 else
		 if(id_type(stackp[-1])==alias_t) /* follow alias */
		   stackp[-1]=id_val(stackp[-1]);
	         continue;
      case AKA_X: dicq=dicp;
		  while((*dicq++ =ch=getc(f))&&ch!=EOF);
		  ovflocheck;
	          *stackp++=datapair(get_id(name()),0);
			    /* wasteful, to share string */
	          continue;
      case HERE_X: dicq=dicp;
                   ch=getc(f);
		   if(!ch){ /* coding hack, 0 means current file name */
			    ch = getc(f);
		            ch = ch|getc(f)<<8;
	                    *stackp++ = fileinfo(CFN,ch);
			    continue; }
		   /* next line locates wrt current posn */
		   if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
		   *dicq++ = ch;
                   while((*dicq++ =ch=getc(f))&&ch!=EOF);
		   ovflocheck;
		   ch = getc(f);
		   ch = ch|getc(f)<<8;
	           *stackp++ = fileinfo(get_id(name()),ch); /* wasteful */
		   continue;
      case DEF_X: switch(stackp-dstack){
		  case 0: /* defs delimiter */
		    { /*printlist("contents: ",defs); /* DEBUG */
		      return(reverse(defs)); }
		  case 1: /* ob delimiter */
		    { return(*--stackp); }
		  case 2: /* pname defn */
		    { ch = *--stackp;
		      pn_val(ch)= *--stackp;
		      defs=cons(ch,defs); /* NB defs now includes pnames */
		      continue; }
		  case 4:
		  if(tag[stackp[-1]]!=ID)
		    if(stackp[-1]==NIL){ stackp -= 4; continue; } /* FIX1 */
		    else { /* id aliased to pname */
			   word akap;
			   ch= *--stackp;
			   SUPPRESSED=cons(ch,SUPPRESSED);
			   stackp--; /* who */
			   akap= tag[*stackp]==CONS?hd[*stackp]:NIL;
			   stackp--;  /* lose type */
			   pn_val(ch)= *--stackp;
			   if(stackp[1]==type_t&&t_class(ch)!=synonym_t)
			     /* suppressed typename */
			     { word a=ALIASES; /* reverse assoc in ALIASES */
			       while(a!=NIL&&id_val(tl[hd[a]])!=ch)
			             a=tl[a];
			       if(a!=NIL) /* surely must hold ?? */
			       TSUPPRESSED=cons(tl[hd[a]],TSUPPRESSED);
			       /*if(akap==NIL)
			         akap=datapair(get_id(tl[hd[a]]),0); */
			     /*if(t_class(ch)==algebraic_t)
			     CSUPPRESS=append1(CSUPPRESS,t_info(ch));
	                     t_info(ch)= cons(akap,fileinfo(CFN,0));
	                     /* assists identifn of dangling typerefs 
		                see privatise() in steer.c */ }else
			   if(pn_val(ch)==UNDEF)
			     { /* special kludge for undefined names */
			       /* necessary only if we allow names specified
				  but not defined to be %included */
			       if(akap==NIL) /* reverse assoc in ALIASES */
				 { word a=ALIASES;
			           while(a!=NIL&&id_val(tl[hd[a]])!=ch)
					a=tl[a];
				   if(a!=NIL)
				   akap=datapair(get_id(tl[hd[a]]),0); } 
			       pn_val(ch)= ap(akap,fileinfo(CFN,0));
			       /* this will generate sensible error message
				  see reduction rule for DATAPAIR */
			     }
		           defs=cons(ch,defs);
			   continue; }
		  if(
		    id_type(stackp[-1])!=new_t&& /* FIX1 */
		    (id_type(stackp[-1])!=undef_t||
		     id_val(stackp[-1])!=UNDEF)) /* nameclash */
		    { if(id_type(stackp[-1])==alias_t) /* cyclic aliasing */
			{ word a=ALIASES;
			  while(a!=NIL&&tl[hd[a]]!=stackp[-1])a=tl[a];
			  if(a==NIL)
			    { fprintf(stderr,
			      "impossible event in cyclic alias (%s)\n",
			       get_id(stackp[-1]));
                              stackp-=4;
			      continue; }
			  defs=cons(*--stackp,defs);
			  hd[hd[hd[a]]]= *--stackp; /* who */
			  hd[tl[hd[hd[a]]]]= *--stackp; /* type */
			  tl[tl[hd[hd[a]]]]= *--stackp; /* value */
			  continue; }
		      /*if(strcmp(CFN,hd[get_here(stackp[-1])]))
			/* EXPT (ignore clash if from same original file) */
		      CLASHES=add1(stackp[-1],CLASHES);
		      stackp-=4; }
		  else
		      defs=cons(*--stackp,defs),
                      /*printf("%s undumped\n",get_id(hd[defs])), /* DEBUG */
		      id_who(hd[defs])= *--stackp,
		      id_type(hd[defs])= *--stackp,
		      id_val(hd[defs])= *--stackp;
		  continue;
		  default:
		    { /* printf("badly formed def in dump\n"); /* DEBUG */
		      BAD_DUMP=3; return(defs); } /* should unsetids */
		  } /* of switch */
      case AP_X: ch = *--stackp;
		 if(stackp[-1]==READ&&ch==0)stackp[-1] = common_stdin; else
		 if(stackp[-1]==READBIN&&ch==0)stackp[-1] = common_stdinb; else
	         stackp[-1] = ap(stackp[-1],ch);
	         continue;
      case CONS_X: ch = *--stackp;
	           stackp[-1] = cons(ch,stackp[-1]);
	           continue;
      default: *stackp++ = ch>127?ch+256:ch;
    }}
  BAD_DUMP=4; /* should unsetids */
  return(defs);
}

extern char *obsuffix;

okdump(t) /* return 1 if script t has a non-syntax-error dump */
char *t;
{ char obf[120];
  FILE *f;
  (void)strcpy(obf,t);
  (void)strcpy(obf+strlen(obf)-1,obsuffix);
  f=fopen(obf,"r");
  if(f&&getc(f)==XVERSION&&getc(f)){fclose(f); return(1); }
  return(0);
}

geterrlin(t) /* returns errline from dump of t if relevant, 0 otherwise */
char *t;
{ char obf[120];
  extern char *dicp,*dicq;
  word ch,el;
  FILE *f;
  (void)strcpy(obf,t);
  (void)strcpy(obf+strlen(obf)-1,obsuffix);
  if(!(f=fopen(obf,"r")))return(0);
  if(getc(f)!=XVERSION||(ch=getc(f))&&ch!=1){ fclose(f);
                                              return(0); }
  el=getw(f);
  /* now check this is right dump */
  setprefix(t);
  ch=getc(f);
  dicq=dicp;
  if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
            /* locate wrt current posn */
  *dicq++ = ch;
  while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */
  ch=getw(f); /* mtime */
  if(strcmp(dicp,t)||ch!=fm_time(t))return(0); /* wrong dump */
  /* this test not foolproof, strictly should extract all files and check
     their mtimes, as in undump, but this involves reading the whole dump */
  return(el);
}

hdsort(x) /* sorts list of name-value pairs on name */
word x;
{ word a=NIL,b=NIL,hold=NIL;
  if(x==NIL)return(NIL);
  if(tl[x]==NIL)return(x);
  while(x!=NIL) /* split x */
       { hold=a,a=cons(hd[x],b),b=hold;
	 x=tl[x]; }
  a=hdsort(a),b=hdsort(b);
  /* now merge two halves back together */
  while(a!=NIL&&b!=NIL)
  if(strcmp(get_id(hd[hd[a]]),get_id(hd[hd[b]]))<0)x=cons(hd[a],x),a=tl[a];
  else x=cons(hd[b],x),b=tl[b];
  if(a==NIL)a=b;
  while(a!=NIL)x=cons(hd[a],x),a=tl[a];
  return(reverse(x));
}
#endif

append1(x,y) /* rude append */
word x,y;
{ word x1=x;
  if(x1==NIL)return(y);
  while(tl[x1]!=NIL)x1=tl[x1];
  tl[x1]=y;
  return(x);
}

/* following is stuff for printing heap objects in readable form - used
   for miscellaneous diagnostics etc - main function is out(FILE *,object) */

/* charname returns the printable name of a character, as a string (using
   C conventions for control characters */  /* DAT 13/9/83 */
/* NB we use DECIMAL (not octal) for miscellaneous unprintables */

/* WARNING - you should take a copy of the name if you intend to do anything
   with it other than print it immediately */

char *charname(c)
word c;
{ static char s[5];
  switch(c)
  { case '\n': return("\\n");
    case '\t': return("\\t");
    case '\b': return("\\b");
    case '\f': return("\\f");  /* form feed */
    case '\r': return("\\r");  /* carriage return */
    case '\\': return("\\\\");
    case '\'': return("\\'");
    case '"': return("\\\"");
    /* we escape all quotes for safety, since the context could be either
       character or string quotation */
    default: if(c<32||c>126)  /* miscellaneous unprintables -- convert to decimal */
               sprintf(s,"\\%d",c); 
               else s[0]=c,s[1]='\0';
             return(s);
  }
}

out(f,x)
/* the routines "out","out1","out2" are for printing compiled expressions  */
FILE *f;
word x;
{ 
#ifdef DEBUG
  static pending=NIL;                                /* cycle trap */
  word oldpending=pending;                            /* cycle trap */
#endif
  if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; }
#ifdef DEBUG
  if(member(pending,x)){ fprintf(f,"..."); return; } /* cycle trap */
  pending=cons(x,pending);                           /* cycle trap */
#endif
  if(tag[x]==LAMBDA)
  { fprintf(f,"$(");out(f,hd[x]);putc(')',f);
    out(f,tl[x]); } else
  { while(tag[x]==CONS)
    { out1(f,hd[x]);
      putc(':',f);
      x= tl[x];
#ifdef DEBUG
      if(member(pending,x))break;                   /* cycle trap */
      pending=cons(x,pending);                      /* cycle trap */
#endif
    }
    out1(f,x); }
#ifdef DEBUG
  pending=oldpending;                               /* cycle trap */
#endif
} /* warning - cycle trap not interrupt safe if `out' used in compiling
     process */

out1(f,x)
FILE *f;
word x;
{ if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; }
  if(tag[x]==AP)
    { out1(f,hd[x]);
      putc(' ',f);
      out2(f,tl[x]); }
  else out2(f,x); }

out2(f,x)
FILE *f;
word x;
{ extern char *yysterm[], *cmbnms[];
  if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; }
  if(tag[x]==INT)
    { if(rest(x))
	{ x=bigtostr(x);
	  while(x)putc(hd[x],f),x=tl[x]; }
      else fprintf(f,"%d",getsmallint(x));
      return; }
  if(tag[x]==DOUBLE){ outr(f,get_dbl(x)); return; }
  if(tag[x]==ID){ fprintf(f,"%s",get_id(x)); return; }
  if(x<256){ fprintf(f,"\'%s\'",charname(x)); return; }
  if(tag[x]==UNICODE){ fprintf(f,"'\%x'",hd[x]); return; }
  if(tag[x]==ATOM)
    { fprintf(f,"%s",x<CMBASE?yysterm[x-256]:
		     x==True?"True":
		     x==False?"False":
		     x==NIL?"[]":
		     x==NILS?"\"\"":
		     cmbnms[x-CMBASE]); 
      return; }
  if(tag[x]==TCONS||tag[x]==PAIR)
    { fprintf(f,"(");
      while(tag[x]==TCONS)
	   out(f,hd[x]), putc(',',f), x=tl[x];
      out(f,hd[x]); putc(',',f); out(f,tl[x]);
      putc(')',f); return; }
  if(tag[x]==TRIES)
    { fprintf(f,"TRIES("); out(f,hd[x]); putc(',',f); out(f,tl[x]);
      putc(')',f); return; }
  if(tag[x]==LABEL)
    { fprintf(f,"LABEL("); out(f,hd[x]); putc(',',f); out(f,tl[x]);
      putc(')',f); return; }
  if(tag[x]==SHOW)
    { fprintf(f,"SHOW("); out(f,hd[x]); putc(',',f); out(f,tl[x]);
      putc(')',f); return; }
  if(tag[x]==STARTREADVALS)
    { fprintf(f,"READVALS("); out(f,hd[x]); putc(',',f); out(f,tl[x]);
      putc(')',f); return; }
  if(tag[x]==LET)
    { fprintf(f,"(LET ");
      out(f,dlhs(hd[x])),fprintf(f,"=");
      out(f,dval(hd[x])),fprintf(f,";IN ");
      out(f,tl[x]);
      fprintf(f,")"); return; }
  if(tag[x]==LETREC)
    { word body=tl[x]; 
      fprintf(f,"(LETREC ");
      x=hd[x];
      while(x!=NIL)out(f,dlhs(hd[x])),fprintf(f,"="),
		   out(f,dval(hd[x])),fprintf(f,";"),x=tl[x];
      fprintf(f,"IN ");
      out(f,body);
      fprintf(f,")"); return; }
  if(tag[x]==DATAPAIR)
    { fprintf(f,"DATAPAIR(%s,%d)",(char *)hd[x],tl[x]);
      return; }
  if(tag[x]==FILEINFO)
    { fprintf(f,"FILEINFO(%s,%d)",(char *)hd[x],tl[x]);
      return; }
  if(tag[x]==CONSTRUCTOR)
    { fprintf(f,"CONSTRUCTOR(%d)",hd[x]);
      return; }
  if(tag[x]==STRCONS)
    { fprintf(f,"<$%d>",hd[x]); return; }/* used as private id's, inter alia*/
  if(tag[x]==SHARE)
    { fprintf(f,"(SHARE:"); out(f,hd[x]); fprintf(f,")"); return; }
  if(tag[x]!=CONS&&tag[x]!=AP&&tag[x]!=LAMBDA)
  /* not a recognised structure */
    { fprintf(f,"<%d|tag=%d>",x,tag[x]); return; }
  putc('(',f);
  out(f,x);
  putc(')',f); }

outr(f,r)     /*  prints a number  */
FILE *f;
double r;
{ double p;
  p= r<0?-r: r;
  if(p>=1000.0||p<=.001)fprintf(f,"%e",r);
  else fprintf(f,"%f",r); }

/*  end of MIRANDA DATA REPRESENTATIONS  */