import Miranda 2.066 from upstream

1 files changed, 1315 insertions, 0 deletions

diff --git a/data.c b/data.c
new file mode 100644
index 0000000..b2a1bea
--- /dev/null
+++ b/data.c
@@ -0,0 +1,1315 @@
+/* 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.              *
+ *                                                                        *
+ * Revised to C11 standard and made 64bit compatible, January 2020        *
+ *------------------------------------------------------------------------*/
+
+#include "data.h"
+#include "big.h"
+#include "lex.h"
+#define INITSPACE 1250000
+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 int atgc,loading; /* flags, set in steer.c */
+
+word *dstack=0,*stackp,*dlim;
+/* stackp=dstack; /* if load_script made interruptible, add to reset */
+
+#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 */
+
+static void bases(void);
+static void bindparams(word,word);
+static void dsetup(void);
+static void dump_defs(word,FILE *);
+static void dump_ob(word,FILE *);
+static word hdsort(word);
+static word load_defs(FILE *);
+static void mark(word);
+static void unscramble(word);
+
+word trueheapsize()
+{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); }
+
+void 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");
+}
+
+void 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 */
+}
+
+void mallocfail(x)
+char *x;
+{ fprintf(stderr,"panic: cannot find enough free space for %s\n",x);
+  exit(1);
+}
+
+void resetgcstats()
+{ cellcount= -claims;
+  nogcs = 0;
+  initclock();
+}
+
+word make(t,x,y)  /* creates a new cell with "tag" t, "hd" x and "tl" y  */
+unsigned char t; word 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 %ld to %ld>>\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 */
+
+void setwd(x,a,b)
+word x,a,b;
+{ hd[x]= a;
+  tl[x]= b; }
+
+int collecting=0;  /* flag for reset(), in case interrupt strikes in gc */
+
+void 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 int 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 = %ld\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) */
+  bases();
+/*if(atgc)printf("bases() done\n"); /* DEBUG */
+  listp= ATOMLIMIT - 1;
+  cellcount+= claims;
+  claims= 0;
+  collecting=0;
+}
+/* int Icount; /* DEBUG */
+
+void 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 */
+}
+
+void 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 *pnvec,nextpn;  /* 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 */
+}
+
+void 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; }
+}
+
+/* test added Jan 2020 - DT */
+#define wordsize (__WORDSIZE)
+#if wordsize==32
+#define splitdouble
+union fpdatum {double real; struct{word left;word right;} bits;};
+#elif wordsize==64
+union fpdatum {double real; word bits;};
+#else
+#error "platform has unknown word size"
+#endif
+
+double get_dbl(x)
+word x;
+{ union fpdatum r;
+#ifdef splitdouble
+  r.bits.left= hd[x];
+  r.bits.right= tl[x];
+#else 
+  r.bits= hd[x];
+#endif
+  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 isfinite() */
+
+word sto_dbl(R)
+double R;
+{ union fpdatum r;
+#if !defined sparc /* */
+  if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */
+#endif
+  r.real=R;
+#ifdef splitdouble
+  return(make(DOUBLE,r.bits.left,r.bits.right));
+#else
+  return(make(DOUBLE,r.bits,0));
+#endif
+}
+
+void setdbl(x,R)
+word x;
+double R;
+{ union fpdatum r;
+#if !defined sparc /* */
+  if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */
+#endif
+  r.real=R;
+  tag[x]=DOUBLE;
+#ifdef splitdouble
+  hd[x]=r.bits.left; tl[x]=r.bits.right;
+#else
+  hd[x]=r.bits; tl[x]=0;
+#endif
+}
+
+word sto_char(c) /* assumes 0<=c<=UMAX */
+int c;
+{ return c<256?c:make(UNICODE,c,0); }
+
+word 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);
+}
+
+int is_char(x)
+word x;
+{ return 0<=x && x<256 || tag[x]==UNICODE; }
+
+word 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
+   w means (sizeof(word)) in bytes
+
+   (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                        <w bytes>
+
+   complete script              __WORDSIZE
+				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            __WORDSIZE
+                                XVERSION
+                                '\1'
+                                <w bytes>  (=errline)
+                                ... (rest as normal script)
+
+   syntax-error script          __WORDSIZE
+                                XVERSION
+                                `\0'
+                                <w 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
+#error "coding scheme breaks down: XLIMIT>512"
+#endif
+
+void putword(x,f)
+word x;
+FILE *f;
+{ int i=sizeof(word);
+  putc(x&255,f);
+  while(--i)x>>=8,putc(x&255,f);
+}
+
+word getword(f)
+FILE *f;
+{ int s=0, i=sizeof(word);
+  word x=getc(f);
+  while(--i)s += 8, x |= getc(f)<<s;
+  return x;
+}
+
+void putint(int n,FILE *f)
+{ fwrite(&n,sizeof(int),1,f); }
+
+int getint(FILE *f)
+{ int r;
+  fread(&r,sizeof(int),1,f);
+  return r; }
+
+void putdbl(word x,FILE *f)
+{ double d = get_dbl(x);
+  fwrite(&d,sizeof(double),1,f); }
+
+word getdbl(FILE *f)
+{ double d;
+  fread(&d,sizeof(double),1,f);
+  return sto_dbl(d);
+}
+
+static char prefix[pnlim];
+word preflen;
+
+void 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;
+
+void 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(wordsize,f);
+  putc(XVERSION,f);  /* identifies dump format */
+  if(files==NIL){ /* source contains syntax or metatype error */
+		  extern word oldfiles;
+		  word x;
+		  putc(0,f);
+		  putword(errline,f);
+		  for(x=oldfiles;x!=NIL;x=tl[x])
+                     fprintf(f,"%s",mkrel(get_fil(hd[x]))),putc(0,f),
+				    /*filename*/
+                     putword(fil_time(hd[x]),f); /* mtime */
+		  return; }
+  if(ND!=NIL)putc(1,f),putword(errline,f);
+  for(;files!=NIL;files=tl[files])
+     { fprintf(f,"%s",mkrel(CFN=get_fil(hd[files]))); /* filename */
+       putc(0,f);
+       putword(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);
+}
+
+void 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),
+	     putint(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 */
+}
+
+void 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: { 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);
+		putint(d,f);
+		x=rest(x);
+		while(x)
+		     putint(digit(x),f),x=rest(x);
+		putint(-1,f);
+		return; }
+		/* 4 bytes per digit wasteful at current value of IBASE */
+    case DOUBLE: putc(DBL_X,f);
+                 putdbl(x,f);
+/*
+		 putword(hd[x],f);
+#ifdef splitdouble
+		 putword(tl[x],f);
+#endif
+*/
+		 return;
+    case UNICODE: putc(UNICODE_X,f);
+                  putint(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 %ld 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),
+	              putint(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;
+
+word 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)!= wordsize || 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=getword(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=getword(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=getword(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=getword(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;
+
+void 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);
+}
+
+void 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]]);
+}
+
+word get_here(x) /* here info for id x */
+word x;
+{ word y=id_who(x);
+  return(tag[y]==CONS?tl[y]:y);
+}
+
+void dsetup()
+{ if(!dstack)
+    { dstack=(word *)malloc(1000*sizeof(word));
+      if(dstack==NULL)mallocfail("dstack");
+      dlim=dstack+1000; }
+  stackp=dstack;
+}
+
+void 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 */
+}
+
+word 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 = getint(f);
+		    *stackp++ = make(INT,ch,0);
+		    x = &rest(stackp[-1]);
+		    ch = getint(f);
+		    while(ch!= -1)
+			 *x=make(INT,ch,0),ch=getint(f),x= &rest(*x);
+		    continue; }
+      case DBL_X: *stackp++ = getdbl(f);
+/*
+#ifdef splitdouble
+		  *stackp++ = make(DOUBLE,ch,getword(f));
+#else
+                  *stackp++ = make(DOUBLE,ch,0);
+#endif
+*/
+		  continue;
+      case UNICODE_X: *stackp++ = make(UNICODE,getint(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+getint(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;
+
+int 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);
+}
+
+word geterrlin(t) /* returns errline from dump of t if relevant, 0 otherwise */
+char *t;
+{ char obf[120];
+  extern char *dicp,*dicq;
+  int ch; word 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=getword(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=getword(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);
+}
+
+word 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));
+}
+
+word 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,"\\%ld",c); 
+               else s[0]=c,s[1]='\0';
+             return(s);
+  }
+}
+
+void 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,"<%ld>",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 */
+
+void out1(f,x)
+FILE *f;
+word x;
+{ if(x<0||x>TOP){ fprintf(f,"<%ld>",x); return; }
+  if(tag[x]==AP)
+    { out1(f,hd[x]);
+      putc(' ',f);
+      out2(f,tl[x]); }
+  else out2(f,x); }
+
+void out2(f,x)
+FILE *f;
+word x;
+{ extern char *yysterm[], *cmbnms[];
+  if(x<0||x>TOP){ fprintf(f,"<%ld>",x); return; }
+  if(tag[x]==INT)
+    { if(rest(x))
+	{ x=bigtostr(x);
+	  while(x)putc(hd[x],f),x=tl[x]; }
+      else fprintf(f,"%ld",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,"'\%lx'",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,%ld)",(char *)hd[x],tl[x]);
+      return; }
+  if(tag[x]==FILEINFO)
+    { fprintf(f,"FILEINFO(%s,%ld)",(char *)hd[x],tl[x]);
+      return; }
+  if(tag[x]==CONSTRUCTOR)
+    { fprintf(f,"CONSTRUCTOR(%ld)",hd[x]);
+      return; }
+  if(tag[x]==STRCONS)
+    { fprintf(f,"<$%ld>",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,"<%ld|tag=%d>",x,tag[x]); return; }
+  putc('(',f);
+  out(f,x);
+  putc(')',f); }
+
+void 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  */
+