summaryrefslogtreecommitdiff
path: root/new
diff options
context:
space:
mode:
Diffstat (limited to 'new')
-rw-r--r--new/big.c643
-rw-r--r--new/data.c1250
-rw-r--r--new/lex.c1213
-rw-r--r--new/reduce.c2376
-rw-r--r--new/rules.y1686
-rw-r--r--new/steer.c2208
-rw-r--r--new/trans.c1026
-rw-r--r--new/types.c1613
8 files changed, 12015 insertions, 0 deletions
diff --git a/new/big.c b/new/big.c
new file mode 100644
index 0000000..7a1cfe1
--- /dev/null
+++ b/new/big.c
@@ -0,0 +1,643 @@
+/* MIRANDA INTEGER PACKAGE */
+/* package for unbounded precision integers */
+
+/**************************************************************************
+ * 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"
+#include <errno.h>
+
+static double logIBASE,log10IBASE;
+word big_one;
+
+void bigsetup()
+{ logIBASE=log((double)IBASE);
+ log10IBASE=log10((double)IBASE);
+ big_one=make(INT,1,0);
+}
+
+word isnat(x)
+word x;
+{ return(tag[x]==INT&&poz(x));
+}
+
+word sto_word(i) /* store C long long as mira bigint */
+long long i;
+{ word s,x;
+ if(i<0)s=SIGNBIT,i= -i; else s=0;
+ x=make(INT,s|i&MAXDIGIT,0);
+ if(i>>=DIGITWIDTH)
+ { word *p = &rest(x);
+ *p=make(INT,i&MAXDIGIT,0),p= &rest(*p);
+ while(i>>=DIGITWIDTH)
+ *p=make(INT,i&MAXDIGIT,0),p= &rest(*p); }
+ return(x);
+} /* change to long long, DT Oct 2019 */
+
+#define maxval (1ll<<60)
+
+long long get_word(x) /* mira bigint to C long long */
+word x;
+{ long long n=digit0(x);
+ word sign=neg(x);
+ if(!(x=rest(x)))return(sign?-n:n);
+{ word w=DIGITWIDTH;
+ while(x&&w<60)n+=(long long)digit(x)<<w,w+=DIGITWIDTH,x=rest(x);
+ if(x)n=maxval; /* overflow, return large value */
+ return(sign?-n:n);
+}} /* change to long long, DT Oct 2019 */
+
+word bignegate(x)
+word x;
+{ if(bigzero(x))return(x);
+ return(make(INT,hd[x]&SIGNBIT?hd[x]&MAXDIGIT:SIGNBIT|hd[x],tl[x]));
+}
+
+word bigplus(x,y)
+word x,y;
+{ if(poz(x))
+ if(poz(y))return(big_plus(x,y,0));
+ else return(big_sub(x,y));
+ else
+ if(poz(y))return(big_sub(y,x));
+ else return(big_plus(x,y,SIGNBIT)); /* both negative */
+}
+
+word big_plus(x,y,signbit) /* ignore input signs, treat x,y as positive */
+word x,y; word signbit;
+{ word d=digit0(x)+digit0(y);
+ word carry = ((d&IBASE)!=0);
+ word r = make(INT,signbit|d&MAXDIGIT,0); /* result */
+ word *z = &rest(r); /* pointer to rest of result */
+ x = rest(x); y = rest(y);
+ while(x&&y) /* this loop has been unwrapped once, see above */
+ { d = carry+digit(x)+digit(y);
+ carry = ((d&IBASE)!=0);
+ *z = make(INT,d&MAXDIGIT,0);
+ x = rest(x); y = rest(y); z = &rest(*z); }
+ if(y)x=y; /* by convention x is the longer one */
+ while(x)
+ { d = carry+digit(x);
+ carry = ((d&IBASE)!=0);
+ *z = make(INT,d&MAXDIGIT,0);
+ x = rest(x); z = &rest(*z); }
+ if(carry)*z=make(INT,1,0);
+ return(r);
+}
+
+word bigsub(x,y)
+word x,y;
+{ if(poz(x))
+ if(poz(y))return(big_sub(x,y));
+ else return(big_plus(x,y,0)); /* poz x, negative y */
+ else
+ if(poz(y))return(big_plus(x,y,SIGNBIT)); /* negative x, poz y */
+ else return(big_sub(y,x)); /* both negative */
+}
+
+word big_sub(x,y) /* ignore input signs, treat x,y as positive */
+word x,y;
+{ word d = digit0(x)-digit0(y);
+ word borrow = (d&IBASE)!=0;
+ word r=make(INT,d&MAXDIGIT,0); /* result */
+ word *z = &rest(r);
+ word *p=NULL; /* pointer to trailing zeros, if any */
+ x = rest(x); y = rest(y);
+ while(x&&y) /* this loop has been unwrapped once, see above */
+ { d = digit(x)-digit(y)-borrow;
+ borrow = (d&IBASE)!=0;
+ d = d&MAXDIGIT;
+ *z = make(INT,d,0);
+ if(d)p=NULL; else if(!p)p=z;
+ x = rest(x); y = rest(y); z = &rest(*z); }
+ while(y) /* at most one of these two loops will be invoked */
+ { d = -digit(y)-borrow;
+ borrow = ((d&IBASE)!=0);
+ d = d&MAXDIGIT;
+ *z = make(INT,d,0);
+ if(d)p=NULL; else if(!p)p=z;
+ y = rest(y); z = &rest(*z); }
+ while(x) /* alternative loop */
+ { d = digit(x)-borrow;
+ borrow = ((d&IBASE)!=0);
+ d = d&MAXDIGIT;
+ *z = make(INT,d,0);
+ if(d)p=NULL; else if(!p)p=z;
+ x = rest(x); z = &rest(*z); }
+ if(borrow) /* result is negative - take complement and add 1 */
+ { p=NULL;
+ d = (digit(r)^MAXDIGIT) + 1;
+ borrow = ((d&IBASE)!=0); /* borrow now means `carry' (sorry) */
+ digit(r) = SIGNBIT|d; /* set sign bit of result */
+ z = &rest(r);
+ while(*z)
+ { d = (digit(*z)^MAXDIGIT)+borrow;
+ borrow = ((d&IBASE)!=0);
+ digit(*z) = d = d&MAXDIGIT;
+ if(d)p=NULL; else if(!p)p=z;
+ z = &rest(*z); }
+ }
+ if(p)*p=0; /* remove redundant (ie trailing) zeros */
+ return(r);
+}
+
+word bigcmp(x,y) /* returns +ve,0,-ve as x greater than, equal, less than y */
+word x,y;
+{ word d,r,s=neg(x);
+ if(neg(y)!=s)return(s?-1:1);
+ r=digit0(x)-digit0(y);
+ for(;;)
+ { x=rest(x); y=rest(y);
+ if(!x)if(y)return(s?1:-1);
+ else return(s?-r:r);
+ if(!y)return(s?-1:1);
+ d=digit(x)-digit(y);
+ if(d)r=d; }
+}
+
+word bigtimes(x,y) /* naive multiply - quadratic */
+word x,y;
+{ if(len(x)<len(y))
+ { word hold=x; x=y; y=hold; } /* important optimisation */
+ word r=make(INT,0,0);
+ word d = digit0(y);
+ word s=neg(y);
+ word n=0;
+ if(bigzero(x))return(r); /* short cut */
+ for(;;)
+ { if(d)r = bigplus(r,shift(n,stimes(x,d)));
+ n++;
+ y = rest(y);
+ if(!y)
+ return(s!=neg(x)?bignegate(r):r);
+ d=digit(y); }
+}
+
+
+word shift(n,x) /* multiply big x by n'th power of IBASE */
+word n,x;
+{ while(n--)x=make(INT,0,x);
+ return(x);
+} /* NB - we assume x non-zero, else unnormalised result */
+
+word stimes(x,n) /* multiply big x (>=0) by digit n (>0) */
+word x,n;
+{ unsigned d= n*digit0(x); /* ignore sign of x */
+ word carry=d>>DIGITWIDTH;
+ word r = make(INT,d&MAXDIGIT,0);
+ word *y = &rest(r);
+ while(x=rest(x))
+ d=n*digit(x)+carry,
+ *y=make(INT,d&MAXDIGIT,0),
+ y = &rest(*y),
+ carry=d>>DIGITWIDTH;
+ if(carry)*y=make(INT,carry,0);
+ return(r);
+}
+
+word b_rem; /* contains remainder from last call to longdiv or shortdiv */
+
+word bigdiv(x,y) /* may assume y~=0 */
+word x,y;
+{ word s1,s2,q;
+ /* make x,y positive and remember signs */
+ if(s1=neg(y))y=make(INT,digit0(y),rest(y));
+ if(neg(x))
+ x=make(INT,digit0(x),rest(x)),s2=!s1;
+ else s2=s1;
+ /* effect: s1 set iff y negative, s2 set iff signs mixed */
+ if(rest(y))q=longdiv(x,y);
+ else q=shortdiv(x,digit(y));
+ if(s2){ if(!bigzero(b_rem))
+ { x=q;
+ while((digit(x)+=1)==IBASE) /* add 1 to q in situ */
+ { digit(x)=0;
+ if(!rest(x)){ rest(x)=make(INT,1,0); break; }
+ else x=rest(x);
+ }
+ }
+ if(!bigzero(q))digit(q)=SIGNBIT|digit(q);
+ }
+ return(q);
+}
+
+word bigmod(x,y) /* may assume y~=0 */
+word x,y;
+{ word s1,s2;
+ /* make x,y positive and remember signs */
+ if(s1=neg(y))y=make(INT,digit0(y),rest(y));
+ if(neg(x))
+ x=make(INT,digit0(x),rest(x)),s2=!s1;
+ else s2=s1;
+ /* effect: s1 set iff y negative, s2 set iff signs mixed */
+ if(rest(y))longdiv(x,y);
+ else shortdiv(x,digit(y));
+ if(s2){ if(!bigzero(b_rem))
+ b_rem = bigsub(y,b_rem);
+ }
+ return(s1?bignegate(b_rem):b_rem);
+}
+
+/* NB - above have entier based handling of signed cases (as Miranda) in
+ which remainder has sign of divisor. To get this:- if signs of
+ divi(sor/dend) mixed negate quotient and if remainder non-zero take
+ complement and add one to magnitude of quotient */
+
+/* for alternative, truncate based handling of signed cases (usual in C):-
+ magnitudes invariant under change of sign, remainder has sign of
+ dividend, quotient negative if signs of divi(sor/dend) mixed */
+
+word shortdiv(x,n) /* divide big x by single digit n returning big quotient
+ and setting external b_rem as side effect */
+ /* may assume - x>=0,n>0 */
+word x,n;
+{ word d=digit(x),s_rem,q=0;
+ while(x=rest(x)) /* reverse rest(x) into q */
+ q=make(INT,d,q),d=digit(x); /* leaving most sig. digit in d */
+ { word tmp;
+ x=q; s_rem=d%n; d=d/n;
+ if(d||!q)q=make(INT,d,0); /* put back first digit (if not leading 0) */
+ else q=0;
+ while(x) /* in situ division of q by n AND destructive reversal */
+ d=s_rem*IBASE+digit(x),digit(x)=d/n,s_rem=d%n,
+ tmp=x,x=rest(x),rest(tmp)=q,q=tmp;
+ }
+ b_rem=make(INT,s_rem,0);
+ return(q);
+}
+
+word longdiv(x,y) /* divide big x by big y returning quotient, leaving
+ remainder in extern variable b_rem */
+ /* may assume - x>=0,y>0 */
+word x,y;
+{ word n,q,ly,y1,scale;
+ if(bigcmp(x,y)<0){ b_rem=x; return(make(INT,0,0)); }
+ y1=msd(y);
+ if((scale=IBASE/(y1+1))>1) /* rescale if necessary */
+ x=stimes(x,scale),y=stimes(y,scale),y1=msd(y);
+ n=q=0;ly=len(y);
+ while(bigcmp(x,y=make(INT,0,y))>=0)n++;
+ y=rest(y); /* want largest y not exceeding x */
+ ly += n;
+ for(;;)
+ { word d,lx=len(x);
+ if(lx<ly)d=0; else
+ if(lx==ly)
+ if(bigcmp(x,y)>=0)x=bigsub(x,y),d=1;
+ else d=0;
+ else{ d=ms2d(x)/y1;
+ if(d>MAXDIGIT)d=MAXDIGIT;
+ if((d -= 2)>0)x=bigsub(x,stimes(y,d));
+ else d=0;
+ if(bigcmp(x,y)>=0)
+ { x=bigsub(x,y),d++;
+ if(bigcmp(x,y)>=0)
+ x=bigsub(x,y),d++; }
+ }
+ q = make(INT,d,q);
+ if(n-- ==0)
+ { b_rem = scale==1?x:shortdiv(x,scale); return(q); }
+ ly-- ; y = rest(y); }
+} /* see Bird & Wadler p82 for explanation */
+
+word len(x) /* no of digits in big x */
+word x;
+{ word n=1;
+ while(x=rest(x))n++;
+ return(n);
+}
+
+word msd(x) /* most significant digit of big x */
+word x;
+{ while(rest(x))x=rest(x);
+ return(digit(x)); /* sign? */
+}
+
+word ms2d(x) /* most significant 2 digits of big x (len>=2) */
+word x;
+{ word d=digit(x);
+ x=rest(x);
+ while(rest(x))d=digit(x),x=rest(x);
+ return(digit(x)*IBASE+d);
+}
+
+word bigpow(x,y) /* assumes y poz */
+word x,y;
+{ word d,r=make(INT,1,0);
+ while(rest(y)) /* this loop has been unwrapped once, see below */
+ { word i=DIGITWIDTH;
+ d=digit(y);
+ while(i--)
+ { if(d&1)r=bigtimes(r,x);
+ x = bigtimes(x,x);
+ d >>= 1; }
+ y=rest(y);
+ }
+ d=digit(y);
+ if(d&1)r=bigtimes(r,x);
+ while(d>>=1)
+ { x = bigtimes(x,x);
+ if(d&1)r=bigtimes(r,x); }
+ return(r);
+}
+
+double bigtodbl(x)
+word x;
+{ word s=neg(x);
+ double b=1.0, r=(double)digit0(x);
+ x = rest(x);
+ while(x)b=b*IBASE,r=r+b*digit(x),x=rest(x);
+ if(s)return(-r);
+ return(r);
+} /* small end first */
+/* note: can return oo, -oo
+ but is used without surrounding sto_/set)dbl() only in compare() */
+
+/* not currently used
+long double bigtoldbl(x)
+word x;
+{ int s=neg(x);
+ long double b=1.0L, r=digit0(x);
+ x = rest(x);
+ while(x)b=b*IBASE,r=r+b*digit(x),x=rest(x);
+/*printf("bigtoldbl returns %Le\n",s?-r:r); /* DEBUG
+ if(s)return(-r);
+ return(r);
+} /* not compatible with std=c90, lib fns eg sqrtl broken */
+
+word dbltobig(x) /* entier */
+double x;
+{ word s= (x<0);
+ word r=make(INT,0,0);
+ word *p = &r;
+ double y= floor(x);
+/*if(fabs(y-x+1.0)<1e-9)y += 1.0; /* trick due to Peter Bartke, see note */
+ for(y=fabs(y);;)
+ { double n = fmod(y,(double)IBASE);
+ digit(*p) = (word)n;
+ y = (y-n)/(double)IBASE;
+ if(y>0.0)rest(*p)=make(INT,0,0),p=&rest(*p);
+ else break;
+ }
+ if(s)digit(r)=SIGNBIT|digit(r);
+ return(r);
+}
+/* produces junk in low order digits if x exceeds range in which integer
+ can be held without error as a double -- NO, see next comment */
+/* hugs, ghci, mira produce same integer for floor/entier hugenum, has 2^971
+ as factor so the low order bits are NOT JUNK -- 9.1.12 */
+
+/* note on suppressed fix:
+ choice of 1e9 arbitrary, chosen to prevent eg entier(100*0.29) = 28
+ but has undesirable effects, causing eg entier 1.9999999999 = 2
+ underlying problem is that computable floor on true Reals is _|_ at
+ the exact integers. There are inherent deficiences in 64 bit fp,
+ no point in trying to mask this */
+
+double biglog(x) /* logarithm of big x */
+word x;
+{ word n=0;
+ double r=digit(x);
+ if(neg(x)||bigzero(x))errno=EDOM,math_error("log");
+ while(x=rest(x))n++,r=digit(x)+r/IBASE;
+ return(log(r)+n*logIBASE);
+}
+
+double biglog10(x) /* logarithm of big x */
+word x;
+{ word n=0;
+ double r=digit(x);
+ if(neg(x)||bigzero(x))errno=EDOM,math_error("log10");
+ while(x=rest(x))n++,r=digit(x)+r/IBASE;
+ return(log10(r)+n*log10IBASE);
+}
+
+word bigscan(p) /* read a big number (in decimal) */
+ /* NB does NOT check for malformed number, assumes already done */
+char *p; /* p is a pointer to a null terminated string of digits */
+{ word s=0,r=make(INT,0,0);
+ if(*p=='-')s=1,p++; /* optional leading `-' (for NUMVAL) */
+ while(*p)
+ { word d= *p-'0',f=10;
+ p++;
+ while(*p&&f<PTEN)d=10*d+*p-'0',f=10*f,p++;
+ /* rest of loop does r=f*r+d; (in situ) */
+ d= f*digit(r)+d;
+ { word carry=d>>DIGITWIDTH;
+ word *x = &rest(r);
+ digit(r)=d&MAXDIGIT;
+ while(*x)
+ d=f*digit(*x)+carry,
+ digit(*x)=d&MAXDIGIT,
+ carry=d>>DIGITWIDTH,
+ x = &rest(*x);
+ if(carry)*x=make(INT,carry,0);
+ }}
+/*if(*p=='e')
+ { int s=bigscan(p+1);
+ r = bigtimes(r,bigpow(make(INT,10,0),s); } */
+ if(s&&!bigzero(r))digit(r)=digit(r)|SIGNBIT;
+ return(r);
+}
+/* code to handle (unsigned) exponent commented out */
+
+word bigxscan(p,q) /* read unsigned hex number in '\0'-terminated string p to q */
+ /* assumes redundant leading zeros removed */
+char *p, *q;
+{ word r; /* will hold result */
+ word *x = &r;
+ if(*p=='0'&&!p[1])return make(INT,0,0);
+ while(q>p)
+ { unsigned long long hold;
+ q = q-p<15 ? p : q-15; /* read upto 15 hex digits from small end */
+ sscanf(q,"%llx",&hold);
+ *q = '\0';
+ word count=4; /* 15 hex digits => 4 bignum digits */
+ while(count-- && !(hold==0 && q==p))
+ *x = make(INT,hold&MAXDIGIT,0),
+ hold >>= DIGITWIDTH,
+ x = &rest(*x);
+ }
+ return r;
+}
+
+word bigoscan(p,q) /* read unsigned octal number in '\0'-terminated string p to q */
+ /* assumes redundant leading zeros removed */
+char *p, *q;
+{ word r; /* will hold result */
+ word *x = &r;
+ while(q>p)
+ { unsigned word hold;
+ q = q-p<5 ? p : q-5; /* read (upto) 5 octal digits from small end */
+ sscanf(q,"%o",&hold);
+ *q = '\0';
+ *x = make(INT,hold,0),
+ x = &rest(*x);
+ }
+ return r;
+}
+
+word digitval(c)
+char c;
+{ return isdigit(c)?c-'0':
+ isupper(c)?10+c-'A':
+ 10+c-'a'; }
+
+word strtobig(z,base) /* numeral (as Miranda string) to big number */
+ /* does NOT check for malformed numeral, assumes
+ done and that z fully evaluated */
+word z; word base;
+{ word s=0,r=make(INT,0,0),PBASE=PTEN;
+ if(base==16)PBASE=PSIXTEEN; else
+ if(base==8)PBASE=PEIGHT;
+ if(z!=NIL&&hd[z]=='-')s=1,z=tl[z]; /* optional leading `-' (for NUMVAL) */
+ if(base!=10)z=tl[tl[z]]; /* remove "0x" or "0o" */
+ while(z!=NIL)
+ { word d=digitval(hd[z]),f=base;
+ z=tl[z];
+ while(z!=NIL&&f<PBASE)d=base*d+digitval(hd[z]),f=base*f,z=tl[z];
+ /* rest of loop does r=f*r+d; (in situ) */
+ d= f*digit(r)+d;
+ { word carry=d>>DIGITWIDTH;
+ word *x = &rest(r);
+ digit(r)=d&MAXDIGIT;
+ while(*x)
+ d=f*digit(*x)+carry,
+ digit(*x)=d&MAXDIGIT,
+ carry=d>>DIGITWIDTH,
+ x = &rest(*x);
+ if(carry)*x=make(INT,carry,0);
+ }}
+ if(s&&!bigzero(r))digit(r)=digit(r)|SIGNBIT;
+ return(r);
+}
+
+extern char *dicp;
+
+word bigtostr(x) /* number to decimal string (as Miranda list) */
+word x;
+{ word x1,sign,s=NIL;
+#ifdef DEBUG
+ extern word debug;
+ if(debug&04) /* print octally */
+ { word d=digit0(x);
+ sign=neg(x);
+ for(;;)
+ { word i=OCTW;
+ while(i--||d)s=cons('0'+(d&07),s),d >>= 3;
+ x=rest(x);
+ if(x)s=cons(' ',s),d=digit(x);
+ else return(sign?cons('-',s):s); }
+ }
+#endif
+ if(rest(x)==0)
+ { extern char *dicp;
+ sprintf(dicp,"%d",getsmallint(x));
+ return(str_conv(dicp)); }
+ sign=neg(x);
+ x1=make(INT,digit0(x),0); /* reverse x into x1 */
+ while(x=rest(x))x1=make(INT,digit(x),x1);
+ x=x1;
+ for(;;)
+ { /* in situ division of (reversed order) x by PTEN */
+ word d=digit(x),rem=d%PTEN;
+ d=d/PTEN; x1=rest(x);
+ if(d)digit(x)=d;
+ else x=x1; /* remove leading zero from result */
+ while(x1)
+ d=rem*IBASE+digit(x1),
+ digit(x1)=d/PTEN,
+ rem=d%PTEN,
+ x1=rest(x1);
+ /* end of in situ division (also uses x1 as temporary) */
+ if(x)
+ { word i=TENW;
+ while(i--)s=cons('0'+rem%10,s),rem=rem/10; }
+ else
+ { while(rem)s=cons('0'+rem%10,s),rem=rem/10;
+ return(sign?cons('-',s):s); }
+ }
+}
+
+word bigtostrx(x) /* integer to hexadecimal string (as Miranda list) */
+word x;
+{ word r=NIL, s=neg(x);
+ while(x)
+ { word count=4; /* 60 bits => 20 octal digits => 4 bignum digits */
+ unsigned long long factor=1;
+ unsigned long long hold=0;
+ while(count-- && x) /* calculate value of (upto) 4 bignum digits */
+ hold=hold+factor*digit0(x),
+ /* printf("::%llx\n",hold), /* DEBUG */
+ factor<<=15,
+ x=rest(x);
+ sprintf(dicp,"%.15llx",hold); /* 15 hex digits = 60 bits */
+ /* printf(":::%s\n",dicp); /* DEBUG */
+ char *q=dicp+15;
+ while(--q>=dicp)r = cons(*q,r);
+ }
+ while(digit(r)=='0'&&rest(r)!=NIL)r=rest(r); /* remove redundant leading 0's */
+ r = cons('0',cons('x',r));
+ if(s)r = cons('-',r);
+ return(r);
+}
+
+word bigtostr8(x) /* integer to octal string (as Miranda list) */
+word x;
+{ word r=NIL, s=neg(x);
+ while(x)
+ { char *q = dicp+5;
+ sprintf(dicp,"%.5o",digit0(x));
+ while(--q>=dicp)r = cons(*q,r);
+ x = rest(x); }
+ while(digit(r)=='0'&&rest(r)!=NIL)r=rest(r); /* remove redundant leading 0's */
+ r = cons('0',cons('o',r));
+ if(s)r = cons('-',r);
+ return(r);
+}
+
+#ifdef DEBUG
+wff(x) /* check for well-formation of integer */
+word x;
+{ word y=x;
+ if(tag[x]!=INT)printf("BAD TAG %d\n",tag[x]);
+ if(neg(x)&&!digit0(x)&&!rest(x))printf("NEGATIVE ZERO!\n");
+ if(digit0(x)&(~MAXDIGIT))printf("OVERSIZED DIGIT!\n");
+ while(x=rest(x))
+ if(tag[x]!=INT)printf("BAD INTERNAL TAG %d\n",tag[x]); else
+ if(digit(x)&(~MAXDIGIT))
+ printf("OVERSIZED DIGIT!\n"); else
+ if(!digit(x)&&!rest(x))
+ printf("TRAILING ZERO!\n");
+ return(y);
+}
+
+normalise(x) /* remove trailing zeros */
+word x;
+{ if(rest(x))rest(x)=norm1(rest(x));
+ return(wff(x));
+}
+
+norm1(x)
+word x;
+{ if(rest(x))rest(x)=norm1(rest(x));
+ return(!digit(x)&&!rest(x)?0:x);
+}
+
+#endif
+
+/* stall(s)
+char *s;
+{ fprintf(stderr,"big integer %s not yet implemented\n",s);
+ exit(0);
+}
+
+#define destrev(x,y,z) while(x)z=x,x=rest(x),rest(z)=y,y=z;
+/* destructively reverse x into y using z as temp */
+
+/* END OF MIRANDA INTEGER PACKAGE */
+
diff --git a/new/data.c b/new/data.c
new file mode 100644
index 0000000..c7463ac
--- /dev/null
+++ b/new/data.c
@@ -0,0 +1,1250 @@
+/* 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 */
+
diff --git a/new/lex.c b/new/lex.c
new file mode 100644
index 0000000..a4e9d09
--- /dev/null
+++ b/new/lex.c
@@ -0,0 +1,1213 @@
+/* MIRANDA LEX ANALYSER */
+
+/**************************************************************************
+ * 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 "lex.h"
+#include <errno.h>
+
+extern word DICSPACE; /* see steer.c for default value */
+/* capacity in chars of dictionary space for storing identifiers and file names
+ to get a larger name space just increase this number */
+extern FILE *s_in;
+extern word echoing,listing,verbosity,magic,inbnf,inlex;
+word fileq=NIL; /* list of currently open-for-input files, of form
+ cons(strcons(stream,<ptr to element of 'files'>),...)*/
+word insertdepth= -1,margstack=NIL,col=0,lmargin=0;
+word echostack=NIL;
+word lverge=0,vergstack=NIL;
+char *prefixbase; /* stores prefixes for pathnames, to get static resolution */
+word prefixlimit=1024; /* initial size of space for prefixes */
+word prefix,prefixstack=NIL; /* current prefix, stack of old prefixes */
+word atnl=1,line_no=0;
+word lastline;
+word litstack=NIL,linostack=NIL;
+word c=' ', lastc;
+word commandmode;
+word common_stdin,common_stdinb,cook_stdin;
+word litmain=0,literate=0; /* flags "literate" comment convention */
+char *dic,*dicp,*dicq;
+char *pathname();
+
+setupdic()
+{ dicp=dicq=dic=malloc(DICSPACE);
+ if(dic==NULL)mallocfail("dictionary");
+ /* it is not permissible to realloc dic, because at the moment identifiers
+ etc. contain absolute pointers into the dictionary space - so we must
+ choose fairly large initial value for DICSPACE. Fix this later */
+ prefixbase=malloc(prefixlimit);
+ prefixbase[0]='\0';
+ prefix=0;
+}
+
+/* this allows ~login convention in filenames */
+/* #define okgetpwnam
+/* suppress 26.5.06 getpwnam cases runtime error when statically linked (Linux) */
+
+#ifdef okgetpwnam
+#include <pwd.h>
+struct passwd *getpwnam();
+#endif
+char *getenv();
+
+char *gethome(n) /* for expanding leading `~' in tokens and pathnames */
+char *n;
+{ struct passwd *pw;
+ if(n[0]=='\0')return(getenv("HOME"));
+#ifdef okgetpwnam
+ if(pw=getpwnam(n))return(pw->pw_dir);
+#endif
+ return(NULL);
+}
+
+#define ovflocheck if(dicq-dic>DICSPACE)dicovflo()
+
+dicovflo() /* is this called everywhere it should be? Check later */
+{ fprintf(stderr,"\npanic: dictionary overflow\n"); exit(1); }
+
+char *token() /* lex analyser for command language (very simple) */
+{ extern char *current_script;
+ word ch=getchar();
+ dicq = dicp; /* uses top of dictionary as temporary work space */
+ while(ch==' '||ch=='\t')ch=getchar();
+ if(ch=='~')
+ { char *h;
+ *dicq++ = ch;
+ ch=getchar();
+ while(isalnum(ch)||ch=='-'||ch=='_'||ch=='.')
+ *dicq++ = ch,ch=getchar();
+ /* NB csh does not allow `.' in user ids when expanding `~'
+ but this may be a mistake */
+ *dicq='\0';
+ if(h=gethome(dicp+1))
+ (void)strcpy(dicp,h),dicq=dicp+strlen(dicp);
+ }
+#ifdef SPACEINFILENAMES
+ if(ch!='"'&&ch!='<') /* test added 9.5.06 see else part */
+#endif
+ while(!isspace(ch)&&ch!=EOF)
+ { *dicq++ = ch;
+ if(ch=='%')
+ if(dicq[-2]=='\\')(--dicq)[-1]='%';
+ else dicq--,(void)strcpy(dicq,current_script),dicq+=strlen(dicq);
+ ch=getchar(); }
+#ifdef SPACEINFILENAMES
+ else { word closeq= ch=='<'?'>':'"'; /* this branch added 9.5.06 */
+ *dicq++ = ch; /* to allow spaces in "tok" or <tok> */
+ ch=getchar();
+ while(ch!=closeq&&ch!='\n'&&ch!=EOF)
+ *dicq++ = ch, ch=getchar();
+ if(ch==closeq)*dicq++ = ch, ch=getchar(); }
+#endif
+ *dicq++ = '\0';
+ ovflocheck;
+ while(ch==' '||ch=='\t')ch=getchar();
+ ungetc(ch,stdin);
+ return(*dicp=='\0'?(char *)NULL:dicp);
+} /* NB - if no token returns NULL rather than pointer to empty string */
+
+char *addextn(b,s) /* if(b)force s to end in ".m", and resolve <quotes> */
+word b;
+char *s;
+{ extern char *miralib;
+ extern char linebuf[];
+ word n=strlen(s);
+ /* printf("addextn(%s)\n",s); /* DEBUG */
+ if(s[0]=='<'&&s[n-1]=='>')
+ { static miralen=0; /* code to handle quotes added 21/1/87 */
+ if(!miralen)miralen=strlen(miralib);
+ strcpy(linebuf,miralib);
+ linebuf[miralen]= '/';
+ strcpy(linebuf+miralen+1,s+1);
+ strcpy(dicp,linebuf);
+ s=dicp;
+ n=n+miralen-1;
+ dicq=dicp+n+1;
+ dicq[-1] = '\0'; /* overwrites '>' */
+ ovflocheck; } else
+ if(s[0]=='\"'&&s[n-1]=='\"')
+ { /*strip quotes */
+ dicq=dicp; s++;
+ while(*s)*dicq++ = *s++;
+ dicq[-1]='\0'; /* overwrites '"' */
+ s=dicp; n=n-2;
+ }
+ if(!b||strcmp(s+n-2,".m")==0)return(s);
+ if(s==dicp)dicq--;/*if s in scratch area at top of dic, extend in situ*/
+ else { /* otherwise build new copy at top of dic */
+ dicq=dicp;
+ while(*s)*dicq++ = *s++;
+ *dicq = '\0'; }
+ if(strcmp(dicq-2,".x")==0)dicq -= 2; else
+ if(dicq[-1]=='.')dicq -= 1;
+ (void)strcpy(dicq,".m");
+ dicq += 3;
+ ovflocheck;
+ /* printf("return(%s)\n",dicp); /* DEBUG */
+ return(dicp);
+} /* NB - call keep(dicp) if the result is to be retained */
+
+word brct=0;
+
+spaces(n)
+word n;
+{ while(n-- >0)putchar(' ');
+}
+
+litname(s)
+char *s;
+{ word n=strlen(s);
+ return(n>=6 && strcmp(s+n-6,".lit.m")==0);
+}
+
+word getch() /* keeps track of current position in the variable "col"(column) */
+{ word ch= getc(s_in);
+ if(ch==EOF&&!atnl&&tl[fileq]==NIL) /* badly terminated top level file */
+ { atnl=1; return('\n'); }
+ if(atnl)
+ { if((line_no==0&&!commandmode||magic&&line_no==1)&&litstack==NIL)
+ litmain=literate= (ch=='>')||litname(get_fil(current_file));
+ if(literate)
+ { word i=0;
+ while(ch!=EOF&&ch!='>')
+ { ungetc(ch,s_in);
+ line_no++;
+ (void)fgets(dicp,250,s_in);
+ if(i==0&&line_no>1)chblank(dicp); i++;
+ if(echoing)spaces(lverge),fputs(dicp,stdout);
+ ch=getc(s_in); }
+ if((i>1||line_no==1&&i==1)&&ch!=EOF)chblank(dicp);
+ if(ch=='>')
+ { if(echoing)putchar(ch),spaces(lverge);ch=getc(s_in); }
+ } /* supports alternative `literate' comment convention */
+ atnl=0; col= lverge+literate;
+ if(!commandmode&&ch!=EOF)line_no++; }
+ if(echoing&&ch!=EOF)
+ { putchar(ch);
+ if(ch=='\n'&&!literate)
+ if(litmain)putchar('>'),spaces(lverge);
+ else spaces(lverge);
+ }
+ if(ch=='\t')col= ((col-lverge)/8 + 1)*8+lverge;
+ else col++;
+ if(ch=='\n')atnl= 1;
+ return(ch); }
+
+word blankerr=0;
+
+chblank(s)
+char *s;
+{ while(*s==' '||*s=='\t')s++;
+ if(*s=='\n')return;
+ syntax("formal text not delimited by blank line\n");
+ blankerr=1;
+ reset(); /* easiest way to recover is to pretend it was an interrupt */
+}
+
+/* getlitch gets a character from input like getch, but using C escaping
+ conventions if the char is backslash -- for use in reading character
+ and string constants */
+
+word rawch;
+/* it is often important to know, when certain characters are returned (e.g.
+ quotes and newlines) whether they were escaped or literal */
+
+word errch; /* for reporting unrecognised \escape */
+
+word getlitch()
+{ extern word UTF8;
+ word ch=c;
+ rawch = ch;
+ if(ch=='\n')return(ch); /* always an error */
+ if(UTF8&&ch>127)
+ { /* UTF-8 uses 2 or 3 bytes for unicode points to 0xffff */
+ word ch1=c=getch();
+ if((ch&0xe0)==0xc0) /* 2 bytes */
+ { if((ch1&0xc0)!=0x80)
+ return -5; /* not valid UTF8 */
+ c=getch();
+ return sto_char((ch&0x1f)<<6|ch1&0x3f); }
+ word ch2=c=getch();
+ if((ch&0xf0)==0xe0) /* 3 bytes */
+ { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80)
+ return -5; /* not valid UTF8 */
+ c=getch();
+ return sto_char((ch&0xf)<<12|(ch1&0x3f)<<6|ch2&0x3f); }
+ word ch3=c=getch();
+ if((ch&0xf8)==0xf0) /* 4 bytes, beyond basic multiligual plane */
+ { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80||(ch3&0xc0)!=0x80)
+ return -5; /* not valid UTF8 */
+ c=getch();
+ return((ch&7)<<18|(ch1&0x3f)<<12|(ch2&0x3f)<<6|ch3&0x3f); }
+ return(-5);
+ /* not UTF8 */
+ }
+ if(ch!='\\')
+ { c=getch(); return(ch); }
+ ch = getch();
+ c = getch();
+ switch(ch)
+ { case '\n': return(getlitch()); /* escaped nl was handled in 'getch()' */
+ case 'a': return('\a');
+ case 'b': return('\b');
+ case 'f': return('\f'); /* form feed */
+ case 'n': return('\n'); /* newline, == linefeed */
+ case 'r': return('\r'); /* carriage return */
+ case 't': return('\t');
+ case 'v': return('\v');
+ case 'X': /* omit for Haskell escape rules, see also lines marked H */
+ case 'x': if(isxdigit(c))
+ { word value, N=ch=='x'?4:6; /* N=7 for Haskell escape rules */
+ char hold[8];
+ ch = c;
+ word count=0;
+ /* while(ch=='0'&&isxdigit(peekch()))ch=getch(); /* H-lose leading 0s */
+ while(isxdigit(ch)&&count<N)
+ hold[count++]=ch,ch=getch();
+ /* read upto N hex digits */
+ hold[count] = '\0';
+ sscanf(hold,"%x",&value);
+ c = ch;
+ return value>UMAX?-3 /* \x out of range */
+ :sto_char(value); }
+ else return -2; /* \x with no hex digits */
+ default: if('0'<=ch&&ch<='9')
+ { word n=ch-'0',count=1,N=3; /* N=8 for Haskell escape rules */
+ ch = c;
+ /* while(ch=='0'&&isdigit(peekch()))ch=getch(); /* H-lose leading 0s */
+ while(isdigit(ch)&&count<N)
+ /* read upto N digits */
+ { n = 10*n+ch-'0';
+ count++;
+ ch = getch(); }
+ c = ch;
+ return /* n>UMAX?-4: /* H \decimal out of range */
+ sto_char(n); }
+ if(ch=='\''||ch=='"'||ch=='\\'||ch=='`')return(ch); /* see note */
+ if(ch=='&')return -7; /* Haskell null escape, accept silently */
+ errch=ch<=255?ch:'?';
+ return -6; /* unrecognised \something */
+ }
+} /* note: we accept \` for ` because getlitch() is used by charclass() */
+
+char *rdline() /* used by the "!" command -- see RULES */
+{ extern char *current_script;
+ static char linebuf[BUFSIZE];
+ char *p=linebuf;
+ word ch=getchar(),expansion=0;
+ while(ch==' '||ch=='\t')ch=getchar();
+ if(ch=='\n'||ch=='!'&&!(*linebuf))
+ { /* "!!" or "!" on its own means repeat last !command */
+ if(*linebuf)printf("!%s",linebuf);
+ while(ch!='\n'&&ch!=EOF)ch=getchar();
+ return(linebuf); }
+ if(ch=='!')
+ expansion=1,p=linebuf+strlen(linebuf)-1; /* p now points at old '\n' */
+ else ungetc(ch,stdin);
+ while((*p++ =ch=getchar())!='\n'&&ch!=EOF)
+ if(p-linebuf>=BUFSIZE)
+ { *p='\0';
+ fprintf(stderr,"sorry, !command too long (limit=%d chars): %s...\n",
+ BUFSIZE,linebuf);
+ while((ch=getchar())!='\n'&&ch!=EOF);
+ return(NULL);
+ } else
+ if(p[-1]=='%')
+ if(p>linebuf+1&&p[-2]=='\\')(--p)[-1]='%'; else
+ { (void)strncpy(p-1,current_script,linebuf+BUFSIZE-p);
+ p = linebuf+strlen(linebuf);
+ expansion = 1;
+ }
+ *p = '\0';
+ if(expansion)printf("!%s",linebuf);
+ return(linebuf); }
+
+setlmargin() /* this and the next routine are used to enforce the offside
+ rule ("yylex" refuses to read a symbol if col<lmargin) */
+{ margstack= cons(lmargin,margstack);
+ if(lmargin<col)lmargin= col; } /* inner scope region cannot "protrude" */
+
+unsetlmargin()
+{ if(margstack==NIL)return; /* in case called after `syntax("..")' */
+ lmargin= hd[margstack];
+ margstack= tl[margstack]; }
+
+word okid();
+word okulid();
+word PREL=1;
+
+#define isletter(c) ('a'<=c&&c<='z'||'A'<=c&&c<='Z')
+
+errclass(word val, word string)
+/* diagnose error in charclass, string or char const */
+{ char *s = string==2?"char class":string?"string":"char const";
+ if(val==-2)printf("\\x with no xdigits in %s\n",s); else
+ if(val==-3)printf("\\hexadecimal escape out of range in %s\n",s); else
+ if(val==-4)printf("\\decimal escape out of range in %s\n",s); else
+ if(val==-5)printf("unrecognised character in %s"
+ "(UTF8 error)\n",s); else
+ if(val==-6)printf("unrecognised escape \\%c in %s\n",errch,s); else
+ if(val==-7)printf("illegal use of \\& in char const\n"); else
+ printf("unknown error in %s\n",s);
+ acterror(); }
+
+yylex() /* called by YACC to get the next symbol */
+{ extern word SYNERR,exportfiles,inexplist,sreds;
+ /* SYNERR flags context sensitive syntax error detected in actions */
+ if(SYNERR)return(END); /* tell YACC to go home */
+ layout();
+ if(c=='\n') /* can only occur in command mode */
+/* if(magic){ commandmode=0; /* expression just read, now script */
+/* line_no=2;
+/* return(c); } else /* no longer relevant 26.11.2019 */
+ return(END);
+ if(col<lmargin)
+ if(c=='='&&(margstack==NIL||col>=hd[margstack]))/* && part fixes utah.bug*/
+ { c = getch();
+ return(ELSEQ); /* ELSEQ means "OFFSIDE =" */
+ }
+ else return(OFFSIDE);
+ if(c==';') /* fixes utah2.bug */
+ { c=getch(); layout();
+ if(c=='='&&(margstack==NIL||col>=hd[margstack]))
+ { c = getch();
+ return(ELSEQ); /* ELSEQ means "OFFSIDE =" */
+ }
+ else return(';');
+ }
+ if(
+ /* c=='_'&&okid(peekch()) || /* _id/_ID as lowercase id */
+ isletter(c)){ kollect(okid);
+ if(inlex==1){ layout();
+ yylval=name();
+ return(c=='='?LEXDEF:
+ isconstructor(yylval)?CNAME:
+ NAME); }
+ if(inbnf==1)
+ /* add trailing space to nonterminal to avoid clash
+ with ordinary names */
+ dicq[-1] = ' ',
+ *dicq++ = '\0';
+ return(identifier(0)); }
+ if('0'<=c&&c<='9'||c=='.'&&peekdig())
+ { if(c=='0'&&tolower(peekch())=='x')
+ hexnumeral(); else /* added 21.11.2013 */
+ if(c=='0'&&tolower(peekch())=='o')
+ getch(),c=getch(),octnumeral(); /* added 21.11.2013 */
+ else numeral();
+ return(CONST); }
+ if(c=='%'&&!commandmode)return(directive());
+ if(c=='\'')
+ { c = getch();
+ yylval= getlitch();
+ if(yylval<0){ errclass(yylval,0); return CONST; }
+ if(!is_char(yylval))
+ printf("%simpossible event while reading char const ('\\%u\')\n",
+ echoing?"\n":"",yylval),
+ acterror();
+ if(rawch=='\n'||c!='\'')syntax("improperly terminated char const\n");
+ else c= getch();
+ return(CONST); }
+ if(inexplist&&(c=='\"'||c=='<'))
+ { if(!pathname())syntax("badly formed pathname in %export list\n");
+ else exportfiles=strcons(addextn(1,dicp),exportfiles),
+ keep(dicp);
+ return(PATHNAME); }
+ if(inlex==1&&c=='`')
+ { return(charclass()?ANTICHARCLASS:CHARCLASS); }
+ if(c=='\"')
+ { string();
+ if(yylval==NIL)yylval=NILS; /* to help typechecker! */
+ return(CONST); }
+ if(inbnf==2) /* fiddle to offside rule in grammars */
+ if(c=='[')brct++; else if(c==']')brct--; else
+ if(c=='|'&&brct==0)
+ return(OFFSIDE);
+ if(c==EOF)
+ { if(tl[fileq]==NIL&&margstack!=NIL)return(OFFSIDE); /* to fix dtbug */
+ fclose((FILE *)hd[hd[fileq]]);
+ fileq= tl[fileq]; insertdepth--;
+ if(fileq!=NIL&&hd[echostack])
+ { if(literate)putchar('>'),spaces(lverge);
+ printf("<end of insert>"); }
+ s_in= fileq==NIL?stdin:(FILE *)hd[hd[fileq]];
+ c= ' ';
+ if(fileq==NIL)
+ { lverge=c=col=lmargin=0;
+ /* c=0; necessary because YACC sometimes reads 1 token past END */
+ atnl=1;
+ echoing=verbosity&listing;
+ lastline=line_no;
+ /* hack so errline can be set right if err at end of file */
+ line_no=0;
+ litmain=literate=0;
+ return(END); }
+ else { current_file = tl[hd[fileq]];
+ prefix=hd[prefixstack];
+ prefixstack=tl[prefixstack];
+ echoing=hd[echostack];
+ echostack=tl[echostack];
+ lverge=hd[vergstack];
+ vergstack=tl[vergstack];
+ literate=hd[litstack];
+ litstack=tl[litstack];
+ line_no=hd[linostack];
+ linostack=tl[linostack]; }
+ return(yylex()); }
+ lastc= c;
+ c= getch();
+#define try(x,y) if(c==x){ c=getch(); return(y); }
+ switch(lastc) {
+ case '_': if(c=='') /* underlined something */
+ { c=getch();
+ if(c=='<'){ c=getch(); return(LE); }
+ if(c=='>'){ c=getch(); return(GE); }
+ if(c=='%'&&!commandmode)return(directive());
+ if(isletter(c)) /* underlined reserved word */
+ { kollect(okulid);
+ if(dicp[1]=='_'&&dicp[2]=='')
+ return(identifier(1)); }
+ syntax("illegal use of underlining\n");
+ return('_'); }
+ return(lastc);
+ case '-': try('>',ARROW) try('-',MINUSMINUS) return(lastc);
+ case '<': try('-',LEFTARROW) try('=',LE) return(lastc);
+ case '=': if(c=='>'){ syntax("unexpected symbol =>\n"); return '='; }
+ try('=',EQEQ) return(lastc);
+ case '+': try('+',PLUSPLUS) return(lastc);
+ case '.': if(c=='.')
+ { c=getch();
+ return(DOTDOT);
+ }
+ return(lastc);
+ case '\\': try('/',VEL) return(lastc);
+ case '>': try('=',GE) return(lastc);
+ case '~': try('=',NE) return(lastc);
+ case '&': if(c=='>')
+ { c=getch();
+ if(c=='>')yylval=1;
+ else yylval=0,ungetc(c,s_in);
+ c=' ';
+ return(TO); }
+ return(lastc);
+ case '/': try('/',DIAG) return(lastc);
+ case '*': try('*',collectstars()) return(lastc);
+ case ':': if(c==':')
+ { c=getch();
+ if(c=='='){ c=getch(); return(COLON2EQ); }
+ else return(COLONCOLON);
+ }
+ return(lastc);
+ case '$': if(
+ /* c=='_'&&okid(peekch())|| /* _id/_ID as id */
+ isletter(c))
+ { word t;
+ kollect(okid);
+ t=identifier(0);
+ return(t==NAME?INFIXNAME:t==CNAME?INFIXCNAME:'$'); }
+ /* the last alternative is an error - caveat */
+ if('1'<=c&&c<='9')
+ { word n=0;
+ while(isdigit(c)&&n<1e6)n=10*n+c-'0',c=getch();
+ if(n>sreds)
+ /* sreds==0 everywhere except in semantic redn clause */
+ printf("%ssyntax error: illegal symbol $%d%s\n",
+ echoing?"\n":"",n,n>=1e6?"...":""),
+ acterror();
+ else { yylval=mkgvar(n); return(NAME); }
+ }
+ if(c=='-')
+ { if(!compiling)
+ syntax("unexpected symbol $-\n"); else
+ {c=getch(); yylval=common_stdin; return(CONST); }}
+ /* NB we disallow recursive use of $($/+/-) inside $+ data
+ whence addition of `compiling' to premises */
+ if(c==':')
+ { c=getch();
+ if(c!='-')syntax("unexpected symbol $:\n"); else
+ { if(!compiling)
+ syntax("unexpected symbol $:-\n"); else
+ {c=getch(); yylval=common_stdinb; return(CONST); }}} /* $:- */
+ if(c=='+')
+ { /* if(!(commandmode&&compiling||magic))
+ syntax("unexpected symbol $+\n"); else /* disallow in scripts */
+ if(!compiling)
+ syntax("unexpected symbol $+\n"); else
+ { c=getch();
+ if(commandmode)
+ yylval=cook_stdin;
+ else yylval=ap(readvals(0,0),OFFSIDE);
+ return(CONST); }}
+ if(c=='$')
+ { if(!(inlex==2||commandmode&&compiling))
+ syntax("unexpected symbol $$\n"); else
+ { c=getch();
+ if(inlex) { yylval=mklexvar(0); return(NAME); }
+ else return(DOLLAR2); }}
+ if(c=='#')
+ { if(inlex!=2)syntax("unexpected symbol $#\n"); else
+ { c=getch(); yylval=mklexvar(1); return(NAME); }}
+ if(c=='*')
+ { c=getch(); yylval=ap(GETARGS,0); return(CONST); }
+ if(c=='0')
+ syntax("illegal symbol $0\n");
+ default: return(lastc);
+}}
+
+layout()
+{L:while(c==' '||c=='\n'&&!commandmode||c=='\t') c= getch();
+ if(c==EOF&&commandmode){ c='\n'; return; }
+ if(c=='|'&&peekch()=='|' /* ||comments */
+ || col==1&&line_no==1 /* added 19.11.2013 */
+ &&c=='#'&&peekch()=='!') /* UNIX magic string */
+ { while((c=getch())!='\n'&&c!=EOF);
+ if(c==EOF&&!commandmode)return;
+ c= '\n';
+ goto L; }
+}
+
+collectstars()
+{ word n=2;
+ while(c=='*')c=getch(),n++;
+ yylval= mktvar(n);
+ return(TYPEVAR);
+}
+
+word gvars=NIL; /* list of grammar variables - no need to reset */
+
+mkgvar(i) /* make bound variable (corresponding to $i in bnf rule) */
+word i;
+{ word *p= &gvars;
+ while(--i)
+ { if(*p==NIL)*p=cons(sto_id("gvar"),NIL);
+ p= &tl[*p]; }
+ if(*p==NIL)*p=cons(sto_id("gvar"),NIL);
+ return(hd[*p]);
+} /* all these variables have the same name, and are not in hashbucket */
+
+word lexvar=0;
+
+mklexvar(i) /* similar - corresponds to $$, $# on rhs of %lex rule */
+word i; /* i=0 or 1 */
+{ extern word ltchar;
+ if(!lexvar)
+ lexvar=cons(sto_id("lexvar"),sto_id("lexvar")),
+ id_type(hd[lexvar])=ltchar,
+ id_type(tl[lexvar])=genlstat_t();
+ return(i?tl[lexvar]:hd[lexvar]);
+}
+
+word ARGC;
+char **ARGV; /* initialised in main(), see steer.c */
+
+conv_args() /* used to give access to command line args
+ see case GETARGS in reduce.c */
+{ word i=ARGC,x=NIL;
+ if(i==0)return(NIL); /* possible only if not invoked from a magic script */
+ { while(--i)x=cons(str_conv(ARGV[i]),x);
+ x=cons(str_conv(ARGV[0]),x); }
+ return(x);
+}
+
+str_conv(s) /* convert C string to Miranda form */
+char *s;
+{ word x=NIL,i=strlen(s);
+ while(i--)x=cons(s[i],x);
+ return(x);
+} /* opposite of getstring() - see reduce.c */
+
+okpath(ch)
+word ch;
+{ return(ch!='\"'&&ch!='\n'&&ch!='>'); }
+
+char *pathname() /* returns NULL if not valid pathname (in string quotes) */
+{ layout();
+ if(c=='<') /* alternative quotes <..> for system libraries */
+ { extern char *miralib;
+ char *hold=dicp;
+ c=getch();
+ (void)strcpy(dicp,miralib);
+ dicp+=strlen(miralib);
+ *dicp++ = '/';
+ kollect(okpath);
+ dicp=hold;
+ if(c!='>')return(NULL);
+ c=' ';
+ return(dicp); }
+ if(c!='\"')return(NULL);
+ c=getch();
+ if(c=='~')
+ { char *h,*hold=dicp;
+ extern char linebuf[];
+ *dicp++ = c;
+ c=getch();
+ while(isalnum(c)||c=='-'||c=='_'||c=='.')
+ *dicp++ = c, c=getch();
+ *dicp='\0';
+ if(h=gethome(hold+1))
+ (void)strcpy(hold,h),dicp=hold+strlen(hold);
+ else (void)strcpy(&linebuf[0],hold),
+ (void)strcpy(hold,prefixbase+prefix),
+ dicp=hold+strlen(prefixbase+prefix),
+ (void)strcpy(dicp,&linebuf[0]),
+ dicp+=strlen(dicp);
+ kollect(okpath);
+ dicp=hold;
+ } else
+ if(c=='/') /* absolute pathname */
+ kollect(okpath);
+ else { /* relative pathname */
+ char *hold=dicp;
+ (void)strcpy(dicp,prefixbase+prefix);
+ dicp+=strlen(prefixbase+prefix);
+ kollect(okpath);
+ dicp=hold; }
+ if(c!='\"')return(NULL);
+ c = ' ';
+ return(dicp);
+} /* result is volatile - call keep(dicp) to retain */
+
+adjust_prefix(f) /* called at %insert and at loadfile, to get static pathname
+ resolution */
+char *f;
+{ /* the directory part of the pathname f becomes the new
+ prefix for pathnames, and we stack the current prefix */
+ char *g;
+ prefixstack=strcons(prefix,prefixstack);
+ prefix += strlen(prefixbase+prefix)+1;
+ while(prefix+strlen(f)>=prefixlimit) /* check and fix overflow */
+ prefixlimit += 1024, prefixbase=realloc(prefixbase,prefixlimit);
+ (void)strcpy(prefixbase+prefix,f);
+ g=rindex(prefixbase+prefix,'/');
+ if(g)g[1]='\0';
+ else prefixbase[prefix]='\0';
+}
+
+/* NOTES on how static pathname resolution is achieved:
+(the specification is that pathnames must always be resolved relative to the
+file in which they are encountered)
+Definition -- the 'prefix' of a pathname is the initial segment up to but not
+including the last occurrence of '/' (null if no '/' present).
+Keep the wd constant during compilation. Have a global char* prefix, initially
+null.
+1) Whenever you read a relative pathname(), insert 'prefix' on the front of it.
+2) On entering a new level of insert, stack old prefix and prefix becomes that
+ of new file name. Done by calling adjust_prefix().
+3) On quitting a level of insert, unstack old prefix.
+*/
+
+peekdig()
+{ word ch = getc(s_in);
+ ungetc(ch,s_in);
+ return('0'<=ch&&ch<='9');
+}
+
+peekch()
+{ word ch = getc(s_in);
+ ungetc(ch,s_in);
+ return(ch);
+}
+
+openfile(n) /* returns 0 or 1 as indication of success - puts file on fileq
+ if successful */
+char *n;
+{ FILE *f;
+ f= fopen(n,"r");
+ if(f==NULL)return(0);
+ fileq= cons(strcons(f,NIL),fileq);
+ insertdepth++;
+ return(1);
+}
+
+identifier(s) /* recognises reserved words */
+word s; /* flags looking for ul reserved words only */
+{ extern word lastid,initialising;
+ if(inbnf==1)
+ { /* only reserved nonterminals are `empty', `end', `error', `where' */
+ if(is("empty ")||is("e_m_p_t_y"))return(EMPTYSY); else
+ if(is("end ")||is("e_n_d"))return(ENDSY); else
+ if(is("error ")||is("e_r_r_o_r"))return(ERRORSY); else
+ if(is("where ")||is("w_h_e_r_e"))return(WHERE); }
+ else
+ switch(dicp[0])
+ { case 'a': if(is("abstype")||is("a_b_s_t_y_p_e"))
+ return(ABSTYPE);
+ break;
+ case 'd': if(is("div")||is("d_i_v"))
+ return(DIV);
+ break;
+ case 'F': if(is("False")) /* True, False alleged to be predefined, not
+ reserved (??) */
+ { yylval = False;
+ return(CONST); }
+ break;
+ case 'i': if(is("if")||is("i_f"))
+ return(IF);
+ break;
+ case 'm': if(is("mod")||is("m_o_d"))
+ return(REM);
+ break;
+ case 'o': if(is("otherwise")||is("o_t_h_e_r_w_i_s_e"))
+ return(OTHERWISE);
+ break;
+ case 'r': if(is("readvals")||is("r_e_a_d_v_a_l_s"))
+ return(READVALSY);
+ break;
+ case 's': if(is("show")||is("s_h_o_w"))
+ return(SHOWSYM);
+ break;
+ case 'T': if(is("True"))
+ { yylval = True;
+ return(CONST); }
+ case 't': if(is("type")||is("t_y_p_e"))
+ return(TYPE);
+ break;
+ case 'w': if(is("where")||is("w_h_e_r_e"))
+ return(WHERE);
+ if(is("with")||is("w_i_t_h"))
+ return(WITH);
+ break;
+ }
+ if(s){ syntax("illegal use of underlining\n"); return('_'); }
+ yylval=name(); /* not a reserved word */
+ if(commandmode&&lastid==0&&id_type(yylval)!=undef_t)lastid=yylval;
+ return(isconstructor(yylval)?CNAME:NAME);
+}
+
+word disgusting=0; /* flag to turn off typecheck, temporary hack for jrc */
+
+directive() /* these are of the form "%identifier" */
+{ extern word SYNERR,magic;
+ word holdcol=col-1,holdlin=line_no;
+ c = getch();
+ if(c=='%'){ c=getch(); return(ENDIR); }
+ kollect(okulid);
+ switch(dicp[0]=='_'&&dicp[1]==''?dicp[2]:dicp[0])
+ { case 'b': if(is("begin")||is("_^Hb_^He_^Hg_^Hi_^Hn"))
+ if(inlex)
+ return(LBEGIN);
+ if(is("bnf")||is("_^Hb_^Hn_^Hf"))
+ { setlmargin(); col=holdcol+4;
+ /* `indent' to right hand end of directive */
+ return(BNF); }
+ break;
+ case 'e': if(is("export")||is("_e_x_p_o_r_t"))
+ { if(magic)syntax(
+ "%export directive not permitted in \"-exp\" script\n");
+ return(EXPORT); }
+ break;
+ case 'f': if(is("free")||is("_f_r_e_e"))
+ { if(magic)syntax(
+ "%free directive not permitted in \"-exp\" script\n");
+ return(FREE); }
+ break;
+ case 'i': if(is("include")||is("_i_n_c_l_u_d_e"))
+ { if(!SYNERR){ layout(); setlmargin(); }
+ /* does `indent' for grammar */
+ if(!pathname())
+ syntax("bad pathname after %include\n");
+ else yylval=strcons(addextn(1,dicp),
+ fileinfo(get_fil(current_file),holdlin)),
+ /* (includee,hereinfo) */
+ keep(dicp);
+ return(INCLUDE); }
+ if(is("insert")||is("_i_n_s_e_r_t"))
+ { char *f=pathname();
+ if(!f)syntax("bad pathname after %insert\n"); else
+ if(insertdepth<12&&openfile(f))
+ { adjust_prefix(f);
+ vergstack=cons(lverge,vergstack);
+ echostack=cons(echoing,echostack);
+ litstack=cons(literate,litstack);
+ linostack=strcons(line_no,linostack);
+ line_no=0; atnl=1; /* was line_no=1; */
+ keep(dicp);
+ current_file = make_fil(f,fm_time(f),0,NIL);
+ files = append1(files,cons(current_file,NIL));
+ tl[hd[fileq]] = current_file;
+ s_in = (FILE *)hd[hd[fileq]];
+ literate= peekch()=='>'||litname(f);
+ col=lverge=holdcol;
+ if(echoing)
+ { putchar('\n');
+ if(!literate)
+ if(litmain)putchar('>'),spaces(holdcol);
+ else spaces(holdcol); }
+ c = getch(); } /* used to precede previous cmd when echo
+ was delayed by one char, see getch() */
+ else { word toomany=(insertdepth>=12);
+ printf("%s%%insert error - cannot open \"%s\"\n",
+ echoing?"\n":"",f);
+ keep(dicp);
+ if(toomany)printf(
+ "too many nested %%insert directives (limit=%d)\n",
+ insertdepth);
+ else
+ files = append1(files,cons(make_fil(f,0,0,NIL),NIL));
+ /* line above for benefit of `oldfiles' */
+ acterror(); }
+ return(yylex()); }
+ break;
+ case 'l': if(is("lex")||is("_^Hl_^He_^Hx"))
+ { if(inlex)syntax("nested %lex not permitted\n");
+ /* due to use of global vars inlex, lexdefs */
+ return(LEX); }
+ if(is("list")||is("_l_i_s_t"))
+ { echoing=verbosity; return(yylex()); }
+ break;
+ case 'n': if(is("nolist")||is("_n_o_l_i_s_t"))
+ { echoing=0; return(yylex()); }
+ break;
+ }
+ if(echoing)putchar('\n');
+ printf("syntax error: unknown directive \"%%%s\"\n",dicp),
+ acterror();
+ return(END);
+}
+
+okid(ch)
+word ch;
+{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9'
+ ||ch=='_'||ch=='\''); }
+
+okulid(ch)
+word ch;
+{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9'
+ ||ch=='_'||ch==''||ch=='\''); }
+
+kollect(f)
+/* note top of dictionary used as work space to collect current token */
+word (*f)();
+{ dicq= dicp;
+ while((*f)(c)){ *dicq++ = c; c= getch(); }
+ *dicq++ = '\0';
+ ovflocheck;
+}
+
+char *keep(p) /* call this to retain volatile string for later use */
+char *p;
+{ if(p==dicp)dicp= dicq;
+ else (void)strcpy(dicp,p),
+ p=dicp,
+ dicp=dicq=dicp+strlen(dicp)+1,
+ dic_check();
+ return(p);
+}
+
+dic_check() /* called from REDUCE */
+{ ovflocheck; }
+
+numeral()
+{ word nflag=1;
+ dicq= dicp;
+ while(isdigit(c))
+ *dicq++ = c, c=getch();
+ if(c=='.'&&peekdig())
+ { *dicq++ = c, c=getch(); nflag=0;
+ while(isdigit(c))
+ *dicq++ = c, c=getch(); }
+ if(c=='e')
+ { word np=0;
+ *dicq++ = c, c=getch(); nflag=0;
+ if(c=='+')c=getch(); else /* ignore + before exponent */
+ if(c=='-')*dicq++ = c, c=getch();
+ if(!isdigit(c)) /* e must be followed by some digits */
+ syntax("badly formed floating point number\n");
+ while(c=='0')
+ *dicq++ = c, c=getch();
+ while(isdigit(c))
+ np++, *dicq++ = c, c=getch();
+ if(!nflag&&np>3) /* scanf falls over with silly exponents */
+ { syntax("floating point number out of range\n");
+ return; }
+ }
+ ovflocheck;
+ if(nflag) /* `.' or `e' makes fractional */
+ *dicq = '\0',
+ yylval= bigscan(dicp); else
+ { double r=0.0;
+ if(dicq-dicp>60) /* this allows 59 chars */
+ /* scanf crashes, on VAX, gives wrong answers, on ORION 1/05 */
+ { syntax("illegal floating point constant (too many digits)\n");
+ return; }
+ errno=0;
+ *dicq = '\n';
+ sscanf(dicp,"%lf",&r);
+ if(errno)fpe_error(); else
+ yylval= sto_dbl((double)r); }
+}
+
+hexnumeral() /* added 21.11.2013 */
+{ extern word errno;
+ word nflag=1;
+ dicq= dicp;
+ *dicq++ = c, c=getch(); /* 0 */
+ *dicq++ = c, c=getch(); /* x */
+ if(!isxdigit(c)&&c!='.')syntax("malformed hex number\n");
+ while(c=='0'&&isxdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */
+ while(isxdigit(c))
+ *dicq++ = c, c=getch();
+ ovflocheck;
+ if(c=='.'||tolower(c)=='p') /* hex float, added 20.11.19 */
+ { double d;
+ if(c=='.')
+ { *dicq++ = c, c=getch();
+ while(isxdigit(c))
+ *dicq++ = c, c=getch(); }
+ if(c=='p')
+ { *dicq++ = c, c=getch();
+ if(c=='+'||c=='-')*dicq++ = c, c=getch();
+ if(!isdigit(c))syntax("malformed hex float\n");
+ while(isdigit(c))
+ *dicq++ = c, c=getch(); }
+ ovflocheck;
+ *dicq='\0';
+ if(dicq-dicp>60||sscanf(dicp,"%lf",&d)!=1)
+ syntax("malformed hex float\n");
+ else yylval= sto_dbl(d);
+ return; }
+ *dicq = '\0';
+ yylval= bigxscan(dicp+2,dicq);
+}
+
+octnumeral() /* added 21.11.2013 */
+{ extern word errno;
+ word nflag=1;
+ dicq= dicp;
+ if(!isdigit(c))syntax("malformed octal number\n");
+ while(c=='0'&&isdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */
+ while(isdigit(c)&&c<='7')
+ *dicq++ = c, c=getch();
+ if(isdigit(c))syntax("illegal digit in octal number\n");
+ ovflocheck;
+ *dicq = '\0';
+ yylval= bigoscan(dicp,dicq);
+}
+
+word namebucket[128]; /* each namebucket has a list terminated by 0, not NIL */
+
+hash(s) /* returns a value in {0..127} */
+char *s;
+{ word h = *s;
+ if(h)while(*++s)h ^= *s; /* guard necessary to deal with s empty */
+ return(h&127);
+}
+
+isconstrname(s)
+char *s;
+{ if(s[0]=='$')s++;
+ return isupper(*s); /* formerly !islower */
+}
+
+getfname(x)
+/* nonterminals have an added ' ', getfname returns the corresponding
+ function name */
+word x;
+{ char *p = get_id(x);
+ dicq= dicp;
+ while(*dicq++ = *p++);
+ if(dicq-dicp<3)fprintf(stderr,"impossible event in getfname\n"),exit(1);
+ dicq[-2] = '\0'; /* overwrite last char */
+ ovflocheck;
+ return(name());
+}
+
+isnonterminal(x)
+word x;
+{ char *n;
+ if(tag[x]!=ID)return(0);
+ n = get_id(x);
+ return(n[strlen(n)-1]==' ');
+}
+
+name()
+{ word q,h;
+ q= namebucket[h=hash(dicp)];
+ while(q&&!is(get_id(hd[q])))q= tl[q];
+ if(q==0)
+ { q = sto_id(dicp);
+ namebucket[h] = cons(q,namebucket[h]);
+ keep(dicp); }
+ else q= hd[q];
+ return(q); }
+/* note - keeping buckets sorted didn't seem to help (if anything slightly
+ slower) probably because ordering only relevant if name not present, and
+ outweighed by increased complexity of loop */
+
+static word inprelude=1;
+
+make_id(n) /* used in mira_setup(), primdef(), predef(), all in steer.c */
+char *n;
+{ word x,h;
+ h=hash(n);
+ x = sto_id(inprelude?keep(n):n);
+ namebucket[h] = cons(x,namebucket[h]);
+ return(x); }
+
+findid(n) /* like name() but returns NIL rather than create new id */
+char *n;
+{ word q;
+ q= namebucket[hash(n)];
+ while(q&&!strcmp(n,get_id(hd[q]))==0)q= tl[q];
+ return(q?hd[q]:NIL); }
+
+word *pnvec=0,nextpn,pn_lim=200; /* private name vector */
+
+reset_pns() /* (re)initialise private name space */
+{ nextpn=0;
+ if(!pnvec)
+ { pnvec=(word *)malloc(pn_lim*sizeof(word));
+ if(pnvec==NULL)mallocfail("pnvec"); }
+}
+
+make_pn(val) /* create new private name with value val */
+word val;
+{ if(nextpn==pn_lim)
+ { pn_lim+=400;
+ pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word));
+ if(pnvec==NULL)mallocfail("pnvec"); }
+ pnvec[nextpn]=strcons(nextpn,val);
+ return(pnvec[nextpn++]);
+}
+
+sto_pn(n) /* return n'th private name, extending pnvec if necessary */
+word n;
+{ if(n>=pn_lim)
+ { while(pn_lim<=n)pn_lim+=400;
+ pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word));
+ if(pnvec==NULL)mallocfail("pnvec"); }
+ while(nextpn<=n) /* NB allocates all missing names upto and including nth*/
+ pnvec[nextpn]=strcons(nextpn,UNDEF),nextpn++;
+ return(pnvec[n]);
+}
+
+mkprivate(x) /* disguise identifiers prior to removal from environment */
+word x; /* used in setting up prelude - see main() in steer.c */
+{ while(x!=NIL)
+ { char *s = get_id(hd[x]);
+ get_id(hd[x])[0] += 128; /* hack to make private internal name */
+ x = tl[x]; } /* NB - doesn't change hashbucket */
+ inprelude=0;
+}
+
+word sl=100;
+
+string()
+{ word p;
+ word ch,badch=0;
+ c = getch();
+ ch= getlitch();
+ p= yylval= cons(NIL,NIL);
+ while(ch!=EOF&&rawch!='\"'&&rawch!='\n')
+ if(ch==-7) ch=getlitch(); else /* skip \& */
+ if(ch<0){ badch=ch; break; }
+ else { p= tl[p]= cons(ch,NIL);
+ ch= getlitch(); }
+ yylval= tl[yylval];
+ if(badch)errclass(badch,1);
+ if(rawch=='\n')
+ syntax("non-escaped newline encountered inside string quotes\n"); else
+ if(ch==EOF)
+ { if(echoing)putchar('\n');
+ printf("syntax error: script ends inside unclosed string quotes - \n");
+ printf(" \"");
+ while(yylval!=NIL&& sl-- )
+ { putchar(hd[yylval]);
+ yylval= tl[yylval]; }
+ printf("...\"\n");
+ acterror(); }
+}
+
+charclass()
+{ word p;
+ word ch,badch=0,anti=0;
+ c = getch();
+ if(c=='^')anti=1,c=getch();
+ ch= getlitch();
+ p= yylval= cons(NIL,NIL);
+ while(ch!=EOF&&rawch!='`'&&rawch!='\n')
+ if(ch==-7)ch=getlitch(); else /* skip \& */
+ if(ch<0){ badch=ch; break; }
+ else { if(rawch=='-'&&hd[p]!=NIL&&hd[p]!=DOTDOT)
+ ch=DOTDOT; /* non-initial, non-escaped '-' */
+ p= tl[p]= cons(ch,NIL);
+ ch= getlitch(); }
+ if(hd[p]==DOTDOT)hd[p]='-'; /* naturalise a trailing '-' */
+ for(p=yylval;tl[p]!=NIL;p=tl[p]) /* move each DOTDOT to front of range */
+ if(hd[tl[p]]==DOTDOT)
+ { hd[tl[p]]=hd[p],hd[p]=DOTDOT;
+ if(hd[tl[p]]>=hd[tl[tl[p]]])
+ syntax("illegal use of '-' in [charclass]\n");
+ }
+ yylval= tl[yylval];
+ if(badch)errclass(badch,2);
+ if(rawch=='\n')
+ syntax("non-escaped newline encountered in char class\n"); else
+ if(ch==EOF)
+ { if(echoing)putchar('\n');
+ printf(
+ "syntax error: script ends inside unclosed char class brackets - \n");
+ printf(" [");
+ while(yylval!=NIL&& sl-- )
+ { putchar(hd[yylval]);
+ yylval= tl[yylval]; }
+ printf("...]\n");
+ acterror(); }
+ return(anti);
+}
+
+reset_lex() /* called after an error */
+{ extern word errs,errline;
+ extern char *current_script;
+ /*printf("reset_lex()\n"); /* DEBUG */
+ if(!commandmode)
+ { if(!errs)errs=fileinfo(get_fil(current_file),line_no);
+ /* convention, if errs set contains location of error, otherwise pick up
+ from current_file and line_no */
+ if(tl[errs]==0&&(char *)hd[errs]==current_script)
+ /* at end of file, so line_no has been reset to 0 */
+ printf("error occurs at end of ");
+ else printf("error found near line %d of ",tl[errs]);
+ printf("%sfile \"%s\"\ncompilation abandoned\n",
+ (char *)hd[errs]==current_script?"":"%insert ",
+ (char *)hd[errs]);
+ if((char *)hd[errs]==current_script)
+ errline=tl[errs]==0?lastline:tl[errs],errs=0;
+ else { while(tl[linostack]!=NIL)linostack=tl[linostack];
+ errline=hd[linostack]; }
+ /* tells editor where to find error - errline contains location of 1st
+ error in main script, errs is hereinfo of upto one error in %insert
+ script (each is 0 if not set) - some errors can set both */
+ }
+ reset_state();
+}
+
+reset_state() /* reset all global variables used by compiler */
+{ extern word TABSTRS,SGC,newtyps,algshfns,showchain,inexplist,sreds,
+ rv_script,idsused;
+ /* printf("reset_state()\n"); /* DEBUG */
+ if(commandmode)
+ while(c!='\n'&&c!=EOF)c=getc(s_in); /* no echo */
+ while(fileq!=NIL)fclose((FILE *)hd[hd[fileq]]),fileq=tl[fileq];
+ insertdepth= -1;
+ s_in=stdin;
+ echostack=idsused=prefixstack=litstack=linostack=vergstack
+ =margstack=NIL;
+ prefix=0; prefixbase[0]='\0';
+ echoing=verbosity&listing;
+ brct=inbnf=sreds=inlex=inexplist=commandmode=lverge=col=lmargin=0;
+ atnl=1;
+ rv_script=0;
+ algshfns=newtyps=showchain=SGC=TABSTRS=NIL;
+ c=' ';
+ line_no=0;
+ litmain=literate=0;
+ /* printf("exit reset_state()\n"); /* DEBUG */
+}
+
+/* end of MIRANDA LEX ANALYSER */
+
diff --git a/new/reduce.c b/new/reduce.c
new file mode 100644
index 0000000..04f7267
--- /dev/null
+++ b/new/reduce.c
@@ -0,0 +1,2376 @@
+/* MIRANDA REDUCE */
+/* new SK reduction machine - installed Oct 86 */
+
+/**************************************************************************
+ * 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 <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+struct stat buf; /* used only by code for FILEMODE, FILESTAT in reduce */
+#include "data.h"
+#include "big.h"
+#include "lex.h"
+extern word debug, UTF8, UTF8OUT;
+#define FST HD
+#define SND TL
+#define BSDCLOCK
+/* POSIX clock wraps around after c. 72 mins */
+#ifdef RYU
+char* d2s(double);
+word d2s_buffered(double, char*);
+#endif
+
+double fa,fb;
+long long cycles=0;
+word stdinuse=0;
+/* int lasthead=0; /* DEBUG */
+
+#define constr_tag(x) hd[x]
+#define idconstr_tag(x) hd[id_val(x)]
+#define constr_name(x) (tag[tl[x]]==ID?get_id(tl[x]):get_id(pn_val(tl[x])))
+#define suppressed(x) (tag[tl[x]]==STRCONS&&tag[pn_val(tl[x])]!=ID)
+ /* suppressed constructor */
+
+#define isodigit(x) ('0'<=(x) && (x)<='7')
+#define sign(x) (x)
+#define fsign(x) ((d=(x))<0?-1:d>0)
+/* ### */ /* functions marked ### contain possibly recursive calls
+ to reduce - fix later */
+
+compare(a,b) /* returns -1, 0, 1 as a is less than equal to or greater than
+ b in the ordering imposed on all data types by the miranda
+ language -- a and b already reduced */
+ /* used by MATCH, EQ, NEQ, GR, GRE */
+word a,b;
+{ double d;
+ L: switch(tag[a])
+ { case DOUBLE:
+ if(tag[b]==DOUBLE)return(fsign(get_dbl(a)-get_dbl(b)));
+ else return(fsign(get_dbl(a)-bigtodbl(b)));
+ case INT:
+ if(tag[b]==INT)return(bigcmp(a,b));
+ else return(fsign(bigtodbl(a)-get_dbl(b)));
+ case UNICODE: return sign(get_char(a)-get_char(b));
+ case ATOM:
+ if(tag[b]==UNICODE) return sign(get_char(a)-get_char(b));
+ if(S<=a&&a<=ERROR||S<=b&&b<=ERROR)
+ fn_error("attempt to compare functions");
+ /* what about constructors - FIX LATER */
+ if(tag[b]==ATOM)return(sign(a-b)); /* order of declaration */
+ else return(-1); /* atomic object always less than non-atomic */
+ case CONSTRUCTOR:
+ if(tag[b]==CONSTRUCTOR)
+ return(sign(constr_tag(a)-constr_tag(b))); /*order of declaration*/
+ else return(-1); /* atom less than non-atom */
+ case CONS: case AP:
+ if(tag[a]==tag[b])
+ { word temp;
+ hd[a]=reduce(hd[a]);
+ hd[b]=reduce(hd[b]);
+ if((temp=compare(hd[a],hd[b]))!=0)return(temp);
+ a=tl[a]=reduce(tl[a]);
+ b=tl[b]=reduce(tl[b]);
+ goto L; }
+ else if(S<=b&&b<=ERROR)fn_error("attempt to compare functions");
+ else return(1); /* non-atom greater than atom */
+ default: fprintf(stderr,"\nghastly error in compare\n");
+ }
+ return(0);
+}
+
+force(x) /* ensures that x is evaluated "all the way" */
+word x; /* x is already reduced */ /* ### */
+{ word h;
+ switch(tag[x])
+ { case AP: h=hd[x];
+ while(tag[h]==AP)h=hd[h];
+ if(S<=h&&h<=ERROR)return; /* don't go inside functions */
+ /* what about unsaturated constructors? fix later */
+ while(tag[x]==AP)
+ { tl[x]=reduce(tl[x]);
+ force(tl[x]);
+ x=hd[x]; }
+ return;
+ case CONS: while(tag[x]==CONS)
+ { hd[x]=reduce(hd[x]);
+ force(hd[x]);
+ x=tl[x]=reduce(tl[x]); }
+ }
+ return;
+}
+
+head(x) /* finds the function part of x */
+word x;
+{ while(tag[x]==AP)x= hd[x];
+ return(x);
+}
+
+extern char linebuf[]; /* used as workspace in various places */
+
+/* ### */ /* opposite is str_conv - see lex.c */
+char *getstring(x,cmd) /* collect Miranda string - x is already reduced */
+word x;
+char *cmd; /* context, for error message */
+{ word x1=x,n=0;
+ char *p=linebuf;
+ while(tag[x]==CONS&&n<BUFSIZE)
+ n++, hd[x] = reduce(hd[x]), x=tl[x]=reduce(tl[x]);
+ x=x1;
+ while(tag[x]==CONS&&n--)
+ *p++ = hd[x], x=tl[x];
+ *p++ ='\0';
+ if(p-linebuf>BUFSIZE)
+ { if(cmd)fprintf(stderr,
+ "\n%s, argument string too long (limit=%d chars): %s...\n",
+ cmd,BUFSIZE,linebuf),
+ outstats(),
+ exit(1);
+ else return(linebuf); /* see G_CLOSE */ }
+ return(linebuf); /* very inefficient to keep doing this for filenames etc.
+ CANNOT WE SUPPORT A PACKED REPRESENTATION OF STRINGS? */
+} /* call keep(linebuf) if you want to save the string */
+
+FILE *s_out=NULL; /* destination of current output message */
+ /* initialised in main() */
+#define Stdout 0
+#define Stderr 1
+#define Tofile 2
+#define Closefile 3
+#define Appendfile 4
+#define System 5
+#define Exit 6
+#define Stdoutb 7
+#define Tofileb 8
+#define Appendfileb 9
+ /* order of declaration of constructors of these names in sys_message */
+
+/* ### */
+output(e) /* "output" is called by YACC (see MIRANDA RULES) to print the
+ value of an expression - output then calls "reduce" - so the
+ whole reduction process is driven by the need to print */
+ /* the value of the whole expression is a list of `messages' */
+word e;
+{
+ extern word *cstack;
+ cstack = &e; /* don't follow C stack below this in gc */
+L:e= reduce(e);
+ while(tag[e]==CONS)
+ { word d;
+ hd[e]= reduce(hd[e]);
+ switch(constr_tag(head(hd[e])))
+ { case Stdout: print(tl[hd[e]]);
+ break;
+ case Stdoutb: UTF8OUT=0;
+ print(tl[hd[e]]);
+ UTF8OUT=UTF8;
+ break;
+ case Stderr: s_out=stderr; print(tl[hd[e]]); s_out=stdout;
+ break;
+ case Tofile: outf(hd[e]);
+ break;
+ case Tofileb: UTF8OUT=0;
+ outf(hd[e]);
+ UTF8OUT=UTF8;
+ break;
+ case Closefile: closefile(tl[hd[e]]=reduce(tl[hd[e]]));
+ break;
+ case Appendfile: apfile(tl[hd[e]]=reduce(tl[hd[e]]));
+ break;
+ case Appendfileb: UTF8OUT=0;
+ apfile(tl[hd[e]]=reduce(tl[hd[e]]));
+ UTF8OUT=UTF8;
+ break;
+ case System: system(getstring(tl[hd[e]]=reduce(tl[hd[e]]),"System"));
+ break;
+ case Exit: { word n=reduce(tl[hd[e]]);
+ if(tag[n]==INT)n=digit0(n);
+ else word_error("Exit");
+ outstats(); exit(n); }
+ default: fprintf(stderr,"\n<impossible event in output list: ");
+ out(stderr,hd[e]);
+ fprintf(stderr,">\n"); }
+ e= tl[e]= reduce(tl[e]);
+ }
+ if(e==NIL)return;
+ fprintf(stderr,"\nimpossible event in output\n"),
+ putc('<',stderr),out(stderr,e),fprintf(stderr,">\n");
+ exit(1);
+}
+
+/* ### */
+print(e) /* evaluate list of chars and send to s_out */
+word e;
+{ e= reduce(e);
+ while(tag[e]==CONS && is_char(hd[e]=reduce(hd[e])))
+ { unsigned word c=get_char(hd[e]);
+ if(UTF8)outUTF8(c,s_out); else
+ if(c<256) putc(c,s_out);
+ else fprintf(stderr,"\n warning: non Latin1 char \%x in print, ignored\n",c);
+ e= tl[e]= reduce(tl[e]); }
+ if(e==NIL)return;
+ fprintf(stderr,"\nimpossible event in print\n"),
+ putc('<',stderr),out(stderr,e),fprintf(stderr,">\n"),
+ exit(1);
+}
+
+word outfilq=NIL; /* list of opened-for-output files */
+/* note that this will be automatically reset to NIL and all files on it
+closed at end of expression evaluation, because of the fork-exit structure */
+
+/* ### */
+outf(e) /* e is of the form (Tofile f x) */
+word e;
+{ word p=outfilq; /* have we already opened this file for output? */
+ char *f=getstring(tl[hd[e]]=reduce(tl[hd[e]]),"Tofile");
+ while(p!=NIL && strcmp((char *)hd[hd[p]],f)!=0)p=tl[p];
+ if(p==NIL) /* new output file */
+ { s_out= fopen(f,"w");
+ if(s_out==NULL)
+ { fprintf(stderr,"\nTofile: cannot write to \"%s\"\n",f);
+ s_out=stdout;
+ return;
+ /* outstats(); exit(1); /* release one policy */
+ }
+ if(isatty(fileno(s_out)))setbuf(s_out,NULL); /*for unbuffered tty output*/
+ outfilq= cons(datapair(keep(f),s_out),outfilq); }
+ else s_out= (FILE *)tl[hd[p]];
+ print(tl[e]);
+ s_out= stdout;
+}
+
+apfile(f) /* open file of name f for appending and add to outfilq */
+word f;
+{ word p=outfilq; /* is it already open? */
+ char *fil=getstring(f,"Appendfile");
+ while(p!=NIL && strcmp((char *)hd[hd[p]],fil)!=0)p=tl[p];
+ if(p==NIL) /* no, so open in append mode */
+ { FILE *s=fopen(fil,"a");
+ if(s==NULL)
+ fprintf(stderr,"\nAppendfile: cannot write to \"%s\"\n",fil);
+ else outfilq= cons(datapair(keep(fil),s),outfilq);
+ }
+ /* if already there do nothing */
+}
+
+closefile(f) /* remove file of name "f" from outfilq and close stream */
+word f;
+{ word *p= &outfilq; /* is this file open for output? */
+ char *fil=getstring(f,"Closefile");
+ while(*p!=NIL && strcmp((char *)hd[hd[*p]],fil)!=0)p= &tl[*p];
+ if(*p!=NIL) /* yes */
+ { fclose((FILE *)tl[hd[*p]]);
+ *p=tl[*p]; /* remove link from outfilq */}
+ /* otherwise ignore closefile request (harmless??) */
+}
+
+static word errtrap=0; /* to prevent error cycles - see ERROR below */
+word waiting=NIL;
+/* list of terminated child processes with exit_status - see Exec/EXEC */
+
+/* pointer-reversing SK reduction machine - based on code written Sep 83 */
+
+#define BACKSTOP 020000000000
+#define READY(x) (x)
+#define RESTORE(x)
+/* in this machine the above two are no-ops, alternate definitions are, eg
+#define READY(x) (x+1)
+#define RESTORE(x) x--
+(if using this method each strict comb needs next opcode unallocated)
+ see comment before "ready" switch */
+#define FIELD word
+#define tlptrbit 020000000000
+#define tlptrbits 030000000000
+ /* warning -- if you change this tell `mark()' in data.c */
+#define mktlptr(x) x |= tlptrbit
+#define mk1tlptr x |= tlptrbits
+#define mknormal(x) x &= ~tlptrbits
+#define abnormal(x) ((x)<0)
+/* covers x is tlptr and x==BACKSTOP */
+
+/* control abstractions */
+
+#define setcell(t,a,b) tag[e]=t,hd[e]=a,tl[e]=b
+#define DOWNLEFT hold=s, s=e, e=hd[e], hd[s]=hold
+#define DOWNRIGHT hold=hd[s], hd[s]=e, e=tl[s], tl[s]=hold, mktlptr(s)
+#define downright if(abnormal(s))goto DONE; DOWNRIGHT
+#define UPLEFT hold=s, s=hd[s], hd[hold]=e, e=hold
+#define upleft if(abnormal(s))goto DONE; UPLEFT
+#define GETARG(a) UPLEFT, a=tl[e]
+#define getarg(a) upleft; a=tl[e]
+#define UPRIGHT mknormal(s), hold=tl[s], tl[s]=e, e=hd[s], hd[s]=hold
+#define lastarg tl[e]
+word reds=0;
+
+/* IMPORTANT WARNING - the macro's
+ `downright;' `upleft;' `getarg;'
+ MUST BE ENCLOSED IN BRACES when they occur as the body of a control
+ structure (if, while etc.) */
+
+#define simpl(r) hd[e]=I, e=tl[e]=r
+
+#ifdef DEBUG
+word maxrdepth=0,rdepth=0;
+#endif
+
+#define fails(x) (x==NIL)
+#define FAILURE NIL
+ /* used by grammar combinators */
+
+/* reduce e to hnf, note that a function in hnf will have head h with
+ S<=h<=ERROR all combinators lie in this range see combs.h */
+FIELD reduce(e)
+FIELD e;
+{ FIELD s=BACKSTOP,hold,arg1,arg2,arg3;
+#ifdef DEBUG
+ if(++rdepth>maxrdepth)maxrdepth=rdepth;
+ if(debug&02)
+ printf("reducing: "),out(stdout,e),putchar('\n');
+#endif
+
+ NEXTREDEX:
+ while(!abnormal(e)&&tag[e]==AP)DOWNLEFT;
+#ifdef HISTO
+ histo(e);
+#endif
+#ifdef DEBUG
+ if(debug&02)
+ { printf("head= ");
+ if(e==BACKSTOP)printf("BACKSTOP");
+ else out(stdout,e);
+ putchar('\n'); }
+#endif
+
+ OPDECODE:
+/*lasthead=e; /* DEBUG */
+ cycles++;
+ switch(e)
+ {
+ case S: /* S f g x => f x(g x) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ hd[e]=ap(arg1,lastarg); tl[e]=ap(arg2,lastarg);
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case B: /* B f g x => f(g z) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ hd[e]=arg1; tl[e]=ap(arg2,lastarg);
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case CB: /* CB f g x => g(f z) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ hd[e]=arg2; tl[e]=ap(arg1,lastarg);
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case C: /* C f g x => f x g */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ hd[e]=ap(arg1,lastarg); tl[e]=arg2;
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case Y: /* Y h => self where self=(h self) */
+ upleft;
+ hd[e]=tl[e]; tl[e]=e;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ L_K:
+ case K: /* K x y => x */
+ getarg(arg1);
+ upleft;
+ hd[e]=I; e=tl[e]=arg1;
+ goto NEXTREDEX; /* could make eager in first arg */
+
+ L_KI:
+ case KI: /* KI x y => y */
+ upleft; /* lose first arg */
+ upleft;
+ hd[e]=I; e=lastarg; /* ?? */
+ goto NEXTREDEX; /* could make eager in 2nd arg */
+
+ case S1: /* S1 k f g x => k(f x)(g x) */
+ getarg(arg1);
+ getarg(arg2);
+ getarg(arg3);
+ upleft;
+ hd[e]=ap(arg2,lastarg);
+ hd[e]=ap(arg1,hd[e]);
+ tl[e]=ap(arg3,lastarg);
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case B1: /* B1 k f g x => k(f(g x)) */
+ getarg(arg1); /* Mark Scheevel's new B1 */
+ getarg(arg2);
+ getarg(arg3);
+ upleft;
+ hd[e]=arg1;
+ tl[e]=ap(arg3,lastarg);
+ tl[e]=ap(arg2,tl[e]);
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case C1: /* C1 k f g x => k(f x)g */
+ getarg(arg1);
+ getarg(arg2);
+ getarg(arg3);
+ upleft;
+ hd[e]=ap(arg2,lastarg);
+ hd[e]=ap(arg1,hd[e]);
+ tl[e]=arg3;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case S_p: /* S_p f g x => (f x) : (g x) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ setcell(CONS,ap(arg1,lastarg),ap(arg2,lastarg));
+ goto DONE;
+
+ case B_p: /* B_p f g x => f : (g x) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ setcell(CONS,arg1,ap(arg2,lastarg));
+ goto DONE;
+
+ case C_p: /* C_p f g x => (f x) : g */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ setcell(CONS,ap(arg1,lastarg),arg2);
+ goto DONE;
+
+ case ITERATE: /* ITERATE f x => x:ITERATE f (f x) */
+ getarg(arg1);
+ upleft;
+ hold=ap(hd[e],ap(arg1,lastarg));
+ setcell(CONS,lastarg,hold);
+ goto DONE;
+
+ case ITERATE1: /* ITERATE1 f x => [], x=FAIL
+ => x:ITERATE1 f (f x), otherwise */
+ getarg(arg1);
+ upleft;
+ if((lastarg=reduce(lastarg))==FAIL) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; }
+ else
+ { hold=ap(hd[e],ap(arg1,lastarg));
+ setcell(CONS,lastarg,hold); }
+ goto DONE;
+
+ case G_RULE:
+ case P: /* P x y => x:y */
+ getarg(arg1);
+ upleft;
+ setcell(CONS,arg1,lastarg);
+ goto DONE;
+
+ case U: /* U f x => f (HD x) (TL x)
+ non-strict uncurry */
+ getarg(arg1);
+ upleft;
+ hd[e]=ap(arg1,ap(HD,lastarg));
+ tl[e]=ap(TL,lastarg);
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case Uf: /* Uf f x => f (BODY x) (LAST x)
+ version of non-strict U for
+ arbitrary constructors */
+ getarg(arg1);
+ upleft;
+ if(tag[head(lastarg)]==CONSTRUCTOR) /* be eager if safe */
+ hd[e]=ap(arg1,hd[lastarg]),
+ tl[e]=tl[lastarg];
+ else
+ hd[e]=ap(arg1,ap(BODY,lastarg)),
+ tl[e]=ap(LAST,lastarg);
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case ATLEAST: /* ATLEAST k f x => f(x-k), isnat x & x>=k
+ => FAIL, otherwise */
+ /* for matching n+k patterns */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ lastarg= reduce(lastarg); /* ### */
+ if(tag[lastarg]==INT)
+ { hold = bigsub(lastarg,arg1);
+ if(poz(hold))hd[e]=arg2,tl[e]=hold;
+ else hd[e]=I,e=tl[e]=FAIL; }
+ else hd[e]=I,e=tl[e]=FAIL;
+ goto NEXTREDEX;
+
+ case U_: /* U_ f (a:b) => f a b
+ U_ f other => FAIL
+ U_ is a strict version of U(see above) */
+ getarg(arg1);
+ upleft;
+ lastarg= reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ { hd[e]=I;
+ e=tl[e]=FAIL;
+ goto NEXTREDEX; }
+ hd[e]=ap(arg1,hd[lastarg]);
+ tl[e]=tl[lastarg];
+ goto NEXTREDEX;
+
+ case Ug: /* Ug k f (k x1 ... xn) => f x1 ... xn, n>=0
+ Ug k f other => FAIL
+ Ug is a strict version of U for arbitrary constructor k */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ lastarg= reduce(lastarg); /* ### */
+ if(constr_tag(arg1)!=constr_tag(head(lastarg)))
+ { hd[e]=I;
+ e=tl[e]=FAIL;
+ goto NEXTREDEX; }
+ if(tag[lastarg]==CONSTRUCTOR) /* case n=0 */
+ { hd[e]=I; e=tl[e]=arg2; goto NEXTREDEX; }
+ hd[e]=hd[lastarg];
+ tl[e]=tl[lastarg];
+ while(tag[hd[e]]!=CONSTRUCTOR)
+ /* go back to head of arg3, copying spine */
+ { hd[e]=ap(hd[hd[e]],tl[hd[e]]);
+ DOWNLEFT; }
+ hd[e]=arg2; /* replace k with f */
+ goto NEXTREDEX;
+
+ case MATCH: /* MATCH a f a => f
+ MATCH a f b => FAIL */
+ upleft;
+ arg1=lastarg=reduce(lastarg); /* ### */
+ /* note that MATCH evaluates arg1, usually needless, could have second
+ version - MATCHEQ, say */
+ getarg(arg2);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ hd[e]=I;
+ e=tl[e]=compare(arg1,lastarg)?FAIL:arg2;
+ goto NEXTREDEX;
+
+ case MATCHINT: /* same but 1st arg is integer literal */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ hd[e]=I;
+ e=tl[e]=(tag[lastarg]!=INT||bigcmp(arg1,lastarg))?FAIL:arg2;
+ /* note no coercion from INT to DOUBLE here */
+ goto NEXTREDEX;
+
+ case GENSEQ: /* GENSEQ (i,NIL) a => a:GENSEQ (i,NIL) (a+i)
+ GENSEQ (i,b) a => [], a>b=sign
+ => a:GENSEQ (i,b) (a+i), otherwise
+ where
+ sign = 1, i>=0
+ = -1, otherwise */
+ GETARG(arg1);
+ UPLEFT;
+ if(tl[arg1]!=NIL&&
+ (tag[arg1]==AP?compare(lastarg,tl[arg1]):compare(tl[arg1],lastarg))>0)
+ hd[e]=I, e=tl[e]=NIL;
+ else hold=ap(hd[e],numplus(lastarg,hd[arg1])),
+ setcell(CONS,lastarg,hold);
+ goto DONE;
+ /* efficiency hack - tag of arg1 encodes sign of step */
+
+ case MAP: /* MAP f [] => []
+ MAP f (a:x) => f a : MAP f x */
+ getarg(arg1);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ hd[e]=I, e=tl[e]=NIL;
+ else hold=ap(hd[e],tl[lastarg]),
+ setcell(CONS,ap(arg1,hd[lastarg]),hold);
+ goto DONE;
+
+ case FLATMAP: /* funny version of map for compiling zf exps
+ FLATMAP f [] => []
+ FLATMAP f (a:x) => FLATMAP f x, f a=FAIL
+ => f a ++ FLATMAP f x
+ (FLATMAP was formerly called MAP1) */
+ getarg(arg1);
+ getarg(arg2);
+ L1:arg2=reduce(arg2); /* ### */
+ if(arg2==NIL)
+ { hd[e]=I;
+ e=tl[e]=NIL;
+ goto DONE; }
+ hold=reduce(hold=ap(arg1,hd[arg2]));
+ if(hold==FAIL||hold==NIL){ arg2=tl[arg2]; goto L1; }
+ tl[e]=ap(hd[e],tl[arg2]);
+ hd[e]=ap(APPEND,hold);
+ goto NEXTREDEX;
+
+ case FILTER: /* FILTER f [] => []
+ FILTER f (a:x) => a : FILTER f x, f a
+ => FILTER f x, otherwise */
+ getarg(arg1);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ while(lastarg!=NIL&&reduce(ap(arg1,hd[lastarg]))==False) /* ### */
+ lastarg=reduce(tl[lastarg]); /* ### */
+ if(lastarg==NIL)
+ hd[e]=I, e=tl[e]=NIL;
+ else hold=ap(hd[e],tl[lastarg]),
+ setcell(CONS,hd[lastarg],hold);
+ goto DONE;
+
+ case LIST_LAST: /* LIST_LAST x => x!(#x-1) */
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL)fn_error("last []"); /* ### */
+ while((tl[lastarg]=reduce(tl[lastarg]))!=NIL) /* ### */
+ lastarg=tl[lastarg];
+ hd[e]=I; e=tl[e]=hd[lastarg];
+ goto NEXTREDEX;
+
+ case LENGTH: /* takes length of a list */
+ upleft;
+ { long long n=0; /* problem - may be followed by gc */
+ /* cannot make static because of ### below */
+ while((lastarg=reduce(lastarg))!=NIL) /* ### */
+ lastarg=tl[lastarg],n++;
+ simpl(sto_word(n)); }
+ goto DONE;
+
+ case DROP:
+ getarg(arg1);
+ upleft;
+ arg1=tl[hd[e]]=reduce(tl[hd[e]]); /* ### */
+ if(tag[arg1]!=INT)word_error("drop");
+ { long long n=get_word(arg1);
+ while(n-- >0)
+ if((lastarg=reduce(lastarg))==NIL) /* ### */
+ { simpl(NIL); goto DONE; }
+ else lastarg=tl[lastarg]; }
+ simpl(lastarg);
+ goto NEXTREDEX;
+
+ case SUBSCRIPT: /* SUBSCRIPT i x => x!i */
+ upleft;
+ upleft;
+ arg1=tl[hd[e]]=reduce(tl[hd[e]]); /* ### */
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)subs_error();
+ { long long indx = tag[arg1]==ATOM?arg1:/* small indexes represented directly */
+ tag[arg1]==INT?get_word(arg1):
+ word_error("!");
+ /* problem, indx may be followed by gc
+ - cannot make static, because of ### below */
+ if(indx<0)subs_error();
+ while(indx)
+ { lastarg= tl[lastarg]= reduce(tl[lastarg]); /* ### */
+ if(lastarg==NIL)subs_error();
+ indx--; }
+ hd[e]= I;
+ e=tl[e]=hd[lastarg]; /* could be eager in tl[e] */
+ goto NEXTREDEX; }
+
+ case FOLDL1: /* FOLDL1 op (a:x) => FOLDL op a x */
+ getarg(arg1);
+ upleft;
+ if((lastarg=reduce(lastarg))!=NIL) /* ### */
+ { hd[e]=ap2(FOLDL,arg1,hd[lastarg]);
+ tl[e]=tl[lastarg];
+ goto NEXTREDEX; }
+ else fn_error("foldl1 applied to []");
+
+ case FOLDL: /* FOLDL op r [] => r
+ FOLDL op r (a:x) => FOLDL op (op r a)^ x
+
+ ^ (FOLDL op) is made strict in 1st param */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ while((lastarg=reduce(lastarg))!=NIL) /* ### */
+ arg2=reduce(ap2(arg1,arg2,hd[lastarg])), /* ^ ### */
+ lastarg=tl[lastarg];
+ hd[e]=I, e=tl[e]=arg2;
+ goto NEXTREDEX;
+
+ case FOLDR: /* FOLDR op r [] => r
+ FOLDR op r (a:x) => op a (FOLDR op r x) */
+ getarg(arg1);
+ getarg(arg2);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ hd[e]=I, e=tl[e]=arg2;
+ else hold=ap(hd[e],tl[lastarg]),
+ hd[e]=ap(arg1,hd[lastarg]), tl[e]=hold;
+ goto NEXTREDEX;
+
+ L_READBIN:
+ case READBIN: /* READBIN streamptr => nextchar : READBIN streamptr
+ if end of file, READBIN file => NIL
+ READBIN does no UTF-8 conversion */
+ UPLEFT; /* gc insecurity - arg is not a heap object */
+ if(lastarg==0) /* special case created by $:- */
+ { if(stdinuse=='-')stdin_error(':');
+ if(stdinuse)
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ stdinuse=':';
+ tl[e]=(word)stdin; }
+ hold= getc((FILE *)lastarg);
+ if(hold==EOF)
+ { fclose((FILE *)lastarg);
+ hd[e]=I;
+ e=tl[e]= NIL;
+ goto DONE; }
+ setcell(CONS,hold,ap(READBIN,lastarg));
+ goto DONE;
+
+ L_READ:
+ case READ: /* READ streamptr => nextchar : READ streamptr
+ if end of file, READ file => NIL
+ does UTF-8 conversion where appropriate */
+ UPLEFT; /* gc insecurity - arg is not a heap object */
+ if(lastarg==0) /* special case created by $- */
+ { if(stdinuse==':')stdin_error('-');
+ if(stdinuse)
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ stdinuse='-';
+ tl[e]=(word)stdin; }
+ hold=UTF8?sto_char(fromUTF8((FILE *)lastarg)):getc((FILE *)lastarg);
+ if(hold==EOF)
+ { fclose((FILE *)lastarg);
+ hd[e]=I;
+ e=tl[e]= NIL;
+ goto DONE; }
+ setcell(CONS,hold,ap(READ,lastarg));
+ goto DONE;
+
+ L_READVALS:
+ case READVALS: /* READVALS (t:fil) f => [], EOF from FILE *f
+ => val : READVALS t f, otherwise
+ where val is obtained by parsing lines of
+ f, and taking next legal expr of type t */
+ GETARG(arg1);
+ upleft;
+ hold=parseline(hd[arg1],(FILE *)lastarg,tl[arg1]);
+ if(hold==EOF)
+ { fclose((FILE *)lastarg);
+ hd[e]=I;
+ e=tl[e]= NIL;
+ goto DONE; }
+ arg2=ap(hd[e],lastarg);
+ setcell(CONS,hold,arg2);
+ goto DONE;
+
+ case BADCASE: /* BADCASE cons(oldn,here_info) => BOTTOM */
+ UPLEFT;
+ { extern word sourcemc;
+ word subject= hd[lastarg];
+ /* either datapair(oldn,0) or 0 */
+ fprintf(stderr,"\nprogram error: missing case in definition");
+ if(subject) /* cannot do patterns - FIX LATER */
+ fprintf(stderr," of %s",(char *)hd[subject]);
+ putc('\n',stderr);
+ out_here(stderr,tl[lastarg],1);
+ /* if(sourcemc&&nargs>1)
+ { int i=2;
+ fprintf(stderr,"arg%s = ",nargs>2?"s":"");
+ while(i<=nargs)out(stderr,tl[stackp[-(i++)]]),putc(' ',stderr);
+ putc('\n',stderr); } /* fix later */
+ }
+ outstats();
+ exit(1);
+
+ case GETARGS: /* GETARGS 0 => argv ||`$*' = command line args */
+ UPLEFT;
+ simpl(conv_args());
+ goto DONE;
+
+ case CONFERROR: /* CONFERROR error_info => BOTTOM */
+ /* if(nargs<1)fprintf(stderr,"\nimpossible event in reduce\n"),
+ exit(1); */
+ UPLEFT;
+ fprintf(stderr,"\nprogram error: lhs of definition doesn't match rhs");
+ /*fprintf(stderr," OF ");
+ out_formal1(stderr,hd[lastarg]); /* omit - names may have been aliased */
+ putc('\n',stderr);
+ out_here(stderr,tl[lastarg],1);
+ outstats();
+ exit(1);
+
+ case ERROR: /* ERROR error_info => BOTTOM */
+ upleft;
+ if(errtrap)fprintf(stderr,"\n(repeated error)\n");
+ else { errtrap=1;
+ fprintf(stderr,"\nprogram error: ");
+ s_out=stderr;
+ print(lastarg); /* ### */
+ putc('\n',stderr); }
+ outstats();
+ exit(1);
+
+ case WAIT: /* WAIT pid => <exit_status of child process pid> */
+ UPLEFT;
+ { word *w= &waiting; /* list of terminated pid's and their exit statuses */
+ while(*w!=NIL&&hd[*w]!=lastarg)w= &tl[tl[*w]];
+ if(*w!=NIL)hold=hd[tl[*w]],
+ *w=tl[tl[*w]]; /* remove entry */
+ else { word status;
+ while((hold=wait(&status))!=lastarg&&hold!= -1)
+ waiting=cons(hold,cons(WEXITSTATUS(status),waiting));
+ if(hold!= -1)hold=WEXITSTATUS(status); }}
+ simpl(stosmallint(hold));
+ goto DONE;
+
+ L_I:
+/* case MONOP: (all strict monadic operators share this code) */
+ case I: /* we treat I as strict to avoid I-chains (MOD1) */
+ case SEQ:
+ case FORCE:
+ case HD:
+ case TL:
+ case BODY:
+ case LAST:
+ case EXEC:
+ case FILEMODE:
+ case FILESTAT:
+ case GETENV:
+ case INTEGER:
+ case NUMVAL:
+ case TAKE:
+ case STARTREAD:
+ case STARTREADBIN:
+ case NB_STARTREAD:
+ case COND:
+ case APPEND:
+ case AND:
+ case OR:
+ case NOT:
+ case NEG:
+ case CODE:
+ case DECODE:
+ case SHOWNUM:
+ case SHOWHEX:
+ case SHOWOCT:
+ case ARCTAN_FN: /* ...FN are strict functions of one numeric arg */
+ case EXP_FN:
+ case ENTIER_FN:
+ case LOG_FN:
+ case LOG10_FN:
+ case SIN_FN:
+ case COS_FN:
+ case SQRT_FN:
+ downright; /* subtask -- reduce arg */
+ goto NEXTREDEX;
+
+ case TRY: /* TRY f g x => TRY(f x)(g x) */
+ getarg(arg1);
+ getarg(arg2);
+ while(!abnormal(s))
+ { UPLEFT;
+ hd[e]=ap(TRY,arg1=ap(arg1,lastarg));
+ arg2=tl[e]=ap(arg2,lastarg); }
+ DOWNLEFT;
+ /* DOWNLEFT; DOWNRIGHT; equivalent to:*/
+ hold=s,s=e,e=tl[e],tl[s]=hold,mktlptr(s); /* now be strict in arg1 */
+ goto NEXTREDEX;
+
+ case FAIL: /* FAIL x => FAIL */
+ while(!abnormal(s))hold=s,s=hd[s],hd[hold]=FAIL,tl[hold]=0;
+ goto DONE;
+
+/* case DIOP: (all strict diadic operators share this code) */
+ case ZIP:
+ case STEP:
+ case EQ:
+ case NEQ:
+ case PLUS:
+ case MINUS:
+ case TIMES:
+ case INTDIV:
+ case FDIV:
+ case MOD:
+ case GRE:
+ case GR:
+ case POWER:
+ case SHOWSCALED:
+ case SHOWFLOAT:
+ case MERGE:
+ upleft;
+ downright; /* first subtask -- reduce arg2 */
+ goto NEXTREDEX;
+
+ case Ush: /* strict in three args */
+ case STEPUNTIL:
+ upleft;
+ upleft;
+ downright;
+ goto NEXTREDEX; /* first subtask -- reduce arg3 */
+
+ case Ush1: /* non-strict version of Ush */
+ /* Ush1 (k f1...fn) p stuff
+ => "k"++' ':f1 x1 ...++' ':fn xn, p='\0'
+ => "(k"++' ':f1 x1 ...++' ':fn xn++")", p='\1'
+ where xi = LAST(BODY^(n-i) stuff) */
+ getarg(arg1);
+ arg1=reduce(arg1); /* ### */
+ getarg(arg2);
+ arg2=reduce(arg2); /* ### */
+ getarg(arg3);
+ if(tag[arg1]==CONSTRUCTOR) /* don't parenthesise atom */
+ { hd[e]=I;
+ if(suppressed(arg1))
+ e=tl[e]=str_conv("<unprintable>");
+ else e=tl[e]=str_conv(constr_name(arg1));
+ goto DONE; }
+ hold=arg2?cons(')',NIL):NIL;
+ while(tag[arg1]!=CONSTRUCTOR)
+ hold=cons(' ',ap2(APPEND,ap(tl[arg1],ap(LAST,arg3)),hold)),
+ arg1=hd[arg1],arg3=ap(BODY,arg3);
+ if(suppressed(arg1))
+ { hd[e]=I; e=tl[e]=str_conv("<unprintable>"); goto DONE; }
+ hold=ap2(APPEND,str_conv(constr_name(arg1)),hold);
+ if(arg2)
+ { setcell(CONS,'(',hold); goto DONE; }
+ else { hd[e]=I; e=tl[e]=hold; goto NEXTREDEX; }
+
+ case MKSTRICT: /* MKSTRICT k f x1 ... xk => f x1 ... xk, xk~=BOT */
+ GETARG(arg1);
+ getarg(arg2);
+ { word i=arg1;
+ while(i--) { upleft; } }
+ lastarg=reduce(lastarg); /* ### */
+ while(--arg1) /* go back towards head, copying spine */
+ { hd[e]=ap(hd[hd[e]],tl[hd[e]]);
+ DOWNLEFT;}
+ hd[e]=arg2; /* overwrite (MKSTRICT k f) with f */
+ goto NEXTREDEX;
+
+ case G_ERROR: /* G_ERROR f g toks = (g residue):[], fails(f toks)
+ = f toks, otherwise */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(!fails(hold))
+ { hd[e]=I; e=tl[e]=hold; goto DONE; }
+ hold=g_residue(lastarg);
+ setcell(CONS,ap(arg2,hold),NIL);
+ goto DONE;
+
+ case G_ALT: /* G_ALT f g toks = f toks, !fails(f toks)
+ = g toks, otherwise */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(!fails(hold))
+ { hd[e]=I; e=tl[e]=hold; goto DONE; }
+ hd[e]=arg2;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case G_OPT: /* G_OPT f toks = []:toks, fails(f toks)
+ = [a]:toks', otherwise
+ where
+ a:toks' = f toks */
+ GETARG(arg1);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(fails(hold))
+ setcell(CONS,NIL,lastarg);
+ else setcell(CONS,cons(hd[hold],NIL),tl[hold]);
+ goto DONE;
+
+ case G_STAR: /* G_STAR f toks => []:toks, fails(f toks)
+ => ((a:FST z):SND z)
+ where
+ a:toks' = f toks
+ z = G_STAR f toks'
+ */
+ GETARG(arg1);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(fails(hold))
+ { setcell(CONS,NIL,lastarg); goto DONE; }
+ arg2=ap(hd[e],tl[hold]); /* called z in above rules */
+ tag[e]=CONS;hd[e]=cons(hd[hold],ap(FST,arg2));tl[e]=ap(SND,arg2);
+ goto DONE;
+
+ /* G_RULE has same action as P */
+
+ case G_FBSTAR: /* G_FBSTAR f toks
+ = I:toks, if fails(f toks)
+ = G_SEQ (G_FBSTAR f) (G_RULE (CB a)) toks', otherwise
+ where a:toks' = f toks
+ */
+ GETARG(arg1);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(fails(hold))
+ { setcell(CONS,I,lastarg); goto DONE; }
+ hd[e]=ap2(G_SEQ,hd[e],ap(G_RULE,ap(CB,hd[hold]))); tl[e]=tl[hold];
+ goto NEXTREDEX;
+
+ case G_SYMB: /* G_SYMB t ((t,s):toks) = t:toks
+ G_SYMB t toks = FAILURE */
+ GETARG(arg1); /* will be in NF */
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ { hd[e]=I,e=tl[e]=NIL; goto DONE; }
+ hd[lastarg]=reduce(hd[lastarg]); /* ### */
+ hold=ap(FST,hd[lastarg]);
+ if(compare(arg1,reduce(hold))) /* ### */
+ hd[e]=I,e=tl[e]=FAILURE;
+ else setcell(CONS,arg1,tl[lastarg]);
+ goto DONE;
+
+ case G_ANY: /* G_ANY ((t,s):toks) = t:toks
+ G_ANY [] = FAILURE */
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ hd[e]=I,e=tl[e]=FAILURE;
+ else setcell(CONS,ap(FST,hd[lastarg]),tl[lastarg]);
+ goto DONE;
+
+ case G_SUCHTHAT: /* G_SUCHTHAT f ((t,s):toks) = t:toks, f t
+ G_SUCHTHAT f toks = FAILURE */
+ GETARG(arg1);
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ { hd[e]=I,e=tl[e]=FAILURE; goto DONE; }
+ hold=ap(FST,hd[lastarg]);
+ hold=reduce(hold); /* ### */
+ if(reduce(ap(arg1,hold))==True) /* ### */
+ setcell(CONS,hold,tl[lastarg]);
+ else hd[e]=I,e=tl[e]=FAILURE;
+ goto DONE;
+
+
+ case G_END: /* G_END [] = []:[]
+ G_END other = FAILURE */
+ upleft;
+ lastarg=reduce(lastarg);
+ if(lastarg==NIL)
+ setcell(CONS,NIL,NIL);
+ else hd[e]=I,e=tl[e]=FAILURE;
+ goto DONE;
+
+ case G_STATE: /* G_STATE ((t,s):toks) = s:((t,s):toks)
+ G_STATE [] = FAILURE */
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==NIL)
+ hd[e]=I,e=tl[e]=FAILURE;
+ else setcell(CONS,ap(SND,hd[lastarg]),lastarg);
+ goto DONE;
+
+ case G_SEQ: /* G_SEQ f g toks = FAILURE, fails(f toks)
+ = FAILURE, fails(g toks')
+ = b a:toks'', otherwise
+ where
+ a:toks' = f toks
+ b:toks'' = g toks' */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ hold=ap(arg1,lastarg);
+ hold=reduce(hold); /* ### */
+ if(fails(hold))
+ { hd[e]=I,e=tl[e]=FAILURE; goto DONE; }
+ arg3=ap(arg2,tl[hold]);
+ arg3=reduce(arg3); /* ### */
+ if(fails(arg3))
+ { hd[e]=I,e=tl[e]=FAILURE; goto DONE; }
+ setcell(CONS,ap(hd[arg3],hd[hold]),tl[arg3]);
+ goto DONE;
+
+ case G_UNIT: /* G_UNIT toks => I:toks */
+ upleft;
+ tag[e]=CONS,hd[e]=I;
+ goto DONE;
+ /* G_UNIT is right multiplicative identity, equivalent (G_RULE I) */
+
+ case G_ZERO: /* G_ZERO toks => FAILURE */
+ upleft;
+ simpl(FAILURE);
+ goto DONE;
+ /* G_ZERO is left additive identity */
+
+ case G_CLOSE: /* G_CLOSE s f toks = <error s>, fails(f toks')
+ = <error s>, toks'' ~= NIL
+ = a, otherwise
+ where
+ toks' = G_COUNT toks
+ a:toks'' = f toks' */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ arg3=ap(G_COUNT,lastarg);
+ hold=ap(arg2,arg3);
+ hold=reduce(hold); /* ### */
+ if(fails(hold) /* ||(tl[hold]=reduce(tl[hold]))!=NIL /* ### */
+ ) /* suppress to make parsers lazy by default 13/12/90 */
+ { fprintf(stderr,"\nPARSE OF %sFAILS WITH UNEXPECTED ",
+ getstring(arg1,0));
+ arg3=reduce(tl[g_residue(arg3)]);
+ if(arg3==NIL)
+ fprintf(stderr,"END OF INPUT\n"),
+ outstats(),
+ exit(1);
+ hold=ap(FST,hd[arg3]);
+ hold=reduce(hold);
+ fprintf(stderr,"TOKEN \"");
+ if(hold==OFFSIDE)fprintf(stderr,"offside"); /* not now possible */
+ { char *p=getstring(hold,0);
+ while(*p)fprintf(stderr,"%s",charname(*p++)); }
+ fprintf(stderr,"\"\n");
+ outstats();
+ exit(1); }
+ hd[e]=I,e=tl[e]=hd[hold];
+ goto NEXTREDEX;
+/* NOTE the atom OFFSIDE differs from every string and is used as a
+ pseudotoken when implementing the offside rule - see `indent' in prelude */
+
+ case G_COUNT: /* G_COUNT NIL => NIL
+ G_COUNT (t:toks) => t:G_COUNT toks */
+ /* G_COUNT is an identity operation on lists - its purpose is to mark
+ last token examined, for syntax error location purposes */
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ setcell(CONS,hd[lastarg],ap(G_COUNT,tl[lastarg]));
+ goto DONE;
+
+/* Explanation of %lex combinators. A lex analyser is of type
+
+ lexer == [char] -> [alpha]
+
+ At top level these are of the form (LEX_RPT f) where f is of type
+
+ lexer1 == startcond -> [char] -> (alpha,startcond,[char])
+
+ A lexer1 is guaranteed to return a triple (if it returns at all...)
+ and is built using LEX_TRY.
+
+ LEX_TRY [(scstuff,(matcher [],rule))*] :: lexer1
+ rule :: [char] -> alpha
+ matcher :: partial_match -> input -> {(alpha,input') | []}
+
+ partial_match and input are both [char] and [] represents failure.
+ The other lex combinators - LEX_SEQ, LEX_OR, LEX_CLASS etc., all
+ create and combine objects of type matcher.
+
+ LEX_RPT1 is a deviant version that labels the input characters
+ with their lexical state (row,col) using LEX_COUNT - goes with
+ LEX_TRY1 which feeds the leading state of input to each rule.
+
+*/
+
+ case LEX_RPT1: /* LEX_RPT1 f s x => LEX_RPT f s (LEX_COUNT0 x)
+ i.e. LEX_RPT1 f s => B (LEX_RPT f s) LEX_COUNT0
+ */
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=ap(B,ap2(LEX_RPT,arg1,lastarg)); tl[e]=LEX_COUNT0;
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case LEX_RPT: /* LEX_RPT f s [] => []
+ LEX_RPT f s x => a : LEX_RPT f s' y
+ where
+ (a,s',y) = f s x
+ note that if f returns a result it is
+ guaranteed to be a triple
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ hold=ap2(arg1,arg2,lastarg);
+ arg1=hd[hd[e]];
+ hold=reduce(hold);
+ setcell(CONS,hd[hold],ap2(arg1,hd[tl[hold]],tl[tl[hold]]));
+ goto DONE;
+
+ case LEX_TRY:
+ upleft;
+ tl[e]=reduce(tl[e]); /* ### */
+ force(tl[e]);
+ hd[e]=LEX_TRY_;
+ DOWNLEFT;
+ /* falls thru to next case */
+
+ case LEX_TRY_:
+ /* LEX_TRY ((scstuff,(f,rule)):alt) s x => LEX_TRY alt s x, if f x = []
+ => (rule (rev a),s,y), otherwise
+ where
+ (a,y) = f x
+ LEX_TRY [] s x => BOTTOM
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+L2: if(arg1==NIL)lexfail(lastarg);
+ if(hd[hd[hd[arg1]]]&&!member(hd[hd[hd[arg1]]],arg2))
+ { arg1=tl[arg1]; goto L2; } /* hd[scstuff] is 0 or list of startconds */
+ hold=ap(hd[tl[hd[arg1]]],lastarg);
+ if((hold=reduce(hold))==NIL) /* ### */
+ { arg1=tl[arg1]; goto L2; }
+ setcell(CONS,ap(tl[tl[hd[arg1]]],ap(DESTREV,hd[hold])),
+ cons(tl[hd[hd[arg1]]]?tl[hd[hd[arg1]]]-1:arg2,tl[hold]));
+ /* tl[scstuff] is 1 + next start condition (0 = no change) */
+ goto DONE;
+
+ case LEX_TRY1:
+ upleft;
+ tl[e]=reduce(tl[e]); /* ### */
+ force(tl[e]);
+ hd[e]=LEX_TRY1_;
+ DOWNLEFT;
+ /* falls thru to next case */
+
+ case LEX_TRY1_:
+ /* LEX_TRY1 ((scstuff,(f,rule)):alt) s x => LEX_TRY1 alt s x, if f x = []
+ => (rule n (rev a),s,y), otherwise
+ where
+ (a,y) = f x
+ n = lexstate(x)
+ ||same as LEX_TRY but feeds lexstate to rule
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+L3: if(arg1==NIL)lexfail(lastarg);
+ if(hd[hd[hd[arg1]]]&&!member(hd[hd[hd[arg1]]],arg2))
+ { arg1=tl[arg1]; goto L3; } /* hd[scstuff] is 0 or list of startconds */
+ hold=ap(hd[tl[hd[arg1]]],lastarg);
+ if((hold=reduce(hold))==NIL) /* ### */
+ { arg1=tl[arg1]; goto L3; }
+ setcell(CONS,ap2(tl[tl[hd[arg1]]],lexstate(lastarg),ap(DESTREV,hd[hold])),
+ cons(tl[hd[hd[arg1]]]?tl[hd[hd[arg1]]]-1:arg2,tl[hold]));
+ /* tl[scstuff] is 1 + next start condition (0 = no change) */
+ goto DONE;
+
+ case DESTREV: /* destructive reverse - used only by LEX_TRY */
+ GETARG(arg1); /* known to be an explicit list */
+ arg2=NIL; /* to hold reversed list */
+ while(arg1!=NIL)
+ { if(tag[hd[arg1]]==STRCONS) /* strip off lex state if present */
+ hd[arg1]=tl[hd[arg1]];
+ hold=tl[arg1],tl[arg1]=arg2,arg2=arg1,arg1=hold; }
+ hd[e]=I; e=tl[e]=arg2;
+ goto DONE;
+
+ case LEX_COUNT0: /* LEX_COUNT0 x => LEX_COUNT (state0,x) */
+ upleft;
+ hd[e]=LEX_COUNT; tl[e]=strcons(0,tl[e]);
+ DOWNLEFT;
+ /* falls thru to next case */
+
+ case LEX_COUNT: /* LEX_COUNT (state,[]) => []
+ LEX_COUNT (state,(a:x)) => (state,a):LEX_COUNT(state',a)
+ where
+ state == (line_no*256+col_no)
+ */
+ GETARG(arg1);
+ if((tl[arg1]=reduce(tl[arg1]))==NIL) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ hold=hd[tl[arg1]]; /* the char */
+ setcell(CONS,strcons(hd[arg1],hold),ap(LEX_COUNT,arg1));
+ if(hold=='\n')hd[arg1]=(hd[arg1]>>8)+1<<8;
+ else { word col = hd[arg1]&255;
+ col = hold=='\t'?(col/8+1)*8:col+1;
+ hd[arg1] = hd[arg1]&(~255)|col; }
+ tl[arg1]=tl[tl[arg1]];
+ goto DONE;
+
+#define lh(x) (tag[hd[x]]==STRCONS?tl[hd[x]]:hd[x])
+ /* hd char of possibly lex-state-labelled string */
+
+ case LEX_STRING: /* LEX_STRING [] p x => p : x
+ LEX_STRING (c:s) p (c:x) => LEX_STRING s (c:p) x
+ LEX_STRING (c:s) p other => []
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ while(arg1!=NIL)
+ { if((lastarg=reduce(lastarg))==NIL||lh(lastarg)!=hd[arg1]) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ arg1=tl[arg1]; arg2=cons(hd[lastarg],arg2); lastarg=tl[lastarg]; }
+ tag[e]=CONS; hd[e]=arg2;
+ goto DONE;
+
+ case LEX_CLASS: /* LEX_CLASS set p (c:x) => (c:p) : x, if c in set
+ LEX_CLASS set p x => [], otherwise
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL|| /* ### */
+ (hd[arg1]==ANTICHARCLASS?memclass(lh(lastarg),tl[arg1])
+ :!memclass(lh(lastarg),arg1))
+ )
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ setcell(CONS,cons(hd[lastarg],arg2),tl[lastarg]);
+ goto DONE;
+
+ case LEX_DOT: /* LEX_DOT p (c:x) => (c:p) : x
+ LEX_DOT p [] => []
+ */
+ GETARG(arg1);
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ setcell(CONS,cons(hd[lastarg],arg1),tl[lastarg]);
+ goto DONE;
+
+ case LEX_CHAR: /* LEX_CHAR c p (c:x) => (c:p) : x
+ LEX_CHAR c p x => []
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ if((lastarg=reduce(lastarg))==NIL||lh(lastarg)!=arg1) /* ### */
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ setcell(CONS,cons(arg1,arg2),tl[lastarg]);
+ goto DONE;
+
+ case LEX_SEQ: /* LEX_SEQ f g p x => [], if f p x = []
+ => g q y, otherwise
+ where
+ (q,y) = f p x
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ GETARG(arg3);
+ upleft;
+ hold=ap2(arg1,arg3,lastarg);
+ lastarg=NIL; /* anti-dragging measure */
+ if((hold=reduce(hold))==NIL) /* ### */
+ { hd[e]=I; e=tl[e]; goto DONE; }
+ hd[e]=ap(arg2,hd[hold]); tl[e]=tl[hold];
+ DOWNLEFT;
+ DOWNLEFT;
+ goto NEXTREDEX;
+
+ case LEX_OR: /* LEX_OR f g p x => g p x, if f p x = []
+ => f p x, otherwise
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ GETARG(arg3);
+ upleft;
+ hold=ap2(arg1,arg3,lastarg);
+ if((hold=reduce(hold))==NIL) /* ### */
+ { hd[e]=ap(arg2,arg3); DOWNLEFT; DOWNLEFT; goto NEXTREDEX; }
+ hd[e]=I; e=tl[e]=hold;
+ goto DONE;
+
+ case LEX_RCONTEXT: /* LEX_RC f g p x => [], if f p x = []
+ => [], if g q y = []
+ => f p x, otherwise <-*
+ where
+ (q,y) = f p x
+
+ (*) special case g=0 means test for y=[]
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ GETARG(arg3);
+ upleft;
+ hold=ap2(arg1,arg3,lastarg);
+ lastarg=NIL; /* anti-dragging measure */
+ if((hold=reduce(hold))==NIL /* ### */
+ || (arg2?(reduce(ap2(arg2,hd[hold],tl[hold]))==NIL) /* ### */
+ :(tl[hold]=reduce(tl[hold]))!=NIL ))
+ { hd[e]=I; e=tl[e]; goto DONE; }
+ hd[e]=I; e=tl[e]=hold;
+ goto DONE;
+
+ case LEX_STAR: /* LEX_STAR f p x => p : x, if f p x = []
+ => LEX_STAR f q y, otherwise
+ where
+ (q,y) = f p x
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ hold=ap2(arg1,arg2,lastarg);
+ while((hold=reduce(hold))!=NIL) /* ### */
+ arg2=hd[hold],lastarg=tl[hold],hold=ap2(arg1,arg2,lastarg);
+ tag[e]=CONS; hd[e]=arg2;
+ goto DONE;
+
+ case LEX_OPT: /* LEX_OPT f p x => p : x, if f p x = []
+ => f p x, otherwise
+ */
+ GETARG(arg1);
+ GETARG(arg2);
+ upleft;
+ hold=ap2(arg1,arg2,lastarg);
+ if((hold=reduce(hold))==NIL) /* ### */
+ { tag[e]=CONS; hd[e]=arg2; goto DONE; }
+ hd[e]=I; e=tl[e]=hold;
+ goto DONE;
+
+/* case NUMBER: /* constructor of arity 1
+ UPLEFT; /* cannot occur free
+ goto DONE; */ /* UNUSED*/
+
+/* case CONSTRUCTOR:
+ for(;;){upleft; } /* reapply to args until DONE */
+
+ default: /* non combinator */
+ cycles--; /* oops! */
+ if(abnormal(e)) /* silly recursion */
+ { fprintf(stderr,"\nBLACK HOLE\n");
+ outstats();
+ exit(1); }
+
+ switch(tag[e])
+ { case STRCONS: e=pn_val(e); /* private name */
+ /*if(e==UNDEF||e==FREE)
+ fprintf(stderr,
+ "\nimpossible event in reduce - undefined pname\n"),
+ exit(1);
+ /* redundant test - remove when sure */
+ goto NEXTREDEX;
+ case DATAPAIR: /* datapair(oldn,0)(fileinfo(filename,0))=>BOTTOM */
+ /* kludge for trapping inherited undefined name without
+ current alias - see code in load_defs */
+ upleft;
+ fprintf(stderr,
+ "\nUNDEFINED NAME (specified as \"%s\" in %s)\n",
+ (char *)hd[hd[e]],(char *)hd[lastarg]);
+ outstats();
+ exit(1);
+ case ID: if(id_val(e)==UNDEF||id_val(e)==FREE)
+ { fprintf(stderr,"\nUNDEFINED NAME - %s\n",get_id(e));
+ outstats();
+ exit(1); }
+ /* setcell(AP,I,id_val(e)); /* overwrites error-info */
+ e=id_val(e); /* could be eager in value */
+ goto NEXTREDEX;
+ default: fprintf(stderr,"\nimpossible tag (%d) in reduce\n",tag[e]);
+ exit(1);
+ case CONSTRUCTOR: for(;;){upleft; } /* reapply to args until DONE */
+ case STARTREADVALS:
+ /* readvals(0,t) file => READVALS (t:file) streamptr */
+ { char *fil;
+ upleft;
+ lastarg=reduce(lastarg); /* ### */
+ if(lastarg==OFFSIDE) /* special case, represents stdin */
+ { if(stdinuse&&stdinuse!='+')
+ { tag[e]=AP; hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ stdinuse='+';
+ hold=cons(tl[hd[e]],0),lastarg=(word)stdin; }
+ else
+ hold=cons(tl[hd[e]],lastarg),
+ lastarg=(word)fopen(fil=getstring(lastarg,"readvals"),"r");
+ if((FILE *)lastarg==NULL) /* cannot open file for reading */
+ /* { hd[e]=I; e=tl[e]=NIL; goto DONE; } */
+ { fprintf(stderr,"\nreadvals, cannot open: \"%s\"\n",fil);
+ outstats(); exit(1); }
+ hd[e]=ap(READVALS,hold); }
+ DOWNLEFT;
+ DOWNLEFT;
+ goto L_READVALS;
+ case ATOM: /* for(;;){upleft; } */
+ /* as above if there are constructors with tag ATOM
+ and +ve arity. Since there are none we could test
+ for missing combinators at this point. Thus
+ /*if(!abnormal(s))
+ fprintf(stderr,"\nreduce: unknown combinator "),
+ out(stderr,e), putc('\n',stderr),exit(1); */
+ case INT:
+ case UNICODE:
+ case DOUBLE:
+ case CONS:; /* all fall thru to DONE */
+ }
+
+ } /* end of decode switch */
+
+ DONE: /* sub task completed -- s is either BACKSTOP or a tailpointer */
+
+ if(s==BACKSTOP)
+ { /* whole expression now in hnf */
+#ifdef DEBUG
+ if(debug&02)printf("result= "),out(stdout,e),putchar('\n');
+ rdepth--;
+#endif
+ return(e); /* end of reduction */
+ /* outchar(hd[e]);
+ e=tl[e];
+ goto NEXTREDEX;
+ /* above shows how to incorporate printing into m/c */
+ }
+
+ /* otherwise deal with return from subtask */
+ UPRIGHT;
+ if(tag[e]==AP)
+ { /* we have just reduced argn of strict operator -- so now
+ we must reduce arg(n-1) */
+ DOWNLEFT;
+ DOWNRIGHT; /* there is a faster way to do this - see TRY */
+ goto NEXTREDEX;
+ }
+
+ /* only possible if mktlptr marks the cell rather than the field */
+/* if(e==BACKSTOP)
+ fprintf(stderr,"\nprogram error: BLACK HOLE2\n"),
+ outstats(),
+ exit(1); */
+
+ /* we are through reducing args of strict operator */
+ /* we can merge the following switch with the main one, if desired,
+ - in this case use the alternate definitions of READY and RESTORE
+ and replace the following switch by
+ /* e=READY(e); goto OPDECODE; */
+
+#ifdef DEBUG
+ if(debug&02){ printf("ready("); out(stdout,e); printf(")\n"); }
+#endif
+ switch(e) /* "ready" switch */
+ {
+/* case READY(MONOP):/* paradigm for execution of strict monadic operator
+ GETARG(arg1);
+ hd[e]=I; e=tl[e]=do_monop(arg1);
+ goto NEXTREDEX; */
+
+ case READY(I): /* I x => x */
+ UPLEFT;
+ e=lastarg;
+ goto NEXTREDEX;
+
+ case READY(SEQ): /* SEQ a b => b, a~=BOTTOM */
+ UPLEFT;
+ upleft;
+ hd[e]=I;e=lastarg;
+ goto NEXTREDEX;
+
+ case READY(FORCE): /* FORCE x => x, total x */
+ UPLEFT;
+ force(lastarg);
+ hd[e]=I;e=lastarg;
+ goto NEXTREDEX;
+
+ case READY(HD):
+ UPLEFT;
+ if(lastarg==NIL)
+ { fprintf(stderr,"\nATTEMPT TO TAKE hd OF []\n");
+ outstats(); exit(1); }
+ hd[e]=I; e=tl[e]=hd[lastarg];
+ goto NEXTREDEX;
+
+ case READY(TL):
+ UPLEFT;
+ if(lastarg==NIL)
+ { fprintf(stderr,"\nATTEMPT TO TAKE tl OF []\n");
+ outstats(); exit(1); }
+ hd[e]=I; e=tl[e]=tl[lastarg];
+ goto NEXTREDEX;
+
+ case READY(BODY):
+ /* BODY(k x1 .. xn) => k x1 ... x(n-1)
+ for arbitrary constructor k */
+ UPLEFT;
+ hd[e]=I; e=tl[e]=hd[lastarg];
+ goto NEXTREDEX;
+
+ case READY(LAST): /* LAST(k x1 .. xn) => xn
+ for arbitrary constructor k */
+ UPLEFT;
+ hd[e]=I; e=tl[e]=tl[lastarg];
+ goto NEXTREDEX;
+
+ case READY(TAKE):
+ GETARG(arg1);
+ upleft;
+ if(tag[arg1]!=INT)word_error("take");
+ { long long n=get_word(arg1);
+ if(n<=0||(lastarg=reduce(lastarg))==NIL) /* ### */
+ { simpl(NIL); goto DONE; }
+ setcell(CONS,hd[lastarg],ap2(TAKE,sto_word(n-1),tl[lastarg])); }
+ goto DONE;
+
+ case READY(FILEMODE): /* FILEMODE string => string'
+ (see filemode in manual) */
+ UPLEFT;
+ if(!stat(getstring(lastarg,"filemode"),&buf))
+ { mode_t mode=buf.st_mode;
+ word d=S_ISDIR(mode)?'d':'-';
+ word perm= buf.st_uid==geteuid()?(mode&0700)>>6:
+ buf.st_gid==getegid()?(mode&070)>>3:
+ mode&07;
+ word r=perm&04?'r':'-',w=perm&02?'w':'-',x=perm&01?'x':'-';
+ setcell(CONS,d,cons(r,cons(w,cons(x,NIL))));
+ }
+ else hd[e]=I,e=tl[e]=NIL;
+ goto DONE;
+
+ case READY(FILESTAT): /* FILESTAT string => ((inode,dev),mtime) */
+ UPLEFT;
+ /* Notes:
+ Non-existent file has conventional ((inode,dev),mtime) of ((0,-1),0)
+ We assume time_t can be stored in int field, this may not port */
+ if(!stat(getstring(lastarg,"filestat"),&buf))
+ setcell(CONS,cons(sto_word(buf.st_ino),
+ sto_word(buf.st_dev) ),
+ sto_word(buf.st_mtime) );
+ else setcell(CONS,cons(stosmallint(0),
+ stosmallint(-1) ),
+ stosmallint(0) );
+ goto DONE;
+
+ case READY(GETENV): /* GETENV string => string'
+ (see man (2) getenv) */
+ UPLEFT;
+ { char *a = getstring(lastarg,"getenv");
+ unsigned char *p = getenv(a);
+ hold = NIL;
+ if(p){ word i;
+ unsigned char *q=p, *r=p;
+ if(UTF8)
+ { while(*r) /* compress to Latin-1 in situ */
+ if(*r>127) /* start of multibyte */
+ if((*r==194||*r==195)&&r[1]>=128&&r[1]<=191) /* Latin-1 */
+ *q= *r==194?r[1]:r[1]+64, q++, r+=2;
+ else getenv_error(a),
+ /* or silently accept errors here? */
+ *q++=*r++;
+ else *q++=*r++;
+ *q='\0';
+ }
+ /* convert p to list */
+ i = strlen(p);
+ while(i--)hold=cons(p[i],hold);
+ }
+ }
+ hd[e]=I; e=tl[e]=hold;
+ goto DONE;
+
+ case READY(EXEC): /* EXEC string
+ fork off a process to execute string as a
+ shell command, returning (via pipes) the
+ triple (stdout,stderr,exit_status)
+ convention: if fork fails, exit status is -1 */
+ UPLEFT;
+ { word pid=(-1),fd[2],fd_a[2];
+ char *cp=getstring(lastarg,"system");
+ /* pipe(fd) should return 0, -1 means fail */
+ /* fd_a is 2nd pipe, for error messages */
+ if(pipe(fd)==(-1)||pipe(fd_a)==(-1)||(pid=fork()))
+ { /* parent (reader) */
+ FILE *fp,*fp_a;
+ if(pid!= -1)
+ close(fd[1]),
+ close(fd_a[1]),
+ fp=(FILE *)fdopen(fd[0],"r"),
+ fp_a=(FILE *)fdopen(fd_a[0],"r");
+ if(pid== -1||!fp||!fp_a)
+ setcell(CONS,NIL,cons(piperrmess(pid),sto_word(-1))); else
+ setcell(CONS,ap(READ,fp),cons(ap(READ,fp_a),ap(WAIT,pid)));
+ }
+ else { /* child (writer) */
+ word in;
+ static char *shell="/bin/sh";
+ dup2(fd[1],1); /* so pipe replaces stdout */
+ dup2(fd_a[1],2); /* 2nd pipe replaces stderr */
+ close(fd[1]);
+ close(fd[0]);
+ close(fd_a[1]);
+ close(fd_a[0]);
+ fclose(stdin); /* anti side-effect measure */
+ execl(shell,shell,"-c",cp,(char *)0);
+ }
+ }
+ goto DONE;
+
+ case READY(NUMVAL): /* NUMVAL numeral => number */
+ UPLEFT;
+ { word x=lastarg;
+ word base=10;
+ while(x!=NIL)
+ hd[x]=reduce(hd[x]), /* ### */
+ x=tl[x]=reduce(tl[x]); /* ### */
+ while(lastarg!=NIL&&isspace(hd[lastarg]))lastarg=tl[lastarg];
+ x=lastarg;
+ if(x!=NIL&&hd[x]=='-')x=tl[x];
+ if(hd[x]=='0'&&tl[x]!=NIL)
+ switch(tolower(hd[tl[x]]))
+ { case 'o':
+ base=8;
+ x=tl[tl[x]];
+ while(x!=NIL&&isodigit(hd[x]))x=tl[x];
+ break;
+ case 'x':
+ base=16;
+ x=tl[tl[x]];
+ while(x!=NIL&&isxdigit(hd[x]))x=tl[x];
+ break;
+ default: goto L;
+ }
+ else L: while(x!=NIL&&isdigit(hd[x]))x=tl[x];
+ if(x==NIL)
+ hd[e]=I,e=tl[e]=strtobig(lastarg,base);
+ else { char *p=linebuf;
+ double d; char junk=0;
+ x=lastarg;
+ while(x!=NIL&&p-linebuf<BUFSIZE-1) *p++ = hd[x], x=tl[x];
+ *p++ ='\0';
+ if(p-linebuf>60||sscanf(linebuf,"%lf%c",&d,&junk)!=1||junk)
+ { fprintf(stderr,"\nbad arg for numval: \"%s\"\n",linebuf);
+ outstats();
+ exit(1); }
+ else hd[e]=I,e=tl[e]=sto_dbl(d); }
+ goto DONE; }
+
+ case READY(STARTREAD): /* STARTREAD filename => READ streamptr */
+ UPLEFT;
+ { char *fil;
+ lastarg = (word)fopen(fil=getstring(lastarg,"read"),"r");
+ if((FILE *)lastarg==NULL) /* cannot open file for reading */
+ /* { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ /* could just return empty contents */
+ { fprintf(stderr,"\nread, cannot open: \"%s\"\n",fil);
+ outstats(); exit(1); }
+ hd[e]=READ;
+ DOWNLEFT; }
+ goto L_READ;
+
+ case READY(STARTREADBIN): /* STARTREADBIN filename => READBIN streamptr */
+ UPLEFT;
+ { char *fil;
+ lastarg = (word)fopen(fil=getstring(lastarg,"readb"),"r");
+ if((FILE *)lastarg==NULL) /* cannot open file for reading */
+ /* { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ /* could just return empty contents */
+ { fprintf(stderr,"\nreadb, cannot open: \"%s\"\n",fil);
+ outstats(); exit(1); }
+ hd[e]=READBIN;
+ DOWNLEFT; }
+ goto L_READBIN;
+
+ case READY(TRY): /* TRY FAIL y => y
+ TRY other y => other */
+ GETARG(arg1);
+ UPLEFT;
+ if(arg1==FAIL)
+ { hd[e]=I; e=lastarg; goto NEXTREDEX; }
+ if(S<=(hold=head(arg1))&&hold<=ERROR)
+ /* function - other than unsaturated constructor */
+ goto DONE;/* nb! else may take premature decision(interacts with MOD1)*/
+ hd[e]=I;
+ e=tl[e]=arg1;
+ goto NEXTREDEX;
+
+ case READY(COND): /* COND True => K
+ COND False => KI */
+ UPLEFT;
+ hd[e]=I;
+ if(lastarg==True)
+ { e=tl[e]=K; goto L_K; }
+ else { e=tl[e]=KI; goto L_KI; }
+ /* goto OPDECODE; /* to speed up we have set extra labels */
+
+ /* alternative rules /* COND True x => K x
+ COND False x => I */
+
+ case READY(APPEND): /* APPEND NIL y => y
+ APPEND (a:x) y => a:APPEND x y */
+ GETARG(arg1);
+ upleft;
+ if(arg1==NIL)
+ { hd[e]=I,e=lastarg; goto NEXTREDEX; }
+ setcell(CONS,hd[arg1],ap2(APPEND,tl[arg1],lastarg));
+ goto DONE;
+
+ case READY(AND): /* AND True => I
+ AND False => K False */
+ UPLEFT;
+ if(lastarg==True){ e=I; goto L_I; }
+ else { hd[e]=K,DOWNLEFT; goto L_K; }
+
+ case READY(OR): /* OR True => K True
+ OR False => I */
+ UPLEFT;
+ if(lastarg==True){ hd[e]=K; DOWNLEFT; goto L_K; }
+ else { e=I; goto L_I; }
+
+ /* alternative rules ?? /* AND True y => y
+ AND False y => False
+ OR True y => True
+ OR False y => y */
+
+ case READY(NOT): /* NOT True => False
+ NOT False => True */
+ UPLEFT;
+ hd[e]=I; e=tl[e]=lastarg==True?False:True;
+ goto DONE;
+
+ case READY(NEG): /* NEG x => -x, if x is a number */
+ UPLEFT;
+ if(tag[lastarg]==INT)simpl(bignegate(lastarg));
+ else setdbl(e,-get_dbl(lastarg));
+ goto DONE;
+
+ case READY(CODE): /* miranda char to int type-conversion */
+ UPLEFT;
+ simpl(make(INT,get_char(lastarg),0));
+ goto DONE;
+
+ case READY(DECODE): /* int to char type conversion */
+ UPLEFT;
+ if(tag[lastarg]==DOUBLE)word_error("decode");
+ long long val=get_word(lastarg);
+ if(val<0||val>UMAX)
+ { fprintf(stderr,"\nCHARACTER OUT-OF-RANGE decode(%d)\n",val);
+ outstats();
+ exit(1); }
+ hd[e]=I; e=tl[e]=sto_char(val);
+ goto DONE;
+
+ case READY(INTEGER): /* predicate on numbers */
+ UPLEFT;
+ hd[e]=I; e=tl[e]=tag[lastarg]==INT?True:False;
+ goto NEXTREDEX;
+
+ case READY(SHOWNUM): /* SHOWNUM number => numeral */
+ UPLEFT;
+ if(tag[lastarg]==DOUBLE)
+ { double x=get_dbl(lastarg);
+#ifndef RYU
+ sprintf(linebuf,"%.16g",x);
+ char *p=linebuf;
+ while isdigit(*p)p++; /* add .0 to false integer */
+ if(!*p)*p++='.',*p++='0',*p='\0';
+ hd[e]=I; e=tl[e]=str_conv(linebuf); }
+#else
+ d2s_buffered(x,linebuf);
+ arg1=str_conv(linebuf);
+ if(*linebuf=='.')arg1=cons('0',arg1);
+ if(*linebuf=='-'&&linebuf[1]=='.')arg1=cons('-',cons('0',tl[arg1]));
+ hd[e]=I; e=tl[e]=arg1; }
+#endif
+ else simpl(bigtostr(lastarg));
+ goto DONE;
+
+ case READY(SHOWHEX):
+ UPLEFT;
+ if(tag[lastarg]==DOUBLE)
+ { sprintf(linebuf,"%a",get_dbl(lastarg));
+ hd[e]=I; e=tl[e]=str_conv(linebuf); }
+ else simpl(bigtostrx(lastarg));
+ goto DONE;
+
+ case READY(SHOWOCT):
+ UPLEFT;
+ if(tag[lastarg]==DOUBLE)word_error("showoct");
+ else simpl(bigtostr8(lastarg));
+ goto DONE;
+
+ /* paradigm for strict monadic arithmetic fns */
+ case READY(ARCTAN_FN): /* atan */
+ UPLEFT;
+ errno=0; /* to clear */
+ setdbl(e,atan(force_dbl(lastarg)));
+ if(errno)math_error("atan");
+ goto DONE;
+
+ case READY(EXP_FN): /* exp */
+ UPLEFT;
+ errno=0; /* to clear */
+ setdbl(e,exp(force_dbl(lastarg)));
+ if(errno)math_error("exp");
+ goto DONE;
+
+ case READY(ENTIER_FN): /* floor */
+ UPLEFT;
+ if(tag[lastarg]==INT)simpl(lastarg);
+ else simpl(dbltobig(get_dbl(lastarg)));
+ goto DONE;
+
+ case READY(LOG_FN): /* log */
+ UPLEFT;
+ if(tag[lastarg]==INT)setdbl(e,biglog(lastarg));
+ else { errno=0; /* to clear */
+ fa=force_dbl(lastarg);
+ setdbl(e,log(fa));
+ if(errno)math_error("log"); }
+ goto DONE;
+
+ case READY(LOG10_FN): /* log10 */
+ UPLEFT;
+ if(tag[lastarg]==INT)setdbl(e,biglog10(lastarg));
+ else { errno=0; /* to clear */
+ fa=force_dbl(lastarg);
+ setdbl(e,log10(fa));
+ if(errno)math_error("log10"); }
+ goto DONE;
+
+ case READY(SIN_FN): /* sin */
+ UPLEFT;
+ errno=0; /* to clear */
+ setdbl(e,sin(force_dbl(lastarg)));
+ if(errno)math_error("sin");
+ goto DONE;
+
+ case READY(COS_FN): /* cos */
+ UPLEFT;
+ errno=0; /* to clear */
+ setdbl(e,cos(force_dbl(lastarg)));
+ if(errno)math_error("cos");
+ goto DONE;
+
+ case READY(SQRT_FN): /* sqrt */
+ UPLEFT;
+ fa=force_dbl(lastarg);
+ if(fa<0.0)math_error("sqrt");
+ setdbl(e,sqrt(fa));
+ goto DONE;
+
+/* case READY(DIOP):/* paradigm for execution of strict diadic operator
+ RESTORE(e); /* do not write modified form of operator back into graph
+ GETARG(arg1);
+ GETARG(arg2);
+ hd[e]=I; e=tl[e]=diop(arg1,arg2);
+ goto NEXTREDEX; */
+
+/* case READY(EQUAL): /* UNUSED
+ RESTORE(e);
+ GETARG(arg1);
+ GETARG(arg2);
+ if(isap(arg1)&&hd[arg1]!=NUMBER&&isap(arg2)&&hd[arg2]!=NUMBER)
+ { /* recurse on components
+ hd[e]=ap2(EQUAL,tl[arg1],tl[arg2]);
+ hd[e]=ap3(EQUAL,hd[arg1],hd[arg2],hd[e]);
+ tl[e]=False;
+ }
+ else { hd[e]=I; e=tl[e]= (eqatom(arg1,arg2)?True:False); }
+ goto NEXTREDEX; */
+
+ case READY(ZIP): /* ZIP (a:x) (b:y) => (a,b) : ZIP x y
+ ZIP x y => [] */
+ RESTORE(e);
+ GETARG(arg1);
+ GETARG(arg2);
+ if(arg1==NIL||arg2==NIL)
+ { hd[e]=I; e=tl[e]=NIL; goto DONE; }
+ setcell(CONS,cons(hd[arg1],hd[arg2]),ap2(ZIP,tl[arg1],tl[arg2]));
+ goto DONE;
+
+ case READY(EQ): /* EQ x x => True
+ EQ x y => False
+ see definition of function "compare" above */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=I; e=tl[e]=compare(arg1,lastarg)?False:True; /* ### */
+ goto DONE;
+
+ case READY(NEQ): /* NEQ x x => False
+ NEQ x y => True
+ see definition of function "compare" above */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=I; e=tl[e]=compare(arg1,lastarg)?True:False; /* ### */
+ goto DONE;
+
+ case READY(GR):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=I; e=tl[e]=compare(arg1,lastarg)>0?True:False; /* ### */
+ goto DONE;
+
+ case READY(GRE):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=I; e=tl[e]=compare(arg1,lastarg)>=0?True:False; /* ### */
+ goto DONE;
+
+ case READY(PLUS):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE)
+ setdbl(e,get_dbl(arg1)+force_dbl(lastarg)); else
+ if(tag[lastarg]==DOUBLE)
+ setdbl(e,bigtodbl(arg1)+get_dbl(lastarg));
+ else simpl(bigplus(arg1,lastarg));
+ goto DONE;
+
+ case READY(MINUS):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE)
+ setdbl(e,get_dbl(arg1)-force_dbl(lastarg)); else
+ if(tag[lastarg]==DOUBLE)
+ setdbl(e,bigtodbl(arg1)-get_dbl(lastarg));
+ else simpl(bigsub(arg1,lastarg));
+ goto DONE;
+
+ case READY(TIMES):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE)
+ setdbl(e,get_dbl(arg1)*force_dbl(lastarg)); else
+ if(tag[lastarg]==DOUBLE)
+ setdbl(e,bigtodbl(arg1)*get_dbl(lastarg));
+ else simpl(bigtimes(arg1,lastarg));
+ goto DONE;
+
+ case READY(INTDIV):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE||tag[lastarg]==DOUBLE)word_error("div");
+ if(bigzero(lastarg))div_error(); /* build into bigmod ? */
+ simpl(bigdiv(arg1,lastarg));
+ goto DONE;
+
+ case READY(FDIV):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ /* experiment, suppressed
+ if(tag[lastarg]==INT&&tag[arg1]==INT&&!bigzero(lastarg))
+ { extern int b_rem;
+ int d = bigdiv(arg1,lastarg);
+ if(bigzero(b_rem)){ simpl(d); goto DONE; }
+ } /* makes a/b integer if a, b integers dividing exactly */
+ fa=force_dbl(arg1);
+ fb=force_dbl(lastarg);
+ if(fb==0.0)div_error();
+ setdbl(e,fa/fb);
+ goto DONE;
+
+ case READY(MOD):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE||tag[lastarg]==DOUBLE)word_error("mod");
+ if(bigzero(lastarg))div_error(); /* build into bigmod ? */
+ simpl(bigmod(arg1,lastarg));
+ goto DONE;
+
+ case READY(POWER):
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[lastarg]==DOUBLE)
+ { fa=force_dbl(arg1);
+ if(fa<0.0)errno=EDOM,math_error("^");
+ fb=get_dbl(lastarg); }else
+ if(tag[arg1]==DOUBLE)
+ fa=get_dbl(arg1),fb=bigtodbl(lastarg); else
+ if(neg(lastarg))
+ fa=bigtodbl(arg1),fb=bigtodbl(lastarg);
+ else { simpl(bigpow(arg1,lastarg));
+ goto DONE; }
+ errno=0; /* to clear */
+ setdbl(e,pow(fa,fb));
+ if(errno)math_error("power");
+ goto DONE;
+
+ case READY(SHOWSCALED): /* SHOWSCALED precision number => numeral */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE)
+ word_error("showscaled");
+ arg1=getsmallint(arg1);
+ (void)sprintf(linebuf,"%.*e",arg1,force_dbl(lastarg));
+ hd[e]=I; e=tl[e]=str_conv(linebuf);
+ goto DONE;
+
+ case READY(SHOWFLOAT): /* SHOWFLOAT precision number => numeral */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(tag[arg1]==DOUBLE)
+ word_error("showfloat");
+ arg1=getsmallint(arg1);
+ (void)sprintf(linebuf,"%.*f",arg1,force_dbl(lastarg));
+ hd[e]=I; e=tl[e]=str_conv(linebuf);
+ goto DONE;
+
+#define coerce_dbl(x) tag[x]==DOUBLE?(x):sto_dbl(bigtodbl(x))
+
+ case READY(STEP): /* STEP i a => GENSEQ (i,NIL) a */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ hd[e]=ap(GENSEQ,cons(arg1,NIL));
+ goto NEXTREDEX;
+
+ case READY(MERGE): /* MERGE [] y => y
+ MERGE (a:x) [] => a:x
+ MERGE (a:x) (b:y) => a:MERGE x (b:y), if a<=b
+ => b:MERGE (a:x) y, otherwise */
+ RESTORE(e);
+ GETARG(arg1);
+ UPLEFT;
+ if(arg1==NIL)simpl(lastarg); else
+ if(lastarg==NIL)simpl(arg1); else
+ if(compare(hd[arg1]=reduce(hd[arg1]),
+ hd[lastarg]=reduce(hd[lastarg]))<=0) /* ### */
+ setcell(CONS,hd[arg1],ap2(MERGE,tl[arg1],lastarg));
+ else setcell(CONS,hd[lastarg],ap2(MERGE,tl[lastarg],arg1));
+ goto DONE;
+
+ case READY(STEPUNTIL): /* STEPUNTIL i a b => GENSEQ (i,b) a */
+ RESTORE(e);
+ GETARG(arg1);
+ GETARG(arg2);
+ UPLEFT;
+ hd[e]=ap(GENSEQ,cons(arg1,arg2));
+ if(tag[arg1]==INT?poz(arg1):get_dbl(arg1)>=0.0)
+ tag[tl[hd[e]]]=AP; /* hack to record sign of step - see GENSEQ */
+ goto NEXTREDEX;
+
+ case READY(Ush):
+ /* Ush (k f1...fn) p (k x1...xn)
+ => "k"++' ':f1 x1 ...++' ':fn xn, p='\0'
+ => "(k"++' ':f1 x1 ...++' ':fn xn++")", p='\1'
+ Ush (k f1...fn) p other => FAIL */
+ RESTORE(e);
+ GETARG(arg1);
+ GETARG(arg2);
+ GETARG(arg3);
+ if(constr_tag(head(arg1))!=constr_tag(head(arg3)))
+ { hd[e]=I;
+ e=tl[e]=FAIL;
+ goto DONE; } /* result is string, so cannot be more args */
+ if(tag[arg1]==CONSTRUCTOR) /* don't parenthesise atom */
+ { hd[e]=I;
+ if(suppressed(arg1))
+ e=tl[e]=str_conv("<unprintable>");
+ else e=tl[e]=str_conv(constr_name(arg1));
+ goto DONE; }
+ hold=arg2?cons(')',NIL):NIL;
+ while(tag[arg1]!=CONSTRUCTOR)
+ hold=cons(' ',ap2(APPEND,ap(tl[arg1],tl[arg3]),hold)),
+ arg1=hd[arg1],arg3=hd[arg3];
+ if(suppressed(arg1))
+ { hd[e]=I; e=tl[e]=str_conv("<unprintable>"); goto DONE; }
+ hold=ap2(APPEND,str_conv(constr_name(arg1)),hold);
+ if(arg2)
+ { setcell(CONS,'(',hold); goto DONE; }
+ else { hd[e]=I; e=tl[e]=hold; goto NEXTREDEX; }
+
+ default: fprintf(stderr,"\nimpossible event in reduce ("),
+ out(stderr,e),fprintf(stderr,")\n"),
+ exit(1);
+ return(0); /* proforma only - unreachable */
+ } /* end of "ready" switch */
+
+} /* end of reduce */
+
+memclass(c,x) /* is char c in list x (may include ranges) */
+{ while(x!=NIL)
+ { if(hd[x]==DOTDOT)
+ { x=tl[x];
+ if(hd[x]<=c&&c<=hd[tl[x]])return(1);
+ x=tl[x]; }
+ else if(c==hd[x])return(1);
+ x=tl[x]; }
+ return(0);
+}
+
+lexfail(x) /* x is known to be a non-empty string (see LEX_RPT) */
+{ word i=24;
+ fprintf(stderr,"\nLEX FAILS WITH UNRECOGNISED INPUT: \"");
+ while(i--&&x!=NIL&&0<=lh(x)&&lh(x)<=255)
+ fprintf(stderr,"%s",charname(lh(x))),
+ x=tl[x];
+ fprintf(stderr,"%s\"\n",x==NIL?"":"...");
+ outstats();
+ exit(1);
+}
+
+lexstate(x) /* extracts initial state info from list of chars labelled
+ by LEX_COUNT - x is evaluated and known to be non-empty */
+{ x = hd[hd[x]]; /* count field of first char */
+ return(cons(sto_word(x>>8),stosmallint(x&255)));
+}
+
+piperrmess(pid)
+word pid;
+{ return(str_conv(pid== -1?"cannot create process\n":"cannot open pipe\n"));
+}
+
+g_residue(toks2) /* remainder of token stream from last token examined */
+word toks2;
+{ word toks1 = NIL;
+ if(tag[toks2]!=CONS)
+ { if(tag[toks2]==AP&&hd[toks2]==I&&tl[toks2]==NIL)
+ return(cons(NIL,NIL));
+ return(cons(NIL,toks2)); /*no tokens examined, whole grammar is `error'*/
+ /* fprintf(stderr,"\nimpossible event in g_residue\n"),
+ exit(1); /* grammar fn must have examined >=1 tokens */ }
+ while(tag[tl[toks2]]==CONS)toks1=cons(hd[toks2],toks1),toks2=tl[toks2];
+ if(tl[toks2]==NIL||tag[tl[toks2]]==AP&&hd[tl[toks2]]==I&&tl[tl[toks2]]==NIL)
+ { toks1=cons(hd[toks2],toks1);
+ return(cons(ap(DESTREV,toks1),NIL)); }
+ return(cons(ap(DESTREV,toks1),toks2));
+}
+
+numplus(x,y)
+word x,y;
+{ if(tag[x]==DOUBLE)
+ return(sto_dbl(get_dbl(x)+force_dbl(y)));
+ if(tag[y]==DOUBLE)
+ return(sto_dbl(bigtodbl(x)+get_dbl(y)));
+ return(bigplus(x,y));
+}
+
+fn_error(s)
+char *s;
+{ fprintf(stderr,"\nprogram error: %s\n",s);
+ outstats();
+ exit(1); }
+
+getenv_error(char *a)
+{ fprintf(stderr,
+ "program error: getenv(%s): illegal characters in result string\n",a);
+ outstats();
+ exit(1); }
+
+subs_error()
+{ fn_error("subscript out of range");
+}
+
+div_error()
+{ fn_error("attempt to divide by zero");
+}
+/* other arithmetic exceptions signal-trapped by fpe_error - see STEER */
+
+math_error(s)
+char *s;
+{ fprintf(stderr,"\nmath function %serror (%s)\n",
+ errno==EDOM?"domain ":errno==ERANGE?"range ":"",s);
+ outstats();
+ exit(1);
+}
+
+word_error(s)
+char *s;
+{ fprintf(stderr,
+ "\nprogram error: fractional number where integer expected (%s)\n",s);
+ outstats();
+ exit(1);
+}
+
+char *stdname(c)
+word c;
+{ return c==':' ? "$:-" : c=='-' ? "$-" : "$+"; }
+
+stdin_error(c)
+word c;
+{ if(stdinuse==c)
+ fprintf(stderr,"program error: duplicate use of %s\n",stdname(c));
+ else fprintf(stderr,"program error: simultaneous use of %s and %s\n",
+ stdname(c), stdname(stdinuse));
+ outstats();
+ exit(1);
+}
+
+#ifdef BSDCLOCK
+#include <sys/times.h>
+#include <unistd.h>
+#ifndef CLK_TCK
+#define CLK_TCK sysconf(_SC_CLK_TCK)
+#endif
+#else
+/* this is ANSII C, POSIX */
+#include <time.h>
+clock_t start, end;
+#endif
+
+initclock()
+{
+#ifndef BSDCLOCK
+start=clock();
+#endif
+}
+
+out_here(f,h,nl) /* h is fileinfo(scriptname,line_no) */
+FILE *f;
+word h,nl;
+{ extern word errs;
+ if(tag[h]!=FILEINFO)
+ { fprintf(stderr,"(impossible event in outhere)\n"); return; }
+ fprintf(f,"(line %3d of \"%s\")",tl[h],(char *)hd[h]);
+ if(nl)putc('\n',f); else putc(' ',f);
+ if(compiling&&!errs)errs=h; /* relevant only when called from steer.c */
+} /* `soft' error, set errs rather than errline, so not saved in dump */
+
+outstats()
+{ extern long claims,nogcs;
+ extern word atcount;
+ extern long long cellcount;
+#ifdef BSDCLOCK
+ struct tms buffer;
+#endif
+#ifdef HISTO
+ if(sourcemc)printhisto();
+#endif
+ if(!atcount)return;
+#ifdef BSDCLOCK
+ times(&buffer);
+#else
+ end=clock();
+#endif
+ printf("||");
+ printf("reductions = %lld, cells claimed = %lld, ",
+ cycles,cellcount+claims);
+ printf("no of gc's = %ld, cpu = %0.2f",nogcs,
+#ifdef BSDCLOCK
+ buffer.tms_utime/(CLK_TCK*1.0));
+#else
+ ((double) (end - start)) / CLOCKS_PER_SEC);
+#endif
+ putchar('\n');
+#ifdef DEBUG
+ printf("||maxr_depth=%d\n",maxrdepth);
+#endif
+}
+
+/* end of MIRANDA REDUCE */
+
diff --git a/new/rules.y b/new/rules.y
new file mode 100644
index 0000000..e44698b
--- /dev/null
+++ b/new/rules.y
@@ -0,0 +1,1686 @@
+/* Miranda token declarations and syntax rules for "YACC" */
+
+/**************************************************************************
+ * 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. *
+ *------------------------------------------------------------------------*/
+
+/* miranda symbols */
+
+%token VALUE EVAL WHERE IF TO LEFTARROW COLONCOLON COLON2EQ
+ TYPEVAR NAME CNAME CONST DOLLAR2 OFFSIDE ELSEQ
+ ABSTYPE WITH DIAG EQEQ FREE INCLUDE EXPORT TYPE
+ OTHERWISE SHOWSYM PATHNAME BNF LEX ENDIR ERRORSY ENDSY
+ EMPTYSY READVALSY LEXDEF CHARCLASS ANTICHARCLASS LBEGIN
+
+%right ARROW
+%right PLUSPLUS ':' MINUSMINUS
+%nonassoc DOTDOT
+%right VEL
+%right '&'
+%nonassoc '>' GE '=' NE LE '<'
+%left '+' '-'
+%left '*' '/' REM DIV
+%right '^'
+%left '.' /* fiddle to make '#' behave */
+%left '!'
+%right INFIXNAME INFIXCNAME
+%token CMBASE /* placeholder to start combinator values - see combs.h */
+
+%{
+/* the following definition has to be kept in line with the token declarations
+ above */
+char *yysterm[]= {
+ 0,
+ "VALUE",
+ "EVAL",
+ "where",
+ "if",
+ "&>",
+ "<-",
+ "::",
+ "::=",
+ "TYPEVAR",
+ "NAME",
+ "CONSTRUCTOR-NAME",
+ "CONST",
+ "$$",
+ "OFFSIDE",
+ "OFFSIDE =",
+ "abstype",
+ "with",
+ "//",
+ "==",
+ "%free",
+ "%include",
+ "%export",
+ "type",
+ "otherwise",
+ "show",
+ "PATHNAME",
+ "%bnf",
+ "%lex",
+ "%%",
+ "error",
+ "end",
+ "empty",
+ "readvals",
+ "NAME",
+ "`char-class`",
+ "`char-class`",
+ "%%begin",
+ "->",
+ "++",
+ "--",
+ "..",
+ "\\/",
+ ">=",
+ "~=",
+ "<=",
+ "mod",
+ "div",
+ "$NAME",
+ "$CONSTRUCTOR"};
+
+%}
+
+/* Miranda syntax rules */
+/* the associated semantic actions perform the compilation */
+
+%{
+#include "data.h"
+#include "lex.h"
+extern word nill,k_i,Void;
+extern word message,standardout;
+extern word big_one;
+#define isltmess_t(t) (islist_t(t)&&tl[t]==message)
+#define isstring_t(t) (islist_t(t)&&tl[t]==char_t)
+extern word SYNERR,errs,echoing,gvars;
+extern word listdiff_fn,indent_fn,outdent_fn;
+extern word polyshowerror;
+word lastname=0;
+word suppressids=NIL;
+word idsused=NIL;
+word tvarscope=0;
+word includees=NIL,embargoes=NIL,exportfiles=NIL,freeids=NIL,exports=NIL;
+word lexdefs=NIL,lexstates=NIL,inlex=0,inexplist=0;
+word inbnf=0,col_fn=0,fnts=NIL,eprodnts=NIL,nonterminals=NIL,sreds=0;
+word ihlist=0,ntspecmap=NIL,ntmap=NIL,lasth=0;
+word obrct=0;
+
+void evaluate(x)
+word x;
+{ extern word debug;
+ word t;
+ t=type_of(x);
+ if(t==wrong_t)return;
+ lastexp=x;
+ x=codegen(x);
+ if(polyshowerror)return;
+ if(process())
+ /* setup new process for each evaluation */
+ { (void)signal(SIGINT,(sighandler)dieclean);
+ /* if interrupted will flush output etc before going */
+ compiling=0;
+ resetgcstats();
+ output(isltmess_t(t)?x:
+ cons(ap(standardout,isstring_t(t)?x
+ :ap(mkshow(0,0,t),x)),NIL));
+ (void)signal(SIGINT,SIG_IGN);/* otherwise could do outstats() twice */
+ putchar('\n');
+ outstats();
+ exit(0); }
+}
+
+void obey(x) /* like evaluate but no fork, no stats, no extra '\n' */
+word x;
+{ word t=type_of(x);
+ x=codegen(x);
+ if(polyshowerror)return;
+ compiling=0;
+ output(isltmess_t(t)?x:
+ cons(ap(standardout,isstring_t(t)?x:ap(mkshow(0,0,t),x)),NIL));
+}
+
+int isstring(x)
+word x;
+{ return(x==NILS||tag[x]==CONS&&is_char(hd[x]));
+}
+
+word compose(x) /* used in compiling 'cases' */
+word x;
+{ word y=hd[x];
+ if(hd[y]==OTHERWISE)y=tl[y]; /* OTHERWISE was just a marker - lose it */
+ else y=tag[y]==LABEL?label(hd[y],ap(tl[y],FAIL)):
+ ap(y,FAIL); /* if all guards false result is FAIL */
+ x = tl[x];
+ if(x!=NIL)
+ { while(tl[x]!=NIL)y=label(hd[hd[x]],ap(tl[hd[x]],y)), x=tl[x];
+ y=ap(hd[x],y);
+ /* first alternative has no label - label of enclosing rhs applies */
+ }
+ return(y);
+}
+
+word starts(x) /* x is grammar rhs - returns list of nonterminals in start set */
+word x;
+{ L: switch(tag[x])
+ { case ID: return(cons(x,NIL));
+ case LABEL:
+ case LET:
+ case LETREC: x=tl[x]; goto L;
+ case AP: switch(hd[x])
+ { case G_SYMB:
+ case G_SUCHTHAT:
+ case G_RULE: return(NIL);
+ case G_OPT:
+ case G_FBSTAR:
+ case G_STAR: x=tl[x]; goto L;
+ default: if(hd[x]==outdent_fn)
+ { x=tl[x]; goto L; }
+ if(tag[hd[x]]==AP)
+ if(hd[hd[x]]==G_ERROR)
+ { x=tl[hd[x]]; goto L; }
+ if(hd[hd[x]]==G_SEQ)
+ { if(eprod(tl[hd[x]]))
+ return(UNION(starts(tl[hd[x]]),starts(tl[x])));
+ x=tl[hd[x]]; goto L; } else
+ if(hd[hd[x]]==G_ALT)
+ return(UNION(starts(tl[hd[x]]),starts(tl[x])));
+ else
+ if(hd[hd[x]]==indent_fn)
+ { x=tl[x]; goto L; }
+ }
+ default: return(NIL);
+ }
+}
+
+int eprod(x) /* x is grammar rhs - does x admit empty production? */
+word x;
+{ L: switch(tag[x])
+ { case ID: return(member(eprodnts,x));
+ case LABEL:
+ case LET:
+ case LETREC: x=tl[x]; goto L;
+ case AP: switch(hd[x])
+ { case G_SUCHTHAT:
+ case G_ANY:
+ case G_SYMB: return(0);
+ case G_RULE: return(1);
+ case G_OPT:
+ case G_FBSTAR:
+ case G_STAR: return(1);
+ default: if(hd[x]==outdent_fn)
+ { x=tl[x]; goto L; }
+ if(tag[hd[x]]==AP)
+ if(hd[hd[x]]==G_ERROR)
+ { x=tl[hd[x]]; goto L; }
+ if(hd[hd[x]]==G_SEQ)
+ return(eprod(tl[hd[x]])&&eprod(tl[x])); else
+ if(hd[hd[x]]==G_ALT)
+ return(eprod(tl[hd[x]])||eprod(tl[x]));
+ else
+ if(hd[hd[x]]==indent_fn)
+ { x=tl[x]; goto L; }
+ }
+ default: return(x==G_STATE||x==G_UNIT);
+ /* G_END is special case, unclear whether it counts as an e-prodn.
+ decide no for now, sort this out later */
+ }
+}
+
+word add_prod(d,ps,hr)
+word d,ps,hr;
+{ word p,n=dlhs(d);
+ for(p=ps;p!=NIL;p=tl[p])
+ if(dlhs(hd[p])==n)
+ if(dtyp(d)==undef_t&&dval(hd[p])==UNDEF)
+ { dval(hd[p])=dval(d); return(ps); } else
+ if(dtyp(d)!=undef_t&&dtyp(hd[p])==undef_t)
+ { dtyp(hd[p])=dtyp(d); return(ps); }
+ else
+ errs=hr,
+ printf(
+ "%ssyntax error: conflicting %s of nonterminal \"%s\"\n",
+ echoing?"\n":"",
+ dtyp(d)==undef_t?"definitions":"specifications",
+ get_id(n)),
+ acterror();
+ return(cons(d,ps));
+}
+/* clumsy - this algorithm is quadratic in number of prodns - fix later */
+
+word getloc(nt,prods) /* get here info for nonterminal */
+word nt,prods;
+{ while(prods!=NIL&&dlhs(hd[prods])!=nt)prods=tl[prods];
+ if(prods!=NIL)return(hd[dval(hd[prods])]);
+ return(0); /* should not happen, but just in case */
+}
+
+void findnt(nt) /* set errs to here info of undefined nonterminal */
+word nt;
+{ word p=ntmap;
+ while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p];
+ if(p!=NIL)
+ { errs=tl[hd[p]]; return; }
+ p=ntspecmap;
+ while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p];
+ if(p!=NIL)errs=tl[hd[p]];
+}
+
+#define isap2(fn,x) (tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==(fn))
+#define firstsymb(term) tl[hd[term]]
+
+void binom(rhs,x)
+/* performs the binomial optimisation on rhs of nonterminal x
+ x: x alpha1| ... | x alphaN | rest ||need not be in this order
+ ==>
+ x: rest (alpha1|...|alphaN)*
+*/
+word rhs,x;
+{ word *p= &tl[rhs]; /* rhs is of form label(hereinf, stuff) */
+ word *lastp=0,*holdrhs,suffix,alpha=NIL;
+ if(tag[*p]==LETREC)p = &tl[*p]; /* ignore trailing `where defs' */
+ if(isap2(G_ERROR,*p))p = &tl[hd[*p]];
+ holdrhs=p;
+ while(isap2(G_ALT,*p))
+ if(firstsymb(tl[hd[*p]])==x)
+ alpha=cons(tl[tl[hd[*p]]],alpha),
+ *p=tl[*p],p = &tl[*p];
+ else lastp=p,p = &tl[tl[*p]];
+ /* note each (G_ALT a b) except the outermost is labelled */
+ if(lastp&&firstsymb(*p)==x)
+ alpha=cons(tl[*p],alpha),
+ *lastp=tl[hd[*lastp]];
+ if(alpha==NIL)return;
+ suffix=hd[alpha],alpha=tl[alpha];
+ while(alpha!=NIL)
+ suffix=ap2(G_ALT,hd[alpha],suffix),
+ alpha=tl[alpha];
+ *holdrhs=ap2(G_SEQ,*holdrhs,ap(G_FBSTAR,suffix));
+}
+/* should put some labels on the alpha's - fix later */
+
+word getcol_fn()
+{ extern char *dicp,*dicq;
+ if(!col_fn)
+ strcpy(dicp,"bnftokenindentation"),
+ dicq=dicp+20,
+ col_fn=name();
+ return(col_fn);
+}
+
+void startbnf()
+{ ntspecmap=ntmap=nonterminals=NIL;
+ if(fnts==0)col_fn=0; /* reinitialise, a precaution */
+}
+
+word ih_abstr(x) /* abstract inherited attributes from grammar rule */
+word x;
+{ word ih=ihlist;
+ while(ih!=NIL) /* relies on fact that ihlist is reversed */
+ x=lambda(hd[ih],x),ih=tl[ih];
+ return(x);
+}
+
+int can_elide(x) /* is x of the form $1 applied to ih attributes in order? */
+word x;
+{ word ih;
+ if(ihlist)
+ for(ih=ihlist;ih!=NIL&&tag[x]==AP;ih=tl[ih],x=hd[x])
+ if(hd[ih]!=tl[x])return(0);
+ return(x==mkgvar(1));
+}
+
+int e_re(x) /* does regular expression x match empty string ? */
+{ L: if(tag[x]==AP)
+ { if(hd[x]==LEX_STAR||hd[x]==LEX_OPT)return(1);
+ if(hd[x]==LEX_STRING)return(tl[x]==NIL);
+ if(tag[hd[x]]!=AP)return(0);
+ if(hd[hd[x]]==LEX_OR)
+ { if(e_re(tl[hd[x]]))return(1);
+ x=tl[x]; goto L; } else
+ if(hd[hd[x]]==LEX_SEQ)
+ { if(!e_re(tl[hd[x]]))return(0);
+ x=tl[x]; goto L; } else
+ if(hd[hd[x]]==LEX_RCONTEXT)
+ { x=tl[hd[x]]; goto L; }
+ }
+ return(0);
+}
+
+%}
+
+%%
+
+entity: /* the entity to be parsed is either a definition script or an
+ expression (the latter appearing as a command line) */
+
+ error|
+
+ script
+ = { lastname=0; /* outstats(); */ }|
+ /* statistics not usually wanted after compilation */
+
+/* MAGIC exp '\n' script
+ = { lastexp=$2; }| /* change to magic scripts 19.11.2013 */
+
+ VALUE exp
+ = { lastexp=$2; }| /* next line of `$+' */
+
+ EVAL exp
+ = { if(!SYNERR&&yychar==0)
+ { evaluate($2); }
+ }|
+
+ EVAL exp COLONCOLON
+ /* boring problem - how to make sure no junk chars follow here?
+ likewise TO case -- trick used above doesn't work, yychar is
+ here always -1 Why? Too fiddly to bother with just now */
+ = { word t=type_of($2);
+ if(t!=wrong_t)
+ { lastexp=$2;
+ if(tag[$2]==ID&&id_type($2)==wrong_t)t=wrong_t;
+ out_type(t);
+ putchar('\n'); }
+ }|
+
+ EVAL exp TO
+ = { FILE *fil=NULL,*efil;
+ word t=type_of($2);
+ char *f=token(),*ef;
+ if(f)keep(f); ef=token(); /* wasteful of dic space, FIX LATER */
+ if(f){ fil= fopen(f,$3?"a":"w");
+ if(fil==NULL)
+ printf("cannot open \"%s\" for writing\n",f); }
+ else printf("filename missing after \"&>\"\n");
+ if(ef)
+ { efil= fopen(ef,$3?"a":"w");
+ if(efil==NULL)
+ printf("cannot open \"%s\" for writing\n",ef); }
+ if(t!=wrong_t)$2=codegen(lastexp=$2);
+ if(polyshowerror)return;
+ if(t!=wrong_t&&fil!=NULL&&(!ef||efil))
+ { word pid;/* launch a concurrent process to perform task */
+ sighandler oldsig;
+ oldsig=signal(SIGINT,SIG_IGN); /* ignore interrupts */
+ if(pid=fork())
+ { /* "parent" */
+ if(pid==-1)perror("cannot create process");
+ else printf("process %d\n",pid);
+ fclose(fil);
+ if(ef)fclose(efil);
+ (void)signal(SIGINT,oldsig); }else
+ { /* "child" */
+ (void)signal(SIGQUIT,SIG_IGN); /* and quits */
+#ifndef SYSTEM5
+ (void)signal(SIGTSTP,SIG_IGN); /* and stops */
+#endif
+ close(1); dup(fileno(fil)); /* subvert stdout */
+ close(2); dup(fileno(ef?efil:fil)); /* subvert stderr */
+ /* FUNNY BUG - if redirect stdout stderr to same file by two
+ calls to freopen, their buffers get conflated - whence do
+ by subverting underlying file descriptors, as above
+ (fix due to Martin Guy) */
+ /* formerly used dup2, but not present in system V */
+ fclose(stdin);
+ /* setbuf(stdout,NIL);
+ /* not safe to change buffering of stream already in use */
+ /* freopen would have reset the buffering automatically */
+ lastexp = NIL; /* what else should we set to NIL? */
+ /*atcount= 1; */
+ compiling= 0;
+ resetgcstats();
+ output(isltmess_t(t)?$2:
+ cons(ap(standardout,isstring_t(t)?$2:
+ ap(mkshow(0,0,t),$2)),NIL));
+ putchar('\n');
+ outstats();
+ exit(0); } } };
+
+script:
+ /* empty */|
+ defs;
+
+exp:
+ op | /* will later suppress in favour of (op) in arg */
+ e1;
+
+op:
+ '~'
+ = { $$ = NOT; }|
+ '#'
+ = { $$ = LENGTH; }|
+ diop;
+
+diop:
+ '-'
+ = { $$ = MINUS; }|
+ diop1;
+
+diop1:
+ '+'
+ = { $$ = PLUS; }|
+ PLUSPLUS
+ = { $$ = APPEND; }|
+ ':'
+ = { $$ = P; }|
+ MINUSMINUS
+ = { $$ = listdiff_fn; }|
+ VEL
+ = { $$ = OR; }|
+ '&'
+ = { $$ = AND; }|
+ relop |
+ '*'
+ = { $$ = TIMES; }|
+ '/'
+ = { $$ = FDIV; }|
+ DIV
+ = { $$ = INTDIV; }|
+ REM
+ = { $$ = MOD; }|
+ '^'
+ = { $$ = POWER; }|
+ '.'
+ = { $$ = B; }|
+ '!'
+ = { $$ = ap(C,SUBSCRIPT); }|
+ INFIXNAME|
+ INFIXCNAME;
+
+relop:
+ '>'
+ = { $$ = GR; }|
+ GE
+ = { $$ = GRE; }|
+ eqop
+ = { $$ = EQ; }|
+ NE
+ = { $$ = NEQ; }|
+ LE
+ = { $$ = ap(C,GRE); }|
+ '<'
+ = { $$ = ap(C,GR); };
+
+eqop:
+ EQEQ| /* silently accept for benefit of Haskell users */
+ '=';
+
+rhs:
+ cases WHERE ldefs
+ = { $$ = block($3,compose($1),0); }|
+ exp WHERE ldefs
+ = { $$ = block($3,$1,0); }|
+ exp|
+ cases
+ = { $$ = compose($1); };
+
+cases:
+ exp ',' if exp
+ = { $$ = cons(ap2(COND,$4,$1),NIL); }|
+ exp ',' OTHERWISE
+ = { $$ = cons(ap(OTHERWISE,$1),NIL); }|
+ cases reindent ELSEQ alt
+ = { $$ = cons($4,$1);
+ if(hd[hd[$1]]==OTHERWISE)
+ syntax("\"otherwise\" must be last case\n"); };
+
+alt:
+ here exp
+ = { errs=$1,
+ syntax("obsolete syntax, \", otherwise\" missing\n");
+ $$ = ap(OTHERWISE,label($1,$2)); }|
+ here exp ',' if exp
+ = { $$ = label($1,ap2(COND,$5,$2)); }|
+ here exp ',' OTHERWISE
+ = { $$ = ap(OTHERWISE,label($1,$2)); };
+
+if:
+ /* empty */
+ = { extern word strictif;
+ if(strictif)syntax("\"if\" missing\n"); }|
+ IF;
+
+indent:
+ /* empty */
+ = { if(!SYNERR){layout(); setlmargin();}
+ };
+/* note that because of yacc's one symbol look ahead, indent must usually be
+ invoked one symbol earlier than the non-terminal to which it applies
+ - see `production:' for an exception */
+
+outdent:
+ separator
+ = { unsetlmargin(); };
+
+separator:
+ OFFSIDE | ';' ;
+
+reindent:
+ /* empty */
+ = { if(!SYNERR)
+ { unsetlmargin(); layout(); setlmargin(); }
+ };
+
+liste: /* NB - returns list in reverse order */
+ exp
+ = { $$ = cons($1,NIL); }|
+ liste ',' exp /* left recursive so as not to eat YACC stack */
+ = { $$ = cons($3,$1); };
+
+e1:
+ '~' e1 %prec '='
+ = { $$ = ap(NOT,$2); }|
+ e1 PLUSPLUS e1
+ = { $$ = ap2(APPEND,$1,$3); }|
+ e1 ':' e1
+ = { $$ = cons($1,$3); }|
+ e1 MINUSMINUS e1
+ = { $$ = ap2(listdiff_fn,$1,$3); }|
+ e1 VEL e1
+ = { $$ = ap2(OR,$1,$3); }|
+ e1 '&' e1
+ = { $$ = ap2(AND,$1,$3); }|
+ reln |
+ e2;
+
+es1: /* e1 or presection */
+ '~' e1 %prec '='
+ = { $$ = ap(NOT,$2); }|
+ e1 PLUSPLUS e1
+ = { $$ = ap2(APPEND,$1,$3); }|
+ e1 PLUSPLUS
+ = { $$ = ap(APPEND,$1); }|
+ e1 ':' e1
+ = { $$ = cons($1,$3); }|
+ e1 ':'
+ = { $$ = ap(P,$1); }|
+ e1 MINUSMINUS e1
+ = { $$ = ap2(listdiff_fn,$1,$3); }|
+ e1 MINUSMINUS
+ = { $$ = ap(listdiff_fn,$1); }|
+ e1 VEL e1
+ = { $$ = ap2(OR,$1,$3); }|
+ e1 VEL
+ = { $$ = ap(OR,$1); }|
+ e1 '&' e1
+ = { $$ = ap2(AND,$1,$3); }|
+ e1 '&'
+ = { $$ = ap(AND,$1); }|
+ relsn |
+ es2;
+
+e2:
+ '-' e2 %prec '-'
+ = { $$ = ap(NEG,$2); }|
+ '#' e2 %prec '.'
+ = { $$ = ap(LENGTH,$2); }|
+ e2 '+' e2
+ = { $$ = ap2(PLUS,$1,$3); }|
+ e2 '-' e2
+ = { $$ = ap2(MINUS,$1,$3); }|
+ e2 '*' e2
+ = { $$ = ap2(TIMES,$1,$3); }|
+ e2 '/' e2
+ = { $$ = ap2(FDIV,$1,$3); }|
+ e2 DIV e2
+ = { $$ = ap2(INTDIV,$1,$3); } |
+ e2 REM e2
+ = { $$ = ap2(MOD,$1,$3); }|
+ e2 '^' e2
+ = { $$ = ap2(POWER,$1,$3); } |
+ e2 '.' e2
+ = { $$ = ap2(B,$1,$3); }|
+ e2 '!' e2
+ = { $$ = ap2(SUBSCRIPT,$3,$1); }|
+ e3;
+
+es2: /* e2 or presection */
+ '-' e2 %prec '-'
+ = { $$ = ap(NEG,$2); }|
+ '#' e2 %prec '.'
+ = { $$ = ap(LENGTH,$2); }|
+ e2 '+' e2
+ = { $$ = ap2(PLUS,$1,$3); }|
+ e2 '+'
+ = { $$ = ap(PLUS,$1); }|
+ e2 '-' e2
+ = { $$ = ap2(MINUS,$1,$3); }|
+ e2 '-'
+ = { $$ = ap(MINUS,$1); }|
+ e2 '*' e2
+ = { $$ = ap2(TIMES,$1,$3); }|
+ e2 '*'
+ = { $$ = ap(TIMES,$1); }|
+ e2 '/' e2
+ = { $$ = ap2(FDIV,$1,$3); }|
+ e2 '/'
+ = { $$ = ap(FDIV,$1); }|
+ e2 DIV e2
+ = { $$ = ap2(INTDIV,$1,$3); } |
+ e2 DIV
+ = { $$ = ap(INTDIV,$1); } |
+ e2 REM e2
+ = { $$ = ap2(MOD,$1,$3); }|
+ e2 REM
+ = { $$ = ap(MOD,$1); }|
+ e2 '^' e2
+ = { $$ = ap2(POWER,$1,$3); } |
+ e2 '^'
+ = { $$ = ap(POWER,$1); } |
+ e2 '.' e2
+ = { $$ = ap2(B,$1,$3); }|
+ e2 '.'
+ = { $$ = ap(B,$1); }|
+ e2 '!' e2
+ = { $$ = ap2(SUBSCRIPT,$3,$1); }|
+ e2 '!'
+ = { $$ = ap2(C,SUBSCRIPT,$1); }|
+ es3;
+
+e3:
+ comb INFIXNAME e3
+ = { $$ = ap2($2,$1,$3); }|
+ comb INFIXCNAME e3
+ = { $$ = ap2($2,$1,$3); }|
+ comb;
+
+es3: /* e3 or presection */
+ comb INFIXNAME e3
+ = { $$ = ap2($2,$1,$3); }|
+ comb INFIXNAME
+ = { $$ = ap($2,$1); }|
+ comb INFIXCNAME e3
+ = { $$ = ap2($2,$1,$3); }|
+ comb INFIXCNAME
+ = { $$ = ap($2,$1); }|
+ comb;
+
+comb:
+ comb arg
+ = { $$ = ap($1,$2); }|
+ arg;
+
+reln:
+ e2 relop e2
+ = { $$ = ap2($2,$1,$3); }|
+ reln relop e2
+ = { word subject;
+ subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1];
+ $$ = ap2(AND,$1,ap2($2,subject,$3));
+ }; /* EFFICIENCY PROBLEM - subject gets re-evaluated (and
+ retypechecked) - fix later */
+
+relsn: /* reln or presection */
+ e2 relop e2
+ = { $$ = ap2($2,$1,$3); }|
+ e2 relop
+ = { $$ = ap($2,$1); }|
+ reln relop e2
+ = { word subject;
+ subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1];
+ $$ = ap2(AND,$1,ap2($2,subject,$3));
+ }; /* EFFICIENCY PROBLEM - subject gets re-evaluated (and
+ retypechecked) - fix later */
+
+arg:
+ { if(!SYNERR)lexstates=NIL,inlex=1; }
+ LEX lexrules ENDIR
+ = { inlex=0; lexdefs=NIL;
+ if(lexstates!=NIL)
+ { word echoed=0;
+ for(;lexstates!=NIL;lexstates=tl[lexstates])
+ { if(!echoed)printf(echoing?"\n":""),echoed=1;
+ if(!(tl[hd[lexstates]]&1))
+ printf("warning: lex state %s is never entered\n",
+ get_id(hd[hd[lexstates]])); else
+ if(!(tl[hd[lexstates]]&2))
+ printf("warning: lex state %s has no associated rules\n",
+ get_id(hd[hd[lexstates]])); }
+ }
+ if($3==NIL)syntax("%lex with no rules\n");
+ else tag[$3]=LEXER;
+ /* result is lex-list, in reverse order, of items of the form
+ cons(scstuff,cons(matcher,rhs))
+ where scstuff is of the form
+ cons(0-or-list-of-startconditions,1+newstartcondition)
+ */
+ $$ = $3; }|
+ NAME |
+ CNAME |
+ CONST |
+ READVALSY
+ = { $$ = readvals(0,0); }|
+ SHOWSYM
+ = { $$ = show(0,0); }|
+ DOLLAR2
+ = { $$ = lastexp;
+ if(lastexp==UNDEF)
+ syntax("no previous expression to substitute for $$\n"); }|
+ '[' ']'
+ = { $$ = NIL; }|
+ '[' exp ']'
+ = { $$ = cons($2,NIL); }|
+ '[' exp ',' exp ']'
+ = { $$ = cons($2,cons($4,NIL)); }|
+ '[' exp ',' exp ',' liste ']'
+ = { $$ = cons($2,cons($4,reverse($6))); }|
+ '[' exp DOTDOT exp ']'
+ = { $$ = ap3(STEPUNTIL,big_one,$4,$2); }|
+ '[' exp DOTDOT ']'
+ = { $$ = ap2(STEP,big_one,$2); }|
+ '[' exp ',' exp DOTDOT exp ']'
+ = { $$ = ap3(STEPUNTIL,ap2(MINUS,$4,$2),$6,$2); }|
+ '[' exp ',' exp DOTDOT ']'
+ = { $$ = ap2(STEP,ap2(MINUS,$4,$2),$2); }|
+ '[' exp '|' qualifiers ']'
+ = { $$ = SYNERR?NIL:compzf($2,$4,0); }|
+ '[' exp DIAG qualifiers ']'
+ = { $$ = SYNERR?NIL:compzf($2,$4,1); }|
+ '(' op ')' /* RSB */
+ = { $$ = $2; }|
+ '(' es1 ')' /* presection or parenthesised e1 */
+ = { $$ = $2; }|
+ '(' diop1 e1 ')' /* postsection */
+ = { $$ = (tag[$2]==AP&&hd[$2]==C)?ap(tl[$2],$3): /* optimisation */
+ ap2(C,$2,$3); }|
+ '(' ')'
+ = { $$ = Void; }| /* the void tuple */
+ '(' exp ',' liste ')'
+ = { if(tl[$4]==NIL)$$=pair($2,hd[$4]);
+ else { $$=pair(hd[tl[$4]],hd[$4]);
+ $4=tl[tl[$4]];
+ while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4];
+ $$ = tcons($2,$$); }
+ /* representation of the tuple (a1,...,an) is
+ tcons(a1,tcons(a2,...pair(a(n-1),an))) */
+ };
+
+lexrules:
+ lexrules lstart here re indent { if(!SYNERR)inlex=2; }
+ ARROW exp lpostfix { if(!SYNERR)inlex=1; } outdent
+ = { if($9<0 && e_re($4))
+ errs=$3,
+ syntax("illegal lex rule - lhs matches empty\n");
+ $$ = cons(cons(cons($2,1+$9),cons($4,label($3,$8))),$1); }|
+ lexdefs
+ = { $$ = NIL; };
+
+lstart:
+ /* empty */
+ = { $$ = 0; }|
+ '<' cnames '>'
+ = { word ns=NIL;
+ for(;$2!=NIL;$2=tl[$2])
+ { word *x = &lexstates,i=1;
+ while(*x!=NIL&&hd[hd[*x]]!=hd[$2])i++,x = &tl[*x];
+ if(*x == NIL)*x = cons(cons(hd[$2],2),NIL);
+ else tl[hd[*x]] |= 2;
+ ns = add1(i,ns); }
+ $$ = ns; };
+
+cnames:
+ CNAME
+ = { $$=cons($1,NIL); }|
+ cnames CNAME
+ = { if(member($1,$2))
+ printf("%ssyntax error: repeated name \"%s\" in start conditions\n",
+ echoing?"\n":"",get_id($2)),
+ acterror();
+ $$ = cons($2,$1); };
+
+lpostfix:
+ /* empty */
+ = { $$ = -1; }|
+ LBEGIN CNAME
+ = { word *x = &lexstates,i=1;
+ while(*x!=NIL&&hd[hd[*x]]!=$2)i++,x = &tl[*x];
+ if(*x == NIL)*x = cons(cons($2,1),NIL);
+ else tl[hd[*x]] |= 1;
+ $$ = i;
+ }|
+ LBEGIN CONST
+ = { if(!isnat($2)||get_word($2)!=0)
+ syntax("%begin not followed by IDENTIFIER or 0\n");
+ $$ = 0; };
+
+lexdefs:
+ lexdefs LEXDEF indent '=' re outdent
+ = { lexdefs = cons(cons($2,$5),lexdefs); }|
+ /* empty */
+ = { lexdefs = NIL; };
+
+re: /* regular expression */
+ re1 '|' re
+ { $$ = ap2(LEX_OR,$1,$3); }|
+ re1;
+
+re1:
+ lterm '/' lterm
+ { $$ = ap2(LEX_RCONTEXT,$1,$3); }|
+ lterm '/'
+ { $$ = ap2(LEX_RCONTEXT,$1,0); }|
+ lterm;
+
+lterm:
+ lfac lterm
+ { $$ = ap2(LEX_SEQ,$1,$2); }|
+ lfac;
+
+lfac:
+ lunit '*'
+ { if(e_re($1))
+ syntax("illegal regular expression - arg of * matches empty\n");
+ $$ = ap(LEX_STAR,$1); }|
+ lunit '+'
+ { $$ = ap2(LEX_SEQ,$1,ap(LEX_STAR,$1)); }|
+ lunit '?'
+ { $$ = ap(LEX_OPT,$1); }|
+ lunit;
+
+lunit:
+ '(' re ')'
+ = { $$ = $2; }|
+ CONST
+ = { if(!isstring($1))
+ printf("%ssyntax error - unexpected token \"",
+ echoing?"\n":""),
+ out(stdout,$1),printf("\" in regular expression\n"),
+ acterror();
+ $$ = $1==NILS?ap(LEX_STRING,NIL):
+ tl[$1]==NIL?ap(LEX_CHAR,hd[$1]):
+ ap(LEX_STRING,$1);
+ }|
+ CHARCLASS
+ = { if($1==NIL)
+ syntax("empty character class `` cannot match\n");
+ $$ = tl[$1]==NIL?ap(LEX_CHAR,hd[$1]):ap(LEX_CLASS,$1); }|
+ ANTICHARCLASS
+ = { $$ = ap(LEX_CLASS,cons(ANTICHARCLASS,$1)); }|
+ '.'
+ = { $$ = LEX_DOT; }|
+ name
+ = { word x=lexdefs;
+ while(x!=NIL&&hd[hd[x]]!=$1)x=tl[x];
+ if(x==NIL)
+ printf(
+ "%ssyntax error: undefined lexeme %s in regular expression\n",
+ echoing?"\n":"",
+ get_id($1)),
+ acterror();
+ else $$ = tl[hd[x]]; };
+
+name: NAME|CNAME;
+
+qualifiers:
+ exp
+ = { $$ = cons(cons(GUARD,$1),NIL); }|
+ generator
+ = { $$ = cons($1,NIL); }|
+ qualifiers ';' generator
+ = { $$ = cons($3,$1); }|
+ qualifiers ';' exp
+ = { $$ = cons(cons(GUARD,$3),$1); };
+
+generator:
+ e1 ',' generator
+ = { /* fix syntax to disallow patlist on lhs of iterate generator */
+ if(hd[$3]==GENERATOR)
+ { word e=tl[tl[$3]];
+ if(tag[e]==AP&&tag[hd[e]]==AP&&
+ (hd[hd[e]]==ITERATE||hd[hd[e]]==ITERATE1))
+ syntax("ill-formed generator\n"); }
+ $$ = cons(REPEAT,cons(genlhs($1),$3)); idsused=NIL; }|
+ generator1;
+
+generator1:
+ e1 LEFTARROW exp
+ = { $$ = cons(GENERATOR,cons(genlhs($1),$3)); idsused=NIL; }|
+ e1 LEFTARROW exp ',' exp DOTDOT
+ = { word p = genlhs($1); idsused=NIL;
+ $$ = cons(GENERATOR,
+ cons(p,ap2(irrefutable(p)?ITERATE:ITERATE1,
+ lambda(p,$5),$3)));
+ };
+
+defs:
+ def|
+ defs def;
+
+def:
+ v act2 indent '=' here rhs outdent
+ = { word l = $1, r = $6;
+ word f = head(l);
+ if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */
+ while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l];
+ r = label($5,r); /* to help locate type errors */
+ declare(l,r),lastname=l; }|
+
+ spec
+ = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]];
+ while(h!=NIL&&!SYNERR)specify(hd[h],t,hr),h=tl[h];
+ $$ = cons(nill,NIL); }|
+
+ ABSTYPE here typeforms indent WITH lspecs outdent
+ = { extern word TABSTRS;
+ extern char *dicp,*dicq;
+ word x=reverse($6),ids=NIL,tids=NIL;
+ while(x!=NIL&&!SYNERR)
+ specify(hd[hd[x]],cons(tl[tl[hd[x]]],NIL),hd[tl[hd[x]]]),
+ ids=cons(hd[hd[x]],ids),x=tl[x];
+ /* each id in specs has its id_type set to const(t,NIL) as a way
+ of flagging that t is an abstract type */
+ x=reverse($3);
+ while(x!=NIL&&!SYNERR)
+ { word shfn;
+ decltype(hd[x],abstract_t,undef_t,$2);
+ tids=cons(head(hd[x]),tids);
+ /* check for presence of showfunction */
+ (void)strcpy(dicp,"show");
+ (void)strcat(dicp,get_id(hd[tids]));
+ dicq = dicp+strlen(dicp)+1;
+ shfn=name();
+ if(member(ids,shfn))
+ t_showfn(hd[tids])=shfn;
+ x=tl[x]; }
+ TABSTRS = cons(cons(tids,ids),TABSTRS);
+ $$ = cons(nill,NIL); }|
+
+ typeform indent act1 here EQEQ type act2 outdent
+ = { word x=redtvars(ap($1,$6));
+ decltype(hd[x],synonym_t,tl[x],$4);
+ $$ = cons(nill,NIL); }|
+
+ typeform indent act1 here COLON2EQ construction act2 outdent
+ = { word rhs = $6, r_ids = $6, n=0;
+ while(r_ids!=NIL)r_ids=tl[r_ids],n++;
+ while(rhs!=NIL&&!SYNERR)
+ { word h=hd[rhs],t=$1,stricts=NIL,i=0;
+ while(tag[h]==AP)
+ { if(tag[tl[h]]==AP&&hd[tl[h]]==strict_t)
+ stricts=cons(i,stricts),tl[h]=tl[tl[h]];
+ t=ap2(arrow_t,tl[h],t),h=hd[h],i++; }
+ if(tag[h]==ID)
+ declconstr(h,--n,t);
+ /* warning - type not yet in reduced form */
+ else { stricts=NIL;
+ if(echoing)putchar('\n');
+ printf("syntax error: illegal construct \"");
+ out_type(hd[rhs]);
+ printf("\" on right of ::=\n");
+ acterror(); } /* can this still happen? check later */
+ if(stricts!=NIL) /* ! operators were present */
+ { word k = id_val(h);
+ while(stricts!=NIL)
+ k=ap2(MKSTRICT,i-hd[stricts],k),
+ stricts=tl[stricts];
+ id_val(h)=k; /* overwrite id_val of original constructor */
+ }
+ r_ids=cons(h,r_ids);
+ rhs = tl[rhs]; }
+ if(!SYNERR)decltype($1,algebraic_t,r_ids,$4);
+ $$ = cons(nill,NIL); }|
+
+ indent setexp EXPORT parts outdent
+ = { inexplist=0;
+ if(exports!=NIL)
+ errs=$2,
+ syntax("multiple %export statements are illegal\n");
+ else { if($4==NIL&&exportfiles==NIL&&embargoes!=NIL)
+ exportfiles=cons(PLUS,NIL);
+ exports=cons($2,$4); } /* cons(hereinfo,identifiers) */
+ $$ = cons(nill,NIL); }|
+
+ FREE here '{' specs '}'
+ = { if(freeids!=NIL)
+ errs=$2,
+ syntax("multiple %free statements are illegal\n"); else
+ { word x=reverse($4);
+ while(x!=NIL&&!SYNERR)
+ { specify(hd[hd[x]],tl[tl[hd[x]]],hd[tl[hd[x]]]);
+ freeids=cons(head(hd[hd[x]]),freeids);
+ if(tl[tl[hd[x]]]==type_t)
+ t_class(hd[freeids])=free_t;
+ else id_val(hd[freeids])=FREE; /* conventional value */
+ x=tl[x]; }
+ fil_share(hd[files])=0; /* parameterised scripts unshareable */
+ freeids=alfasort(freeids);
+ for(x=freeids;x!=NIL;x=tl[x])
+ hd[x]=cons(hd[x],cons(datapair(get_id(hd[x]),0),
+ id_type(hd[x])));
+ /* each element of freeids is of the form
+ cons(id,cons(original_name,type)) */
+ }
+ $$ = cons(nill,NIL); }|
+
+ INCLUDE bindings modifiers outdent
+ /* fiddle - 'indent' done by yylex() on reading fileid */
+ = { extern char *dicp;
+ extern word CLASHES,BAD_DUMP;
+ includees=cons(cons($1,cons($3,$2)),includees);
+ /* $1 contains file+hereinfo */
+ $$ = cons(nill,NIL); }|
+
+ here BNF { startbnf(); inbnf=1;} names outdent productions ENDIR
+ /* fiddle - `indent' done by yylex() while processing directive */
+ = { word lhs=NIL,p=$6,subjects,body,startswith=NIL,leftrecs=NIL;
+ ihlist=inbnf=0;
+ nonterminals=UNION(nonterminals,$4);
+ for(;p!=NIL;p=tl[p])
+ if(dval(hd[p])==UNDEF)nonterminals=add1(dlhs(hd[p]),nonterminals);
+ else lhs=add1(dlhs(hd[p]),lhs);
+ nonterminals=setdiff(nonterminals,lhs);
+ if(nonterminals!=NIL)
+ errs=$1,
+ member($4,hd[nonterminals])||findnt(hd[nonterminals]),
+ printf("%sfatal error in grammar, ",echoing?"\n":""),
+ printf("undefined nonterminal%s: ",
+ tl[nonterminals]==NIL?"":"s"),
+ printlist("",nonterminals),
+ acterror(); else
+ { /* compute list of nonterminals admitting empty prodn */
+ eprodnts=NIL;
+ L:for(p=$6;p!=NIL;p=tl[p])
+ if(!member(eprodnts,dlhs(hd[p]))&&eprod(dval(hd[p])))
+ { eprodnts=cons(dlhs(hd[p]),eprodnts); goto L; }
+ /* now compute startswith reln between nonterminals
+ (performing binomial transformation en route)
+ and use to detect unremoved left recursion */
+ for(p=$6;p!=NIL;p=tl[p])
+ if(member(lhs=starts(dval(hd[p])),dlhs(hd[p])))
+ binom(dval(hd[p]),dlhs(hd[p])),
+ startswith=cons(cons(dlhs(hd[p]),starts(dval(hd[p]))),
+ startswith);
+ else startswith=cons(cons(dlhs(hd[p]),lhs),startswith);
+ startswith=tclos(sortrel(startswith));
+ for(;startswith!=NIL;startswith=tl[startswith])
+ if(member(tl[hd[startswith]],hd[hd[startswith]]))
+ leftrecs=add1(hd[hd[startswith]],leftrecs);
+ if(leftrecs!=NIL)
+ errs=getloc(hd[leftrecs],$6),
+ printf("%sfatal error in grammar, ",echoing?"\n":""),
+ printlist("irremovable left recursion: ",leftrecs),
+ acterror();
+ if($4==NIL) /* implied start symbol */
+ $4=cons(dlhs(hd[lastlink($6)]),NIL);
+ fnts=1; /* fnts is flag indicating %bnf in use */
+ if(tl[$4]==NIL) /* only one start symbol */
+ subjects=getfname(hd[$4]),
+ body=ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]);
+ else
+ { body=subjects=Void;
+ while($4!=NIL)
+ subjects=pair(getfname(hd[$4]),subjects),
+ body=pair(
+ ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]),
+ body),
+ $4=tl[$4];
+ }
+ declare(subjects,label($1,block($6,body, 0)));
+ }};
+
+setexp:
+ here
+ = { $$=$1;
+ inexplist=1; }; /* hack to fix lex analyser */
+
+bindings:
+ /* empty */
+ = { $$ = NIL; }|
+ '{' bindingseq '}'
+ = { $$ = $2; };
+
+bindingseq:
+ bindingseq binding
+ = { $$ = cons($2,$1); }|
+ binding
+ = { $$ = cons($1,NIL); };
+
+binding:
+ NAME indent '=' exp outdent
+ = { $$ = cons($1,$4); }|
+ typeform indent act1 EQEQ type act2 outdent
+ = { word x=redtvars(ap($1,$5));
+ word arity=0,h=hd[x];
+ while(tag[h]==AP)arity++,h=hd[h];
+ $$ = ap(h,make_typ(arity,0,synonym_t,tl[x]));
+ };
+
+modifiers:
+ /* empty */
+ = { $$ = NIL; }|
+ negmods
+ = { word a,b,c=0;
+ for(a=$1;a!=NIL;a=tl[a])
+ for(b=tl[a];b!=NIL;b=tl[b])
+ { if(hd[hd[a]]==hd[hd[b]])c=hd[hd[a]];
+ if(tl[hd[a]]==tl[hd[b]])c=tl[hd[a]];
+ if(c)break; }
+ if(c)printf(
+ "%ssyntax error: conflicting aliases (\"%s\")\n",
+ echoing?"\n":"",
+ get_id(c)),
+ acterror();
+ };
+
+negmods:
+ negmods negmod
+ = { $$ = cons($2,$1); }|
+ negmod
+ = { $$ = cons($1,NIL); };
+
+negmod:
+ NAME '/' NAME
+ = { $$ = cons($1,$3); }|
+ CNAME '/' CNAME
+ = { $$ = cons($1,$3); }|
+ '-' NAME
+ = { $$ = cons(make_pn(UNDEF),$2); }/*|
+ '-' CNAME */; /* no - cannot suppress constructors selectively */
+
+here:
+ /* empty */
+ = { extern word line_no;
+ lasth = $$ = fileinfo(get_fil(current_file),line_no);
+ /* (script,line_no) for diagnostics */
+ };
+
+act1:
+ /* empty */
+ = { tvarscope=1; };
+
+act2:
+ /* empty */
+ = { tvarscope=0; idsused= NIL; };
+
+ldefs:
+ ldef
+ = { $$ = cons($1,NIL);
+ dval($1) = tries(dlhs($1),cons(dval($1),NIL));
+ if(!SYNERR&&get_ids(dlhs($1))==NIL)
+ errs=hd[hd[tl[dval($1)]]],
+ syntax("illegal lhs for local definition\n");
+ }|
+ ldefs ldef
+ = { if(dlhs($2)==dlhs(hd[$1]) /*&&dval(hd[$1])!=UNDEF*/)
+ { $$ = $1;
+ if(!fallible(hd[tl[dval(hd[$1])]]))
+ errs=hd[dval($2)],
+ printf("%ssyntax error: \
+unreachable case in defn of \"%s\"\n",echoing?"\n":"",get_id(dlhs($2))),
+ acterror();
+ tl[dval(hd[$1])]=cons(dval($2),tl[dval(hd[$1])]); }
+ else if(!SYNERR)
+ { word ns=get_ids(dlhs($2)),hr=hd[dval($2)];
+ if(ns==NIL)
+ errs=hr,
+ syntax("illegal lhs for local definition\n");
+ $$ = cons($2,$1);
+ dval($2)=tries(dlhs($2),cons(dval($2),NIL));
+ while(ns!=NIL&&!SYNERR) /* local nameclash check */
+ { nclashcheck(hd[ns],$1,hr);
+ ns=tl[ns]; }
+ /* potentially quadratic - fix later */
+ }
+ };
+
+ldef:
+ spec
+ = { errs=hd[tl[$1]];
+ syntax("`::' encountered in local defs\n");
+ $$ = cons(nill,NIL); }|
+ typeform here EQEQ
+ = { errs=$2;
+ syntax("`==' encountered in local defs\n");
+ $$ = cons(nill,NIL); }|
+ typeform here COLON2EQ
+ = { errs=$2;
+ syntax("`::=' encountered in local defs\n");
+ $$ = cons(nill,NIL); }|
+ v act2 indent '=' here rhs outdent
+ = { word l = $1, r = $6;
+ word f = head(l);
+ if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */
+ while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l];
+ r = label($5,r); /* to help locate type errors */
+ $$ = defn(l,undef_t,r); };
+
+vlist:
+ v
+ = { $$ = cons($1,NIL); }|
+ vlist ',' v /* left recursive so as not to eat YACC stack */
+ = { $$ = cons($3,$1); }; /* reverse order, NB */
+
+v:
+ v1 |
+ v1 ':' v
+ = { $$ = cons($1,$3); };
+
+v1:
+ v1 '+' CONST /* n+k pattern */
+ = { if(!isnat($3))
+ syntax("inappropriate use of \"+\" in pattern\n");
+ $$ = ap2(PLUS,$3,$1); }|
+ '-' CONST
+ = { /* if(tag[$2]==DOUBLE)
+ $$ = cons(CONST,sto_dbl(-get_dbl($2))); else */
+ if(tag[$2]==INT)
+ $$ = cons(CONST,bignegate($2)); else
+ syntax("inappropriate use of \"-\" in pattern\n"); }|
+ v2 INFIXNAME v1
+ = { $$ = ap2($2,$1,$3); }|
+ v2 INFIXCNAME v1
+ = { $$ = ap2($2,$1,$3); }|
+ v2;
+
+v2:
+ v3 |
+ v2 v3
+ = { $$ = ap(hd[$1]==CONST&&tag[tl[$1]]==ID?tl[$1]:$1,$2); };
+ /* repeated name apparatus may have wrapped CONST around leading id
+ - not wanted */
+
+v3:
+ NAME
+ = { if(sreds&&member(gvars,$1))syntax("illegal use of $num symbol\n");
+ /* cannot use grammar variable in a binding position */
+ if(memb(idsused,$1))$$ = cons(CONST,$1);
+ /* picks up repeated names in a template */
+ else idsused= cons($1,idsused); } |
+ CNAME |
+ CONST
+ = { if(tag[$1]==DOUBLE)
+ syntax("use of floating point literal in pattern\n");
+ $$ = cons(CONST,$1); }|
+ '[' ']'
+ = { $$ = nill; }|
+ '[' vlist ']'
+ = { word x=$2,y=nill;
+ while(x!=NIL)y = cons(hd[x],y), x = tl[x];
+ $$ = y; }|
+ '(' ')'
+ = { $$ = Void; }|
+ '(' v ')'
+ = { $$ = $2; }|
+ '(' v ',' vlist ')'
+ = { if(tl[$4]==NIL)$$=pair($2,hd[$4]);
+ else { $$=pair(hd[tl[$4]],hd[$4]);
+ $4=tl[tl[$4]];
+ while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4];
+ $$ = tcons($2,$$); }
+ /* representation of the tuple (a1,...,an) is
+ tcons(a1,tcons(a2,...pair(a(n-1),an))) */
+ };
+
+type:
+ type1 |
+ type ARROW type
+ = { $$ = ap2(arrow_t,$1,$3); };
+
+type1:
+ type2 INFIXNAME type1
+ = { $$ = ap2($2,$1,$3); }|
+ type2;
+
+type2:
+ /* type2 argtype /* too permissive - fix later */
+ /* = { $$ = ap($1,$2); }| */
+ tap|
+ argtype;
+
+tap:
+ NAME argtype
+ = { $$ = ap($1,$2); }|
+ tap argtype
+ = { $$ = ap($1,$2); };
+
+argtype:
+ NAME
+ = { $$ = transtypeid($1); }|
+ /* necessary while prelude not meta_tchecked (for prelude)*/
+ typevar
+ = { if(tvarscope&&!memb(idsused,$1))
+ printf("%ssyntax error: unbound type variable ",echoing?"\n":""),
+ out_type($1),putchar('\n'),acterror();
+ $$ = $1; }|
+ '(' typelist ')'
+ = { $$ = $2; }|
+ '[' type ']' /* at release one was `typelist' */
+ = { $$ = ap(list_t,$2); }|
+ '[' type ',' typel ']'
+ = { syntax(
+ "tuple-type with missing parentheses (obsolete syntax)\n"); };
+
+typelist:
+ /* empty */
+ = { $$ = void_t; }| /* voidtype */
+ type |
+ type ',' typel
+ = { word x=$3,y=void_t;
+ while(x!=NIL)y = ap2(comma_t,hd[x],y), x = tl[x];
+ $$ = ap2(comma_t,$1,y); };
+
+typel:
+ type
+ = { $$ = cons($1,NIL); }|
+ typel ',' type /* left recursive so as not to eat YACC stack */
+ = { $$ = cons($3,$1); };
+
+parts: /* returned in reverse order */
+ parts NAME
+ = { $$ = add1($2,$1); }|
+ parts '-' NAME
+ = { $$ = $1; embargoes=add1($3,embargoes); }|
+ parts PATHNAME
+ = { $$ = $1; }| /*the pathnames are placed on exportfiles in yylex*/
+ parts '+'
+ = { $$ = $1;
+ exportfiles=cons(PLUS,exportfiles); }|
+ NAME
+ = { $$ = add1($1,NIL); }|
+ '-' NAME
+ = { $$ = NIL; embargoes=add1($2,embargoes); }|
+ PATHNAME
+ = { $$ = NIL; }|
+ '+'
+ = { $$ = NIL;
+ exportfiles=cons(PLUS,exportfiles); };
+
+specs: /* returns a list of cons(id,cons(here,type))
+ in reverse order of appearance */
+ specs spec
+ = { word x=$1,h=hd[$2],t=tl[$2];
+ while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
+ $$ = x; }|
+ spec
+ = { word x=NIL,h=hd[$1],t=tl[$1];
+ while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
+ $$ = x; };
+
+spec:
+ typeforms indent here COLONCOLON ttype outdent
+ = { $$ = cons($1,cons($3,$5)); };
+ /* hack: `typeforms' includes `namelist' */
+
+lspecs: /* returns a list of cons(id,cons(here,type))
+ in reverse order of appearance */
+ lspecs lspec
+ = { word x=$1,h=hd[$2],t=tl[$2];
+ while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
+ $$ = x; }|
+ lspec
+ = { word x=NIL,h=hd[$1],t=tl[$1];
+ while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h];
+ $$ = x; };
+
+lspec:
+ namelist indent here {inbnf=0;} COLONCOLON type outdent
+ = { $$ = cons($1,cons($3,$6)); };
+
+namelist:
+ NAME ',' namelist
+ = { $$ = cons($1,$3); }|
+ NAME
+ = { $$ = cons($1,NIL); };
+
+typeforms:
+ typeforms ',' typeform act2
+ = { $$ = cons($3,$1); }|
+ typeform act2
+ = { $$ = cons($1,NIL); };
+
+typeform:
+ CNAME typevars
+ = { syntax("upper case identifier out of context\n"); }|
+ NAME typevars /* warning if typevar is repeated */
+ = { $$ = $1;
+ idsused=$2;
+ while($2!=NIL)
+ $$ = ap($$,hd[$2]),$2 = tl[$2];
+ }|
+ typevar INFIXNAME typevar
+ = { if(eqtvar($1,$3))
+ syntax("repeated type variable in typeform\n");
+ idsused=cons($1,cons($3,NIL));
+ $$ = ap2($2,$1,$3); }|
+ typevar INFIXCNAME typevar
+ = { syntax("upper case identifier cannot be used as typename\n"); };
+
+ttype:
+ type|
+ TYPE
+ = { $$ = type_t; };
+
+typevar:
+ '*'
+ = { $$ = mktvar(1); }|
+ TYPEVAR;
+
+typevars:
+ /* empty */
+ = { $$ = NIL; }|
+ typevar typevars
+ = { if(memb($2,$1))
+ syntax("repeated type variable on lhs of type def\n");
+ $$ = cons($1,$2); };
+
+construction:
+ constructs
+ = { extern word SGC; /* keeps track of sui-generis constructors */
+ if( tl[$1]==NIL && tag[hd[$1]]!=ID )
+ /* 2nd conjunct excludes singularity types */
+ SGC=cons(head(hd[$1]),SGC);
+ };
+
+constructs:
+ construct
+ = { $$ = cons($1,NIL); }|
+ constructs '|' construct
+ = { $$ = cons($3,$1); };
+
+construct:
+ field here INFIXCNAME field
+ = { $$ = ap2($3,$1,$4);
+ id_who($3)=$2; }|
+ construct1;
+
+construct1:
+ '(' construct ')'
+ = { $$ = $2; }|
+ construct1 field1
+ = { $$ = ap($1,$2); }|
+ here CNAME
+ = { $$ = $2;
+ id_who($2)=$1; };
+
+field:
+ type|
+ argtype '!'
+ = { $$ = ap(strict_t,$1); };
+
+field1:
+ argtype '!'
+ = { $$ = ap(strict_t,$1); }|
+ argtype;
+
+names: /* used twice - for bnf list, and for inherited attr list */
+ /* empty */
+ = { $$ = NIL; }|
+ names NAME
+ = { if(member($1,$2))
+ printf("%ssyntax error: repeated identifier \"%s\" in %s list\n",
+ echoing?"\n":"",get_id($2),inbnf?"bnf":"attribute"),
+ acterror();
+ $$ = inbnf?add1($2,$1):cons($2,$1);
+ };
+
+productions:
+ lspec
+ = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]];
+ inbnf=1;
+ $$=NIL;
+ while(h!=NIL&&!SYNERR)
+ ntspecmap=cons(cons(hd[h],hr),ntspecmap),
+ $$=add_prod(defn(hd[h],t,UNDEF),$$,hr),
+ h=tl[h];
+ }|
+ production
+ = { $$ = cons($1,NIL); }|
+ productions lspec
+ = { word h=reverse(hd[$2]),hr=hd[tl[$2]],t=tl[tl[$2]];
+ inbnf=1;
+ $$=$1;
+ while(h!=NIL&&!SYNERR)
+ ntspecmap=cons(cons(hd[h],hr),ntspecmap),
+ $$=add_prod(defn(hd[h],t,UNDEF),$$,hr),
+ h=tl[h];
+ }|
+ productions production
+ = { $$ = add_prod($2,$1,hd[dval($2)]); };
+
+production:
+ NAME params ':' indent grhs outdent
+ /* found by experiment that indent must follow ':' here */
+ = { $$ = defn($1,undef_t,$5); };
+
+params: /* places inherited attributes, if any, on ihlist */
+ /* empty */
+ = { ihlist=0; }|
+ { inbnf=0; } '(' names ')'
+ = { inbnf=1;
+ if($3==NIL)syntax("unexpected token ')'\n");
+ ihlist=$3; }
+
+grhs:
+ here phrase
+ = { $$ = label($1,$2); };
+
+phrase:
+ error_term
+ = { $$ = ap2(G_ERROR,G_ZERO,$1); }|
+ phrase1
+ = { $$=hd[$1], $1=tl[$1];
+ while($1!=NIL)
+ $$=label(hd[$1],$$),$1=tl[$1],
+ $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1];
+ }|
+ phrase1 '|' error_term
+ = { $$=hd[$1], $1=tl[$1];
+ while($1!=NIL)
+ $$=label(hd[$1],$$),$1=tl[$1],
+ $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1];
+ $$ = ap2(G_ERROR,$$,$3); };
+ /* we right rotate G_ALT's to facilitate left factoring (see trans) */
+
+phrase1:
+ term
+ = { $$=cons($1,NIL); }|
+ phrase1 '|' here term
+ = { $$ = cons($4,cons($3,$1)); };
+
+term:
+ count_factors
+ = { word n=0,f=$1,rule=Void;
+ /* default value of a production is () */
+ /* rule=mkgvar(sreds); /* formerly last symbol */
+ if(f!=NIL&&hd[f]==G_END)sreds++;
+ if(ihlist)rule=ih_abstr(rule);
+ while(n<sreds)rule=lambda(mkgvar(++n),rule);
+ sreds=0;
+ rule=ap(G_RULE,rule);
+ while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f];
+ $$ = rule; }|
+ count_factors {inbnf=2;} indent '=' here rhs outdent
+ = { if($1!=NIL&&hd[$1]==G_END)sreds++;
+ if(sreds==1&&can_elide($6))
+ inbnf=1,sreds=0,$$=hd[$1]; /* optimisation */
+ else
+ { word f=$1,rule=label($5,$6),n=0;
+ inbnf=1;
+ if(ihlist)rule=ih_abstr(rule);
+ while(n<sreds)rule=lambda(mkgvar(++n),rule);
+ sreds=0;
+ rule=ap(G_RULE,rule);
+ while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f];
+ $$ = rule; }
+ };
+
+error_term:
+ ERRORSY
+ = { word rule = ap(K,Void); /* default value of a production is () */
+ if(ihlist)rule=ih_abstr(rule);
+ $$ = rule; }|
+ ERRORSY { inbnf=2,sreds=2; } indent '=' here rhs outdent
+ = { word rule = label($5,$6);
+ if(ihlist)rule=ih_abstr(rule);
+ $$ = lambda(pair(mkgvar(1),mkgvar(2)),rule);
+ inbnf=1,sreds=0; };
+
+count_factors:
+ EMPTYSY
+ = { sreds=0; $$=NIL; }|
+ EMPTYSY factors
+ = { syntax("unexpected token after empty\n");
+ sreds=0; $$=NIL; }|
+ { obrct=0; } factors
+ = { word f=$2;
+ if(obrct)
+ syntax(obrct>0?"unmatched { in grammar rule\n":
+ "unmatched } in grammar rule\n");
+ for(sreds=0;f!=NIL;f=tl[f])sreds++;
+ if(hd[$2]==G_END)sreds--;
+ $$ = $2; };
+
+factors:
+ factor
+ = { $$ = cons($1,NIL); }|
+ factors factor
+ = { if(hd[$1]==G_END)
+ syntax("unexpected token after end\n");
+ $$ = cons($2,$1); };
+
+factor:
+ unit|
+ '{' unit '}'
+ = { $$ = ap(outdent_fn,ap2(indent_fn,getcol_fn(),$2)); }|
+ '{' unit
+ = { obrct++;
+ $$ = ap2(indent_fn,getcol_fn(),$2); }|
+ unit '}'
+ = { if(--obrct<0)syntax("unmatched `}' in grammar rule\n");
+ $$ = ap(outdent_fn,$1); } ;
+
+unit:
+ symbol|
+ symbol '*'
+ = { $$ = ap(G_STAR,$1); }|
+ symbol '+'
+ = { $$ = ap2(G_SEQ,$1,ap2(G_SEQ,ap(G_STAR,$1),ap(G_RULE,ap(C,P)))); }|
+ symbol '?'
+ = { $$ = ap(G_OPT,$1); };
+
+symbol:
+ NAME
+ = { extern word NEW;
+ nonterminals=newadd1($1,nonterminals);
+ if(NEW)ntmap=cons(cons($1,lasth),ntmap); }|
+ ENDSY
+ = { $$ = G_END; }|
+ CONST
+ = { if(!isstring($1))
+ printf("%ssyntax error: illegal terminal ",echoing?"\n":""),
+ out(stdout,$1),printf(" (should be string-const)\n"),
+ acterror();
+ $$ = ap(G_SYMB,$1); }|
+ '^'
+ = { $$=G_STATE; }|
+ {inbnf=0;} '[' exp {inbnf=1;} ']'
+ = { $$ = ap(G_SUCHTHAT,$3); }|
+ '-'
+ = { $$ = G_ANY; };
+
+%%
+/* end of MIRANDA RULES */
+
diff --git a/new/steer.c b/new/steer.c
new file mode 100644
index 0000000..27c238d
--- /dev/null
+++ b/new/steer.c
@@ -0,0 +1,2208 @@
+/* MIRANDA STEER */
+/* initialisation routines and assorted routines for I/O etc */
+
+/**************************************************************************
+ * 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. *
+ *------------------------------------------------------------------------*/
+
+/* this stuff is to get the time-last-modified of files */
+#include <sys/types.h>
+#include <sys/stat.h>
+/* #include <sys/wait.h> /* seems not needed, oct 05 */
+struct stat buf; /* see man(2) stat - gets file status */
+
+#include "data.h"
+#include "lex.h"
+#include <float.h>
+word nill,Void;
+word main_id; /* change to magic scripts 19.11.2013 */
+word message,standardout;
+word diagonalise,concat,indent_fn,outdent_fn,listdiff_fn;
+word shownum1,showbool,showchar,showlist,showstring,showparen,showpair,
+ showvoid,showfunction,showabstract,showwhat;
+
+char PRELUDE[pnlim+10],STDENV[pnlim+9];
+ /* if anyone complains, elasticate these buffers! */
+
+#define DFLTSPACE 2500000
+#define DFLTDICSPACE 100000
+/* default values for size of heap, dictionary */
+word SPACELIMIT=DFLTSPACE,DICSPACE=DFLTDICSPACE;
+
+#ifdef CYGWIN
+#define EDITOR "joe +!"
+#else
+#define EDITOR "vi +!"
+#endif
+/* The name of whatever is locally considered to be the default editor - the
+ user will be able to override this using the `/editor' command.
+ It is also overriden by shell/environment variable EDITOR if present */
+
+extern FILE *s_out;
+word UTF8=0, UTF8OUT=0;
+extern char *vdate, *host;
+extern word version, ND;
+
+char *mkabsolute(char *), *strvers(word);
+void fpe_error(void);
+
+char *editor=NULL;
+word okprel=0; /* set to 1 when prelude loaded */
+word nostdenv=0; /* if set to 1 mira does not load stdenv at startup */
+/* to allow a NOSTDENV directive _in_the_script_ we would need to
+ (i) replace isltmess() test in rules by eg is this a list of thing,
+ where thing is algebraic type originally defined in STDENV
+ (ii) arrange to pick up <stdenv> when current script not loaded
+ not implemented */
+word baded=0; /* see fixeditor() */
+char *miralib=NULL;
+char *mirahdr,*lmirahdr;
+char *promptstr="Miranda ";
+char *obsuffix="x";
+FILE *s_in=NULL;
+word commandmode=0; /* true only when reading command-level expressions */
+word atobject=0,atgc=0,atcount=0,debug=0;
+word magic=0; /* set to 1 means script will start with UNIX magic string */
+word making=0; /* set only for mira -make */
+word mkexports=0; /* set only for mira -exports */
+word mksources=0; /* set only for mira -sources */
+word make_status=0; /* exit status of -make */
+word compiling=1;
+/* there are two types of MIRANDA process - compiling (the main process) and
+subsidiary processes launched for each evaluation - the above flag tells
+us which kind of process we are in */
+word ideep=0; /* depth of %include we are at, see mkincludes() */
+word SYNERR=0;
+word initialising=1;
+word primenv=NIL;
+char *current_script;
+word lastexp=UNDEF; /* value of `$$' */
+word echoing=0,listing=0,verbosity;
+word strictif=1,rechecking=0;
+word errline=0; /* records position of last error, for editor */
+word errs=0; /* secondary error location, in inserted script, if relevant */
+word *cstack;
+extern word c;
+extern char *dicp,*dicq;
+char linebuf[BUFSIZE]; /* used for assorted purposes */
+ /* NB cannot share with linebuf in lex.c, or !! goes wrong */
+static char ebuf[pnlim];
+word col;
+char home_rc[pnlim+8];
+char lib_rc[pnlim+8];
+char *rc_error=NULL;
+#define badval(x) (x<1||x>478000000)
+
+#include <setjmp.h> /* for longjmp() - see man (3) setjmp */
+jmp_buf env;
+
+#ifdef sparc8
+#include <ieeefp.h>
+fp_except commonmask = FP_X_INV|FP_X_OFL|FP_X_DZ; /* invalid|ovflo|divzero */
+#endif
+
+main(argc,argv) /* system initialisation, followed by call to YACC */
+word argc;
+char *argv[];
+{ word manonly=0;
+ char *home, *prs;
+ word okhome_rc; /* flags valid HOME/.mirarc file present */
+ char *argv0=argv[0];
+ char *initscript;
+ word badlib=0;
+ extern word ARGC; extern char **ARGV;
+ extern word newtyps,algshfns;
+ char *progname=rindex(argv[0],'/');
+ cstack= &manonly;
+/* used to indicate the base of the C stack for garbage collection purposes */
+ verbosity=isatty(0);
+/*if(isatty(1))*/ setbuf(stdout,NULL); /* for unbuffered tty output */
+ if(home=getenv("HOME"))
+ { strcpy(home_rc,home);
+ if(strcmp(home_rc,"/")==0)home_rc[0]=0; /* root is special case */
+ strcat(home_rc,"/.mirarc");
+ okhome_rc=rc_read(home_rc); }
+/*setup policy:
+ if valid HOME/.mirarc found look no further, otherwise try
+ <miralib>/.mirarc
+ Complaints - if any .mirarc contained bad data, `announce' complains about
+ the last such looked at. */
+ UTF8OUT=UTF8=utf8test();
+ while(argc>1&&argv[1][0]=='-') /* strip off flags */
+ { if(strcmp(argv[1],"-stdenv")==0)nostdenv=1; else
+ if(strcmp(argv[1],"-count")==0)atcount=1; else
+ if(strcmp(argv[1],"-list")==0)listing=1; else
+ if(strcmp(argv[1],"-nolist")==0)listing=0; else
+ if(strcmp(argv[1],"-nostrictif")==0)strictif=0; else
+ if(strcmp(argv[1],"-gc")==0)atgc=1; else
+ if(strcmp(argv[1],"-object")==0)atobject=1; else
+ if(strcmp(argv[1],"-lib")==0)
+ { argc--,argv++;
+ if(argc==1)missparam("lib"); else miralib=argv[1];
+ } else
+ if(strcmp(argv[1],"-dic")==0)
+ { argc--,argv++;
+ if(argc==1)missparam("dic"); else
+ if(sscanf(argv[1],"%d",&DICSPACE)!=1||badval(DICSPACE))
+ fprintf(stderr,"mira: bad value after flag \"-dic\"\n"),exit(1);
+ } else
+ if(strcmp(argv[1],"-heap")==0)
+ { argc--,argv++;
+ if(argc==1)missparam("heap"); else
+ if(sscanf(argv[1],"%d",&SPACELIMIT)!=1||badval(SPACELIMIT))
+ fprintf(stderr,"mira: bad value after flag \"-heap\"\n"),exit(1);
+ } else
+ if(strcmp(argv[1],"-editor")==0)
+ { argc--,argv++;
+ if(argc==1)missparam("editor");
+ else editor=argv[1],fixeditor();
+ } else
+ if(strcmp(argv[1],"-hush")==0)verbosity=0; else
+ if(strcmp(argv[1],"-nohush")==0)verbosity=1; else
+ if(strcmp(argv[1],"-exp")==0||strcmp(argv[1],"-log")==0)
+ fprintf(stderr,"mira: obsolete flag \"%s\"\n"
+ "use \"-exec\" or \"-exec2\", see manual\n",
+ argv[1]),exit(1); else
+ if(strcmp(argv[1],"-exec")==0) /* replaces -exp 26.11.2019 */
+ ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; else
+ if(strcmp(argv[1],"-exec2")==0) /* version of -exec for debugging CGI scripts */
+ { if(argc<=2)fprintf(stderr,"incorrect use of -exec2 flag, missing filename\n"),exit(1);
+ char *logfilname, *p=strrchr(argv[2],'/');
+ FILE *fil=NULL;
+ if(!p)p=argv[2]; /* p now holds last component of prog name */
+ if(logfilname=malloc((strlen(p)+9)))
+ sprintf(logfilname,"miralog/%s",p),
+ fil=fopen(logfilname,"a");
+ else mallocfail("logfile name");
+ /* process requires write permission on local directory "miralog" */
+ if(fil)dup2(fileno(fil),2); /* redirect stderr to log file */
+ else fprintf(stderr,"could not open %s\n",logfilname);
+ ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; } else
+ if(strcmp(argv[1],"-man")==0){ manonly=1; break; } else
+ if(strcmp(argv[1],"-version")==0)v_info(0),exit(0); else
+ if(strcmp(argv[1],"-V")==0)v_info(1),exit(0); else
+ if(strcmp(argv[1],"-make")==0) making=1,verbosity=0; else
+ if(strcmp(argv[1],"-exports")==0) making=mkexports=1,verbosity=0; else
+ if(strcmp(argv[1],"-sources")==0) making=mksources=1,verbosity=0; else
+ if(strcmp(argv[1],"-UTF-8")==0) UTF8=1; else
+ if(strcmp(argv[1],"-noUTF-8")==0) UTF8=0; else
+ fprintf(stderr,"mira: unknown flag \"%s\"\n",argv[1]),exit(1);
+ argc--,argv++; }
+ if(argc>2&&!magic&&!making)fprintf(stderr,"mira: too many args\n"),exit(1);
+ if(!miralib) /* no -lib flag */
+ { char *m;
+ /* note search order */
+ if((m=getenv("MIRALIB")))miralib=m; else
+ if(checkversion(m="/usr/lib/miralib"))miralib=m; else
+ if(checkversion(m="/usr/local/lib/miralib"))miralib=m; else
+ if(checkversion(m="miralib"))miralib=m; else
+ badlib=1;
+ }
+ if(badlib)
+ { fprintf(stderr,"fatal error: miralib version %s not found\n",
+ strvers(version));
+ libfails();
+ exit(1);
+ }
+ if(!okhome_rc)
+ { if(rc_error==lib_rc)rc_error=NULL;
+ (void)strcpy(lib_rc,miralib);
+ (void)strcat(lib_rc,"/.mirarc");
+ rc_read(lib_rc); }
+ if(editor==NULL) /* .mirarc was absent or unreadable */
+ { editor=getenv("EDITOR");
+ if(editor==NULL)editor=EDITOR;
+ else strcpy(ebuf,editor),editor=ebuf,fixeditor(); }
+ if(prs=getenv("MIRAPROMPT"))promptstr=prs;
+ if(getenv("RECHECKMIRA")&&!rechecking)rechecking=1;
+ if(getenv("NOSTRICTIF"))strictif=0;
+ setupdic(); /* used by mkabsolute */
+ s_in=stdin;
+ s_out=stdout;
+ miralib=mkabsolute(miralib); /* protection against "/cd" */
+ if(manonly)manaction(),exit(0);
+ (void)strcpy(PRELUDE,miralib); (void)strcat(PRELUDE,"/prelude");
+ /* convention - change spelling of "prelude" at each release */
+ (void)strcpy(STDENV,miralib);
+ (void)strcat(STDENV,"/stdenv.m");
+ mira_setup();
+ if(verbosity)announce();
+ files=NIL;
+ undump(PRELUDE),okprel=1;
+ mkprivate(fil_defs(hd[files]));
+ files=NIL; /* don't wish unload() to unsetids on prelude */
+ if(!nostdenv)
+ { undump(STDENV);
+ while(files!=NIL) /* stdenv may have %include structure */
+ primenv=alfasort(append1(primenv,fil_defs(hd[files]))),
+ files=tl[files];
+ primenv=alfasort(primenv);
+ newtyps=files=NIL; /* don't wish unload() to unsetids */ }
+ if(!magic)rc_write();
+ echoing = verbosity&listing;
+ initialising=0;
+ if(mkexports)
+ { /* making=1, to say if recompiling, also to undump as for %include */
+ word f,argcount=argc-1;
+ extern word exports,freeids;
+ char *s;
+ setjmp(env); /* will return here on blankerr (via reset) */
+ while(--argc) /* where do error messages go?? */
+ { word x=NIL;
+ s=addextn(1,*++argv);
+ if(s==dicp)keep(dicp);
+ undump(s); /* bug, recompile messages goto stdout - FIX LATER */
+ if(files==NIL||ND!=NIL)continue;
+ if(argcount!=1)printf("%s\n",s);
+ if(exports!=NIL)x=exports;
+ /* true (if ever) only if just recompiled */
+ else for(f=files;f!=NIL;f=tl[f])x=append1(fil_defs(hd[f]),x);
+ /* method very clumsy, because exports not saved in dump */
+ if(freeids!=NIL)
+ { word f=freeids;
+ while(f!=NIL)
+ { word n=findid((char *)hd[hd[tl[hd[f]]]]);
+ id_type(n)=tl[tl[hd[f]]];
+ id_val(n)=the_val(hd[hd[f]]);
+ hd[f]=n;
+ f=tl[f]; }
+ f=freeids=typesfirst(freeids);
+ printf("\t%%free {\n");
+ while(f!=NIL)
+ putchar('\t'),
+ report_type(hd[f]),
+ putchar('\n'),
+ f=tl[f];
+ printf("\t}\n"); }
+ for(x=typesfirst(alfasort(x));x!=NIL;x=tl[x])
+ { putchar('\t');
+ report_type(hd[x]);
+ putchar('\n'); } }
+ exit(0); }
+ if(mksources){ extern word oldfiles;
+ char *s;
+ word f,x=NIL;
+ setjmp(env); /* will return here on blankerr (via reset) */
+ while(--argc)
+ if(stat((s=addextn(1,*++argv)),&buf)==0)
+ { if(s==dicp)keep(dicp);
+ undump(s);
+ for(f=files==NIL?oldfiles:files;f!=NIL;f=tl[f])
+ if(!member(x,(word)get_fil(hd[f])))
+ x=cons((word)get_fil(hd[f]),x),
+ printf("%s\n",get_fil(hd[f]));
+ }
+ exit(0); }
+ if(making){ extern word oldfiles;
+ char *s;
+ setjmp(env); /* will return here on blankerr (via reset) */
+ while(--argc) /* where do error messages go?? */
+ { s=addextn(1,*++argv);
+ if(s==dicp)keep(dicp);
+ undump(s);
+ if(ND!=NIL||files==NIL&&oldfiles!=NIL)
+ { if(make_status==1)make_status=0;
+ make_status=strcons(s,make_status); }
+ /* keep list of source files with error-dumps */
+ }
+ if(tag[make_status]==STRCONS)
+ { word h=0,maxw=0,w,n;
+ printf("errors or undefined names found in:-\n");
+ while(make_status) /* reverse to get original order */
+ { h=strcons(hd[make_status],h);
+ w=strlen((char *)hd[h]);
+ if(w>maxw)maxw=w;
+ make_status=tl[make_status]; }
+ maxw++;n=78/maxw;w=0;
+ while(h)
+ printf("%*s%s",maxw,(char *)hd[h],(++w%n)?"":"\n"),
+ h=tl[h];
+ if(w%n)printf("\n");
+ make_status=1; }
+ exit(make_status); }
+ initscript= argc==1?"script.m":magic?argv[1]:addextn(1,argv[1]);
+ if(initscript==dicp)keep(dicp);
+#if sparc8
+ fpsetmask(commonmask);
+#elif defined sparc
+ ieee_handler("set","common",(sighandler)fpe_error);
+#endif
+#if !defined sparc | sparc8
+ (void)signal(SIGFPE,(sighandler)fpe_error); /* catch arithmetic overflow */
+#endif
+ (void)signal(SIGTERM,(sighandler)exit); /* flush buffers if killed */
+ commandloop(initscript);
+ /* parameter is file given as argument */
+}
+
+word vstack[4]; /* record of miralib versions looked at */
+char *mstack[4]; /* and where found */
+word mvp=0;
+
+checkversion(m)
+/* returns 1 iff m is directory with .version containing our version number */
+char *m;
+{ word v1,read=0,r=0;
+ FILE *f=fopen(strcat(strcpy(linebuf,m),"/.version"),"r");
+ if(f&&fscanf(f,"%u",&v1)==1)r= v1==version, read=1;
+ if(f)fclose(f);
+ if(read&&!r)mstack[mvp]=m,vstack[mvp++]=v1;
+ return r;
+}
+
+libfails()
+{ word i=0;
+ fprintf(stderr,"found");
+ for(;i<mvp;i++)fprintf(stderr,"\tversion %s at: %s\n",
+ strvers(vstack[i]),mstack[i]);
+}
+
+char *strvers(v)
+{ static char vbuf[12];
+ if(v<0||v>999999)return "\?\?\?";
+ snprintf(vbuf,12,"%.3f",v/1000.0);
+ return vbuf;
+}
+
+char *mkabsolute(m) /* make sure m is an absolute pathname */
+char *m;
+{ if(m[0]=='/')return(m);
+ if(!getcwd(dicp,pnlim))fprintf(stderr,"panic: cwd too long\n"),exit(1);
+ (void)strcat(dicp,"/");
+ (void)strcat(dicp,m);
+ m=dicp;
+ dicp=dicq+=strlen(dicp)+1;
+ dic_check();
+ return(m);
+}
+
+missparam(s)
+char *s;
+{ fprintf(stderr,"mira: missing param after flag \"-%s\"\n",s);
+ exit(1); }
+
+word oldversion=0;
+#define colmax 400
+#define spaces(s) for(j=s;j>0;j--)putchar(' ')
+
+announce()
+{ extern char *vdate;
+ word w,j;
+/*clrscr(); /* clear screen on start up */
+ w=(twidth()-50)/2;
+ printf("\n\n");
+ spaces(w); printf(" T h e M i r a n d a S y s t e m\n\n");
+ spaces(w+5-strlen(vdate)/2);
+ printf(" version %s last revised %s\n\n",strvers(version),vdate);
+ spaces(w); printf("Copyright Research Software Ltd 1985-2019\n\n");
+ spaces(w); printf(" World Wide Web: http://miranda.org.uk\n\n\n");
+ if(SPACELIMIT!=DFLTSPACE)
+ printf("(%d cells)\n",SPACELIMIT);
+ if(!strictif)printf("(-nostrictif : deprecated!)\n");
+/*printf("\t\t\t\t%dbit platform\n",__WORDSIZE); /* */
+ if(oldversion<1999) /* pre release two */
+ printf("\
+WARNING:\n\
+a new release of Miranda has been installed since you last used\n\
+the system - please read the `CHANGES' section of the /man pages !!!\n\n");
+ else
+ if(version>oldversion)
+ printf("a new version of Miranda has been installed since you last\n"),
+ printf("used the system - see under `CHANGES' in the /man pages\n\n");
+ if(version<oldversion)
+ printf("warning - this is an older version of Miranda than the one\n"),
+ printf("you last used on this machine!!\n\n");
+ if(rc_error)
+ printf("warning: \"%s\" contained bad data (ignored)\n",rc_error);
+}
+
+
+rc_read(rcfile) /* get settings of system parameters from setup file */
+char *rcfile;
+{ FILE *in;
+ char z[20];
+ word h,d,v,s,r=0;
+ oldversion=version; /* default assumption */
+ in=fopen(rcfile,"r");
+ if(in==NULL||fscanf(in,"%19s",z)!=1)
+ return(0); /* file not present, or not readable */
+ if(strncmp(z,"hdve",4)==0 /* current .mirarc format */
+ ||strcmp(z,"lhdve")==0) /* alternative format used at release one */
+ { char *z1 = &z[3];
+ if(z[0]=='l')listing=1,z1++;
+ while(*++z1)if(*z1=='l')listing=1; else
+ if(*z1=='s') /* ignore */; else
+ if(*z1=='r')rechecking=2; else
+ rc_error=rcfile;
+ if(fscanf(in,"%d%d%d%*c",&h,&d,&v)!=3||!getln(in,pnlim-1,ebuf)
+ ||badval(h)||badval(d)||badval(v))rc_error=rcfile;
+ else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1,
+ oldversion=v; } else
+ if(strcmp(z,"ehdsv")==0) /* versions before 550 */
+ { if(fscanf(in,"%19s%d%d%d%d",ebuf,&h,&d,&s,&v)!=5
+ ||badval(h)||badval(d)||badval(v))rc_error=rcfile;
+ else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1,
+ oldversion=v; } else
+ if(strcmp(z,"ehds")==0) /* versions before 326, "s" was stacklimit (ignore) */
+ { if(fscanf(in,"%s%d%d%d",ebuf,&h,&d,&s)!=4
+ ||badval(h)||badval(d))rc_error=rcfile;
+ else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1,
+ oldversion=1; }
+ else rc_error=rcfile; /* unrecognised format */
+ if(editor)fixeditor();
+ fclose(in);
+ return(r);
+}
+
+fixeditor()
+{ if(strcmp(editor,"vi")==0)editor="vi +!"; else
+ if(strcmp(editor,"pico")==0)editor="pico +!"; else
+ if(strcmp(editor,"nano")==0)editor="nano +!"; else
+ if(strcmp(editor,"joe")==0)editor="joe +!"; else
+ if(strcmp(editor,"jpico")==0)editor="jpico +!"; else
+ if(strcmp(editor,"vim")==0)editor="vim +!"; else
+ if(strcmp(editor,"gvim")==0)editor="gvim +! % &"; else
+ if(strcmp(editor,"emacs")==0)editor="emacs +! % &";
+ else { char *p=rindex(editor,'/');
+ if(p==0)p=editor; else p++;
+ if(strcmp(p,"vi")==0)strcat(p," +!");
+ }
+ if(rindex(editor,'&'))rechecking=2;
+ listing=badeditor();
+}
+
+badeditor() /* does editor know how to open file at line? */
+{ char *p=index(editor,'!');
+ while(p&&p[-1]=='\\')p=index(p+1,'!');
+ return (baded = !p);
+}
+
+getln(in,n,s) /* reads line (<=n chars) from in into s - returns 1 if ok */
+FILE *in; /* the newline is discarded, and the result '\0' terminated */
+word n;
+char *s;
+{ while(n--&&(*s=getc(in))!='\n')s++;
+ if(*s!='\n'||n<0)return(0);
+ *s='\0';
+ return(1);
+} /* what a pain that `fgets' doesn't do it right !! */
+
+rc_write()
+{ FILE *out=fopen(home_rc,"w");
+ if(out==NULL)
+ { fprintf(stderr,"warning: cannot write to \"%s\"\n",home_rc);
+ return; }
+ fprintf(out,"hdve");
+ if(listing)fputc('l',out);
+ if(rechecking==2)fputc('r',out);
+ fprintf(out," %d %d %d %s\n",SPACELIMIT,DICSPACE,version,editor);
+ fclose(out);
+}
+
+word lastid=0; /* first inscope identifier of immediately preceding command */
+word rv_expr=0;
+
+commandloop(initscript)
+char* initscript;
+{ word ch;
+ word reset();
+ extern word cook_stdin,polyshowerror;
+ char *lb;
+ if(setjmp(env)==0) /* returns here if interrupted, 0 means first time thru */
+ { if(magic){ undump(initscript); /* was loadfile() changed 26.11.2019
+ to allow dump of magic scripts in ".m"*/
+ if(files==NIL||ND!=NIL||id_val(main_id)==UNDEF)
+ /* files==NIL=>script absent or has syntax errors
+ ND!=NIL=>script has type errors or undefined names
+ all reported by undump() or loadfile() on new compile */
+ { if(files!=NIL&&ND==NIL&&id_val(main_id)==UNDEF)
+ fprintf(stderr,"%s: main not defined\n",initscript);
+ fprintf(stderr,"mira: incorrect use of \"-exec\" flag\n");
+ exit(1); }
+ magic=0; obey(main_id); exit(0); }
+ /* was obey(lastexp), change to magic scripts 19.11.2013 */
+ (void)signal(SIGINT,(sighandler)reset);
+ undump(initscript);
+ if(verbosity)printf("for help type /h\n"); }
+ for(;;)
+ { resetgcstats();
+ if(verbosity)printf("%s",promptstr);
+ ch = getchar();
+ if(rechecking&&src_update())loadfile(current_script);
+ /* modified behaviour for `2-window' mode */
+ while(ch==' '||ch=='\t')ch=getchar();
+ switch(ch)
+ { case '?': ch=getchar();
+ if(ch=='?')
+ { word x; char *aka=NULL;
+ if(!token()&&!lastid)
+ { printf("\7identifier needed after `\?\?'\n");
+ ch=getchar(); /* '\n' */
+ break; }
+ if(getchar()!='\n'){ xschars(); break; }
+ if(baded){ ed_warn(); break; }
+ if(dicp[0])x=findid(dicp);
+ else printf("??%s\n",get_id(lastid)),x=lastid;
+ if(x==NIL||id_type(x)==undef_t)
+ { diagnose(dicp[0]?dicp:get_id(lastid));
+ lastid=0;
+ break; }
+ if(id_who(x)==NIL)
+ { /* nb - primitives have NIL who field */
+ printf("%s -- primitive to Miranda\n",
+ dicp[0]?dicp:get_id(lastid));
+ lastid=0;
+ break; }
+ lastid=x;
+ x=id_who(x); /* get here info */
+ if(tag[x]==CONS)aka=(char *)hd[hd[x]],x=tl[x];
+ if(aka)printf("originally defined as \"%s\"\n",
+ aka);
+ editfile((char *)hd[x],tl[x]);
+ break; }
+ ungetc(ch,stdin);
+ (void)token();
+ lastid=0;
+ if(dicp[0]=='\0')
+ { if(getchar()!='\n')xschars();
+ else allnamescom();
+ break; }
+ while(dicp[0])finger(dicp),(void)token();
+ ch=getchar();
+ break;
+ case ':': /* add (silently) as kindness to Hugs users */
+ case '/': (void)token();
+ lastid=0;
+ command(ch);
+ break;
+ case '!': if(!(lb=rdline()))break; /* rdline returns NULL on failure */
+ lastid=0;
+ if(*lb)
+ { /*system(lb); */ /* always gives /bin/sh */
+ static char *shell=NULL;
+ sighandler oldsig;
+ word pid;
+ if(!shell)
+ { shell=getenv("SHELL");
+ if(!shell)shell="/bin/sh"; }
+ oldsig= signal(SIGINT,SIG_IGN);
+ if(pid=fork())
+ { /* parent */
+ if(pid==-1)
+ perror("UNIX error - cannot create process");
+ while(pid!=wait(0));
+ (void)signal(SIGINT,oldsig); }
+ else execl(shell,shell,"-c",lb,(char *)0);
+ if(src_update())loadfile(current_script); }
+ else printf(
+ "No previous shell command to substitute for \"!\"\n");
+ break;
+ case '|': /* lines beginning "||" are comments */
+ if((ch=getchar())!='|')
+ printf("\7unknown command - type /h for help\n");
+ while(ch!='\n'&&ch!=EOF)ch=getchar();
+ case '\n': break;
+ case EOF: if(verbosity)printf("\nmiranda logout\n");
+ exit(0);
+ default: ungetc(ch,stdin);
+ lastid=0;
+ tl[hd[cook_stdin]]=0; /* unset type of $+ */
+ rv_expr=0;
+ c = EVAL;
+ echoing=0;
+ polyshowerror=0; /* gets set by wrong use of $+, readvals */
+ commandmode=1;
+ yyparse();
+ if(SYNERR)SYNERR=0;
+ else if(c!='\n') /* APPARENTLY NEVER TRUE */
+ { printf("syntax error\n");
+ while(c!='\n'&&c!=EOF)
+ c=getchar(); /* swallow syntax errors */
+ }
+ commandmode=0;
+ echoing=verbosity&listing;
+}}}
+
+parseline(t,f,fil) /* parses next valid line of f at type t, returns EOF
+ if none found. See READVALS in reduce.c */
+word t;
+FILE *f;
+word fil;
+{ word t1,ch;
+ lastexp=UNDEF;
+ for(;;)
+ { ch=getc(f);
+ while(ch==' '||ch=='\t'||ch=='\n')ch=getc(f);
+ if(ch=='|')
+ { ch=getc(f);
+ if(ch=='|') /* leading comment */
+ { while((ch=getc(f))!='\n'&&ch!=EOF);
+ if(ch!=EOF)continue; }
+ else ungetc(ch,f); }
+ if(ch==EOF)return(EOF);
+ ungetc(ch,f);
+ c = VALUE;
+ echoing=0;
+ commandmode=1;
+ s_in=f;
+ yyparse();
+ s_in=stdin;
+ if(SYNERR)SYNERR=0,lastexp=UNDEF; else
+ if((t1=type_of(lastexp))==wrong_t)lastexp=UNDEF; else
+ if(!subsumes(instantiate(t1),t))
+ { printf("data has wrong type :: "), out_type(t1),
+ printf("\nshould be :: "), out_type(t), putc('\n',stdout);
+ lastexp=UNDEF; }
+ if(lastexp!=UNDEF)return(codegen(lastexp));
+ if(isatty(fileno(f)))printf("please re-enter data:\n");
+ else { if(fil)fprintf(stderr,"readvals: bad data in file \"%s\"\n",
+ getstring(fil,0));
+ else fprintf(stderr,"bad data in $+ input\n");
+ outstats(); exit(1); }
+}}
+
+ed_warn()
+{ printf(
+"The currently installed editor command, \"%s\", does not\n\
+include a facility for opening a file at a specified line number. As a\n\
+result the `\?\?' command and certain other features of the Miranda system\n\
+are disabled. See manual section 31/5 on changing the editor for more\n\
+information.\n",editor);
+}
+
+time_t fm_time(f) /* time last modified of file f */
+char *f;
+{ return(stat(f,&buf)==0?buf.st_mtime:0);
+ /* non-existent file has conventional mtime of 0 */
+} /* WARNING - we assume time_t can be stored in an int field
+ - this may not port */
+
+#define same_file(x,y) (hd[fil_inodev(x)]==hd[fil_inodev(y)]&& \
+ tl[fil_inodev(x)]==tl[fil_inodev(y)])
+#define inodev(f) (stat(f,&buf)==0?datapair(buf.st_ino,buf.st_dev):\
+ datapair(0,-1))
+
+word oldfiles=NIL; /* most recent set of sources, in case of interrupted or
+ failed compilation */
+src_update() /* any sources modified ? */
+{ word ft,f=files==NIL?oldfiles:files;
+ while(f!=NIL)
+ { if((ft=fm_time(get_fil(hd[f])))!=fil_time(hd[f]))
+ { if(ft==0)unlinkx(get_fil(hd[f])); /* tidy up after eg `!rm %' */
+ return(1); }
+ f=tl[f]; }
+ return(0);
+}
+
+word loading;
+char *unlinkme; /* if set, is name of partially created obfile */
+
+reset() /* interrupt catcher - see call to signal in commandloop */
+{ extern word lineptr,ATNAMES,current_id;
+ extern word blankerr,collecting/* ,*dstack,*stackp */;
+ /*if(!making) /* see note below
+ (void)signal(SIGINT,SIG_IGN); /* dont interrupt me while I'm tidying up */
+/*if(magic)exit(0); *//* signal now not set to reset in magic scripts */
+ if(collecting)gcpatch();
+ if(loading)
+ { if(!blankerr)
+ printf("\n<<compilation interrupted>>\n");
+ if(unlinkme)unlink(unlinkme);
+ /* stackp=dstack; /* add if undump() made interruptible later*/
+ oldfiles=files,unload(),current_id=ATNAMES=loading=SYNERR=lineptr=0;
+ if(blankerr)blankerr=0,makedump(); }
+ /* magic script cannot be literate so no guard needed on makedump */
+ else printf("<<interrupt>>\n"); /* VAX, SUN, ^C does not cause newline */
+ reset_state(); /* see LEX */
+ if(collecting)collecting=0,gc(); /* to mark stdenv etc as wanted */
+ if(making&&!make_status)make_status=1;
+#ifdef SYSTEM5
+ else (void)signal(SIGINT,(sighandler)reset);/*ready for next interrupt*//*see note*/
+#endif
+ /* during mira -make blankerr is only use of reset */
+ longjmp(env,1);
+}/* under BSD and Linux installed signal remains installed after interrupt
+ and further signals blocked until handler returns */
+
+#define checkeol if(getchar()!='\n')break;
+
+word lose;
+
+normal(f) /* s has ".m" suffix */
+char *f;
+{ word n=strlen(f);
+ return n>=2&&strcmp(f+n-2,".m")==0;
+}
+
+v_info(word full)
+{ printf("%s last revised %s\n",strvers(version),vdate);
+ if(!full)return;
+ printf("%s",host);
+ printf("XVERSION %u\n",XVERSION);
+}
+
+
+command(c)
+word c;
+{ char *t;
+ word ch,ch1;
+ switch(dicp[0])
+ {
+ case 'a': if(is("a")||is("aux"))
+ { checkeol;
+/* if(verbosity)clrscr(); */
+ (void)strcpy(linebuf,miralib);
+ (void)strcat(linebuf,"/auxfile");
+ filecopy(linebuf);
+ return; }
+ case 'c': if(is("count"))
+ { checkeol; atcount=1; return; }
+ if(is("cd"))
+ { char *d=token();
+ if(!d)d=getenv("HOME");
+ else d=addextn(0,d);
+ checkeol;
+ if(chdir(d)==-1)printf("cannot cd to %s\n",d);
+ else if(src_update())undump(current_script);
+ /* alternative: keep old script and recompute pathname
+ wrt new directory - LOOK INTO THIS LATER */
+ return; }
+ case 'd': if(is("dic"))
+ { extern char *dic;
+ if(!token())
+ { lose=getchar(); /* to eat \n */
+ printf("%d chars",DICSPACE);
+ if(DICSPACE!=DFLTDICSPACE)
+ printf(" (default=%d)",DFLTDICSPACE);
+ printf(" %d in use\n",dicq-dic);
+ return; }
+ checkeol;
+ printf(
+ "sorry, cannot change size of dictionary while in use\n");
+ printf(
+ "(/q and reinvoke with flag: mira -dic %s ... )\n",dicp);
+ return; }
+ case 'e': if(is("e")||is("edit"))
+ { char *mf=0;
+ if(t=token())t=addextn(1,t);
+ else t=current_script;
+ checkeol;
+ if(stat(t,&buf)) /* new file */
+ { if(!lmirahdr) /* lazy initialisation */
+ { dicp=dicq;
+ (void)strcpy(dicp,getenv("HOME"));
+ if(strcmp(dicp,"/")==0)
+ dicp[0]=0; /* root is special case */
+ (void)strcat(dicp,"/.mirahdr");
+ lmirahdr=dicp;
+ dicq=dicp=dicp+strlen(dicp)+1; } /* ovflo check? */
+ if(!stat(lmirahdr,&buf))mf=lmirahdr;
+ if(!mf&&!mirahdr) /* lazy initialisation */
+ { dicp=dicq;
+ (void)strcpy(dicp,miralib);
+ (void)strcat(dicp,"/.mirahdr");
+ mirahdr=dicp;
+ dicq=dicp=dicp+strlen(dicp)+1; }
+ if(!mf&&!stat(mirahdr,&buf))mf=mirahdr;
+ /*if(mf)printf("mf=%s\n",mf); /* DEBUG*/
+ if(mf&&t!=current_script)
+ { printf("open new script \"%s\"? [ny]",t);
+ ch1=ch=getchar();
+ while(ch!='\n'&&ch!=EOF)ch=getchar();
+ /*eat rest of line */
+ if(ch1!='y'&&ch1!='Y')return; }
+ if(mf)filecp(mf,t); }
+ editfile(t,strcmp(t,current_script)==0?errline:
+ errs&&strcmp(t,(char *)hd[errs])==0?tl[errs]:
+ geterrlin(t));
+ return; }
+ if(is("editor"))
+ { char *hold=linebuf,*h;
+ if(!getln(stdin,pnlim-1,hold))break; /*reject if too long*/
+ if(!*hold)
+ { /* lose=getchar(); /* to eat newline */
+ printf("%s\n",editor);
+ return; }
+ h=hold+strlen(hold); /* remove trailing white space */
+ while(h[-1]==' '||h[-1]=='\t')*--h='\0';
+ if(*hold=='"'||*hold=='\'')
+ { printf("please type name of editor without quotation marks\n");
+ return; }
+ printf("change editor to: \"%s\"? [ny]",hold);
+ ch1=ch=getchar();
+ while(ch!='\n'&&ch!=EOF)ch=getchar(); /* eat rest of line */
+ if(ch1!='y'&&ch1!='Y')
+ { printf("editor not changed\n");
+ return; }
+ (void)strcpy(ebuf,hold);
+ editor=ebuf;
+ fixeditor(); /* reads "vi" as "vi +!" etc */
+ echoing=verbosity&listing;
+ rc_write();
+ printf("editor = %s\n",editor);
+ return; }
+ case 'f': if(is("f")||is("file"))
+ { char *t=token();
+ checkeol;
+ if(t)t=addextn(1,t),keep(t);
+ /* could get multiple copies of filename in dictionary
+ - FIX LATER */
+ if(t)errs=errline=0; /* moved here from reset() */
+ if(t)if(strcmp(t,current_script)||files==NIL&&okdump(t))
+ { extern word CLASHES;
+ CLASHES=NIL; /* normally done by load_script */
+ undump(t); /* does not always call load_script */
+ if(CLASHES!=NIL)/* pathological case, recompile */
+ loadfile(t); }
+ else loadfile(t); /* force recompilation */
+ else printf("%s%s\n",current_script,
+ files==NIL?" (not loaded)":"");
+ return; }
+ if(is("files")) /* info about internal state, not documented */
+ { word f=files;
+ checkeol;
+ for(;f!=NIL;f=tl[f])
+ printf("(%s,%d,%d)",get_fil(hd[f]),fil_time(hd[f]),
+ fil_share(hd[f])),printlist("",fil_defs(hd[f]));
+ return; } /* DEBUG */
+ if(is("find"))
+ { word i=0;
+ while(token())
+ { word x=findid(dicp),y,f;
+ i++;
+ if(x!=NIL)
+ { char *n=get_id(x);
+ for(y=primenv;y!=NIL;y=tl[y])
+ if(tag[hd[y]]==ID)
+ if(hd[y]==x||getaka(hd[y])==n)
+ finger(get_id(hd[y]));
+ for(f=files;f!=NIL;f=tl[f])
+ for(y=fil_defs(hd[f]);y!=NIL;y=tl[y])
+ if(tag[hd[y]]==ID)
+ if(hd[y]==x||getaka(hd[y])==n)
+ finger(get_id(hd[y])); }
+ }
+ ch=getchar(); /* '\n' */
+ if(i==0)printf("\7identifier needed after `/find'\n");
+ return; }
+ case 'g': if(is("gc"))
+ { checkeol; atgc=1; return; }
+ case 'h': if(is("h")||is("help"))
+ { checkeol;
+/* if(verbosity)clrscr(); */
+ (void)strcpy(linebuf,miralib);
+ (void)strcat(linebuf,"/helpfile");
+ filecopy(linebuf);
+ return; }
+ if(is("heap"))
+ { word x;
+ if(!token())
+ { lose=getchar(); /* to eat \n */
+ printf("%d cells",SPACELIMIT);
+ if(SPACELIMIT!=DFLTSPACE)
+ printf(" (default=%d)",DFLTSPACE);
+ printf("\n");
+ return; }
+ checkeol;
+ if(sscanf(dicp,"%d",&x)!=1||badval(x))
+ { printf("illegal value (heap unchanged)\n"); return; }
+ if(x<trueheapsize())
+ printf("sorry, cannot shrink heap to %d at this time\n",x);
+ else { if(x!=SPACELIMIT)
+ SPACELIMIT=x,resetheap();
+ printf("heaplimit = %d cells\n",SPACELIMIT),
+ rc_write(); }
+ return; }
+ if(is("hush"))
+ { checkeol; echoing=verbosity=0; return; }
+ case 'l': if(is("list"))
+ { checkeol; listing=1; echoing=verbosity&listing;
+ rc_write(); return; }
+ case 'm': if(is("m")||is("man"))
+ { checkeol; manaction(); return; }
+ if(is("miralib"))
+ { checkeol; printf("%s\n",miralib); return; }
+ case 'n': /* if(is("namebuckets"))
+ { int i,x;
+ extern int namebucket[];
+ checkeol;
+ for(i=0;i<128;i++)
+ if(x=namebucket[i])
+ { printf("%d:",i);
+ while(x)
+ putchar(' '),out(stdout,hd[x]),x=tl[x];
+ putchar('\n'); }
+ return; } /* DEBUG */
+ if(is("nocount"))
+ { checkeol; atcount=0; return; }
+ if(is("nogc"))
+ { checkeol; atgc=0; return; }
+ if(is("nohush"))
+ { checkeol; echoing=listing; verbosity=1; return; }
+ if(is("nolist"))
+ { checkeol; echoing=listing=0; rc_write(); return; }
+ if(is("norecheck"))
+ { checkeol; rechecking=0; rc_write(); return; }
+/* case 'o': if(is("object"))
+ { checkeol; atobject=1; return; } /* now done by flag -object */
+ case 'q': if(is("q")||is("quit"))
+ { checkeol; if(verbosity)printf("miranda logout\n"); exit(0); }
+ case 'r': if(is("recheck"))
+ { checkeol; rechecking=2; rc_write(); return; }
+ case 's': if(is("s")||is("settings"))
+ { checkeol;
+ printf("*\theap %d\n",SPACELIMIT);
+ printf("*\tdic %d\n",DICSPACE);
+ printf("*\teditor = %s\n",editor);
+ printf("*\t%slist\n",listing?"":"no");
+ printf("*\t%srecheck\n",rechecking?"":"no");
+ if(!strictif)
+ printf("\t-nostrictif (deprecated!)\n");
+ if(atcount)printf("\tcount\n");
+ if(atgc)printf("\tgc\n");
+ if(UTF8)printf("\tUTF-8 i/o\n");
+ if(!verbosity)printf("\thush\n");
+ if(debug)printf("\tdebug 0%o\n",debug);
+ printf("\n* items remembered between sessions\n");
+ return; }
+ case 'v': if(is("v")||is("version"))
+ { checkeol;
+ v_info(0);
+ return; }
+ case 'V': if(is("V"))
+ { checkeol;
+ v_info(1);
+ return; }
+ default: printf("\7unknown command \"%c%s\"\n",c,dicp);
+ printf("type /h for help\n");
+ while((ch=getchar())!='\n'&&ch!=EOF);
+ return;
+ } /* end of switch statement */
+ xschars();
+}
+
+manaction()
+{ sprintf(linebuf,"\"%s/menudriver\" \"%s/manual\"",miralib,miralib);
+ system(linebuf);
+} /* put quotes around both pathnames to allow for spaces in miralib 8.5.06 */
+
+editfile(t,line)
+char *t;
+word line;
+{ char *ebuf=linebuf;
+ char *p=ebuf,*q=editor;
+ word tdone=0;
+ if(line==0)line=1; /* avoids warnings in some versions of vi */
+ while(*p++ = *q++)
+ if(p[-1]=='\\'&&(q[0]=='!'||q[0]=='%'))p[-1]= *q++; else
+ if(p[-1]=='!')
+ (void)
+ sprintf(p-1,"%d",line),
+ p+=strlen(p); else
+ if(p[-1]=='%')p[-1]='"',*p='\0', /* quote filename 9.5.06 */
+ (void)strncat(p,t,BUFSIZE+ebuf-p),
+ p+=strlen(p),
+ *p++ = '"',*p='\0',
+ tdone=1;
+ if(!tdone)
+ p[-1] = ' ',
+ *p++ = '"',*p='\0', /* quote filename 9.5.06 */
+ (void)strncat(p,t,BUFSIZE+ebuf-p),
+ p+=strlen(p),
+ *p++ = '"',*p='\0';
+ /* printf("%s\n",ebuf); /* DEBUG */
+ system(ebuf);
+ if(src_update())loadfile(current_script);
+ return;
+}
+
+xschars()
+{ word ch;
+ printf("\7extra characters at end of command\n");
+ while((ch=getchar())!='\n'&&ch!=EOF);
+}
+
+reverse(x) /* x is a cons list */
+word x;
+{ word y = NIL;
+ while(x!=NIL)y = cons(hd[x],y), x = tl[x];
+ return(y);
+}
+
+shunt(x,y) /* equivalent to append(reverse(x),y) */
+word x,y;
+{ while(x!=NIL)y = cons(hd[x],y), x = tl[x];
+ return(y);
+}
+
+char *presym[] =
+ {"abstype","div","if","mod","otherwise","readvals","show","type","where",
+ "with", 0};
+word presym_n[] =
+ { 21, 8, 15, 8, 15, 31, 23, 22, 15,
+ 21 };
+
+#include <ctype.h>
+
+filequote(p) /* write p to stdout with <quotes> if appropriate */
+char *p; /* p is a pathname */
+{ static mlen=0;
+ if(!mlen)mlen=(rindex(PRELUDE,'/')-PRELUDE)+1;
+ if(strncmp(p,PRELUDE,mlen)==0)
+ printf("<%s>",p+mlen);
+ else printf("\"%s\"",p);
+} /* PRELUDE is a convenient string with the miralib prefix */
+
+finger(n) /* find info about name stored at dicp */
+char *n;
+{ word x,line;
+ char *s;
+ x=findid(n);
+ if(x!=NIL&&id_type(x)!=undef_t)
+ { if(id_who(x)!=NIL)
+ s=(char *)hd[line=get_here(x)],line=tl[line];
+ if(!lastid)lastid=x;
+ report_type(x);
+ if(id_who(x)==NIL)printf(" ||primitive to Miranda\n");
+ else { char *aka=getaka(x);
+ if(aka==get_id(x))aka=NULL; /* don't report alias to self */
+ if(id_val(x)==UNDEF&&id_type(x)!=wrong_t)
+ printf(" ||(UNDEFINED) specified in "); else
+ if(id_val(x)==FREE)
+ printf(" ||(FREE) specified in "); else
+ if(id_type(x)==type_t&&t_class(x)==free_t)
+ printf(" ||(free type) specified in "); else
+ printf(" ||%sdefined in ",
+ id_type(x)==type_t
+ && t_class(x)==abstract_t?"(abstract type) ":
+ id_type(x)==type_t
+ && t_class(x)==algebraic_t?"(algebraic type) ":
+ id_type(x)==type_t
+ && t_class(x)==placeholder_t?"(placeholder type) ":
+ id_type(x)==type_t
+ && t_class(x)==synonym_t?"(synonym type) ":
+ "");
+ filequote(s);
+ if(baded||rechecking)printf(" line %d",line);
+ if(aka)printf(" (as \"%s\")\n",aka);
+ else putchar('\n');
+ }
+ if(atobject)printf("%s = ",get_id(x)),
+ out(stdout,id_val(x)),putchar('\n');
+ return; }
+ diagnose(n);
+}
+
+diagnose(n)
+char *n;
+{ word i=0;
+ if(isalpha(n[0]))
+ while(n[i]&&okid(n[i]))i++;
+ if(n[i]){ printf("\"%s\" -- not an identifier\n",n); return; }
+ for(i=0;presym[i];i++)
+ if(strcmp(n,presym[i])==0)
+ { printf("%s -- keyword (see manual, section %d)\n",n,presym_n[i]);
+ return; }
+ printf("identifier \"%s\" not in scope\n",n);
+}
+
+static word sorted=0; /* flag to avoid repeatedly sorting fil_defs */
+static word leftist; /* flag to alternate bias of padding in justification */
+word words[colmax]; /* max plausible size of screen */
+
+allnamescom()
+{ word s;
+ word x=ND;
+ word y=x,z=0;
+ leftist=0;
+ namescom(make_fil(nostdenv?0:STDENV,0,0,primenv));
+ if(files==NIL)return; else s=tl[files];
+ while(s!=NIL)namescom(hd[s]),s=tl[s];
+ namescom(hd[files]);
+ sorted=1;
+ /* now print warnings, if any */
+ /*if(ND!=NIL&&id_type(hd[ND])==type_t)
+ { printf("ILLEGAL EXPORT LIST - MISSING TYPENAME%s: ",tl[ND]==NIL?"":"S");
+ printlist("",ND);
+ return; } /* install if incomplete export list is escalated to error */
+ while(x!=NIL&&id_type(hd[x])==undef_t)x=tl[x];
+ while(y!=NIL&&id_type(hd[y])!=undef_t)y=tl[y];
+ if(x!=NIL)
+ { printf("WARNING, SCRIPT CONTAINS TYPE ERRORS: ");
+ for(;x!=NIL;x=tl[x])
+ if(id_type(hd[x])!=undef_t)
+ { if(!z)z=1; else putchar(',');
+ out(stdout,hd[x]); }
+ printf(";\n"); }
+ if(y!=NIL)
+ { printf("%s UNDEFINED NAMES: ",z?"AND":"WARNING, SCRIPT CONTAINS");
+ z=0;
+ for(;y!=NIL;y=tl[y])
+ if(id_type(hd[y])==undef_t)
+ { if(!z)z=1; else putchar(',');
+ out(stdout,hd[y]); }
+ printf(";\n"); }
+}
+/* There are two kinds of entry in ND
+ undefined names: val=UNDEF, type=undef_t
+ type errors: val=UNDEF, type=wrong_t
+*/
+
+#define tolerance 3
+ /* max number of extra spaces we are willing to insert */
+
+namescom(l) /* l is an element of `files' */
+word l;
+{ word n=fil_defs(l),col=0,undefs=NIL,wp=0;
+ word scrwd = twidth();
+ if(!sorted&&n!=primenv) /* primenv already sorted */
+ fil_defs(l)=n=alfasort(n); /* also removes pnames */
+ if(n==NIL)return; /* skip empty files */
+ if(get_fil(l))filequote(get_fil(l));
+ else printf("primitive:");
+ printf("\n");
+ while(n!=NIL)
+ { if(id_type(hd[n])==wrong_t||id_val(hd[n])!=UNDEF)
+ { word w=strlen(get_id(hd[n]));
+ if(col+w<scrwd)col += (col!=0); else
+ if(wp&&col+w>=scrwd)
+ { word i,r,j;
+ if(wp>1)i=(scrwd-col)/(wp-1),r=(scrwd-col)%(wp-1);
+ if(i+(r>0)>tolerance)i=r=0;
+ if(leftist)
+ for(col=0;col<wp;)
+ { printf("%s",get_id(words[col]));
+ if(++col<wp)
+ spaces(1+i+(r-- >0)); }
+ else
+ for(r=wp-1-r,col=0;col<wp;)
+ { printf("%s",get_id(words[col]));
+ if(++col<wp)
+ spaces(1+i+(r-- <=0)); }
+ leftist=!leftist,wp=0,col=0,putchar('\n'); }
+ col+=w;
+ words[wp++]=hd[n]; }
+ else undefs=cons(hd[n],undefs); /* undefined but have good types */
+ n = tl[n]; }
+ if(wp)
+ for(col=0;col<wp;)
+ printf("%s",get_id(words[col])),putc(++col==wp?'\n':' ',stdout);
+ if(undefs==NIL)return;
+ undefs=reverse(undefs);
+ printlist("SPECIFIED BUT NOT DEFINED: ",undefs);
+}
+
+word detrop=NIL; /* list of unused local definitions */
+word rfl=NIL; /* list of include components containing type orphans */
+word bereaved; /* typenames referred to in exports and not exported */
+word ld_stuff=NIL;
+ /* list of list of files, to be unloaded if mkincludes interrupted */
+
+loadfile(t)
+char *t;
+{ extern word fileq;
+ extern word current_id,includees,embargoes,exportfiles,freeids,exports;
+ extern word fnts,FBS,disgusting,nextpn;
+ word h=NIL; /* location of %export directive, if present */
+ loading=1;
+ errs=errline=0;
+ current_script=t;
+ oldfiles=NIL;
+ unload();
+ if(stat(t,&buf))
+ { if(initialising){ fprintf(stderr,"panic: %s not found\n",t); exit(1); }
+ if(verbosity)printf("new file %s\n",t);
+ if(magic)fprintf(stderr,"mira -exec %s%s\n",t,": no such file"),exit(1);
+ if(making&&ideep==0)printf("mira -make %s%s\n",t,": no such file");
+ else oldfiles=cons(make_fil(t,0,0,NIL),NIL);
+ /* for correct record of sources */
+ loading=0;
+ return; }
+ if(!openfile(t))
+ { if(initialising){ fprintf(stderr,"panic: cannot open %s\n",t); exit(1); }
+ printf("cannot open %s\n",t);
+ oldfiles=cons(make_fil(t,0,0,NIL),NIL);
+ loading=0;
+ return; }
+ files = cons(make_fil(t,fm_time(t),1,NIL),NIL);
+ current_file = hd[files],tl[hd[fileq]] = current_file;
+ if(initialising&&strcmp(t,PRELUDE)==0)privlib(); else
+ if(initialising||nostdenv==1)
+ if(strcmp(t,STDENV)==0)stdlib();
+ c = ' ';
+ col = 0;
+ s_in = (FILE *)hd[hd[fileq]];
+ adjust_prefix(t);
+/*if(magic&&!initialising)
+ { if(!(getc(s_in)=='#'&&getc(s_in)=='!'))
+ { files=NIL; return; }
+ while(getc(s_in)!='\n');
+ commandmode=1;
+ c=MAGIC; }
+ else /* change to magic scripts 19.11.2013 */
+ commandmode = 0;
+ if(verbosity||making)printf("compiling %s\n",t);
+ nextpn=0; /* lose pnames */
+ embargoes=detrop=
+ fnts=rfl=bereaved=ld_stuff=exportfiles=freeids=exports=includees=FBS=NIL;
+ yyparse();
+ if(!SYNERR&&exportfiles!=NIL)
+ { /* check pathnames in exportfiles have unique bindings */
+ word s,i,count;
+ for(s=exportfiles;s!=NIL;s=tl[s])
+ if(hd[s]==PLUS) /* add current script (less freeids) to exports */
+ { for(i=fil_defs(hd[files]);i!=NIL;i=tl[i])
+ if(isvariable(hd[i])&&!isfreeid(hd[i]))
+ tl[exports]=add1(hd[i],tl[exports]);
+ } else
+ /* pathnames are expanded to their contents in mkincludes */
+ { for(count=0,i=includees;i!=NIL;i=tl[i])
+ if(!strcmp((char *)hd[hd[hd[i]]],(char *)hd[s]))
+ hd[s]=hd[hd[hd[i]]]/*sharing*/,count++;
+ if(count!=1)
+ SYNERR=1,
+ printf("illegal fileid \"%s\" in export list (%s)\n",
+ (char *)hd[s],
+ count?"ambiguous":"not %included in script");
+ }
+ if(SYNERR)
+ sayhere(hd[exports],1),
+ printf("compilation abandoned\n");
+ }
+ if(!SYNERR&&includees!=NIL)
+ files=append1(files,mkincludes(includees)),includees=NIL;
+ ld_stuff=NIL;
+ if(!SYNERR&!disgusting)
+ { if(verbosity||making&&!mkexports&&!mksources)
+ printf("checking types in %s\n",t);
+ checktypes();
+ /* printf("typecheck complete\n"); /* DEBUG */ }
+ if(!SYNERR&&exports!=NIL)
+ if(ND!=NIL)exports=NIL; else /* skip check, cannot be %included */
+ { /* check exports all present and close under type info */
+ word e,u=NIL,n=NIL,c=NIL;
+ h=hd[exports]; exports=tl[exports];
+ for(e=embargoes;e!=NIL;e=tl[e])
+ { if(id_type(hd[e])==undef_t)u=cons(hd[e],u),ND=add1(hd[e],ND); else
+ if(!member(exports,hd[e]))n=cons(hd[e],n); }
+ if(embargoes!=NIL)
+ exports=setdiff(exports,embargoes);
+ exports=alfasort(exports);
+ for(e=exports;e!=NIL;e=tl[e])
+ if(id_type(hd[e])==undef_t)u=cons(hd[e],u),ND=add1(hd[e],ND); else
+ if(id_type(hd[e])==type_t&&t_class(hd[e])==algebraic_t)
+ c=shunt(t_info(hd[e]),c); /* constructors */
+ if(exports==NIL)printf("warning, export list has void contents\n");
+ else exports=append1(alfasort(c),exports);
+ if(n!=NIL)
+ { printf("redundant entr%s in export list:",tl[n]==NIL?"y":"ies");
+ while(n!=NIL)printf(" -%s",get_id(hd[n])),n=tl[n]; n=1; /* flag */
+ putchar('\n'); }
+ if(u!=NIL)exports=NIL,
+ printlist("undefined names in export list: ",u);
+ if(u!=NIL)sayhere(h,1),h=NIL; else
+ if(exports==NIL||n!=NIL)out_here(stderr,h,1),h=NIL;
+ /* for warnings call out_here not sayhere, so errinfo not saved in dump */
+ }
+ if(!SYNERR&&ND==NIL&&(exports!=NIL||tl[files]!=NIL))
+ { /* find out if script can create type orphans when %included */
+ word e1,t;
+ word r=NIL; /* collect list of referenced typenames */
+ word e=NIL; /* and list of exported typenames */
+ if(exports!=NIL)
+ for(e1=exports;e1!=NIL;e1=tl[e1])
+ { if((t=id_type(hd[e1]))==type_t)
+ if(t_class(hd[e1])==synonym_t)
+ r=UNION(r,deps(t_info(hd[e1])));
+ else e=cons(hd[e1],e);
+ else r=UNION(r,deps(t)); } else
+ for(e1=fil_defs(hd[files]);e1!=NIL;e1=tl[e1])
+ { if((t=id_type(hd[e1]))==type_t)
+ if(t_class(hd[e1])==synonym_t)
+ r=UNION(r,deps(t_info(hd[e1])));
+ else e=cons(hd[e1],e);
+ else r=UNION(r,deps(t)); }
+ for(e1=freeids;e1!=NIL;e1=tl[e1])
+ if((t=id_type(hd[hd[e1]]))==type_t)
+ if(t_class(hd[hd[e1]])==synonym_t)
+ r=UNION(r,deps(t_info(hd[hd[e1]])));
+ else e=cons(hd[hd[e1]],e);
+ else r=UNION(r,deps(t));
+ /*printlist("r: ",r); /* DEBUG */
+ for(;r!=NIL;r=tl[r])
+ if(!member(e,hd[r]))bereaved=cons(hd[r],bereaved);
+ /*printlist("bereaved: ",bereaved); /* DEBUG */
+ }
+ if(exports!=NIL&&bereaved!=NIL)
+ { extern word newtyps;
+ word b=intersection(bereaved,newtyps);
+ /*printlist("newtyps",newtyps); /* DEBUG */
+ if(b!=NIL)
+ /*ND=b; /* to escalate to type error, see also allnamescom */
+ printf("warning, export list is incomplete - missing typename%s: ",
+ tl[b]==NIL?"":"s"),
+ printlist("",b);
+ if(b!=NIL&&h!=NIL)out_here(stdout,h,1); /* sayhere(h,1) for error */
+ }
+ if(!SYNERR&&detrop!=NIL)
+ { word gd=detrop;
+ while(detrop!=NIL&&tag[dval(hd[detrop])]==LABEL)detrop=tl[detrop];
+ if(detrop!=NIL)
+ printf("warning, script contains unused local definitions:-\n");
+ while(detrop!=NIL)
+ { out_here(stdout,hd[hd[tl[dval(hd[detrop])]]],0), putchar('\t');
+ out_pattern(stdout,dlhs(hd[detrop])), putchar('\n');
+ detrop=tl[detrop];
+ while(detrop!=NIL&&tag[dval(hd[detrop])]==LABEL)
+ detrop=tl[detrop]; }
+ while(gd!=NIL&&tag[dval(hd[gd])]!=LABEL)gd=tl[gd];
+ if(gd!=NIL)
+ printf("warning, grammar contains unused nonterminals:-\n");
+ while(gd!=NIL)
+ { out_here(stdout,hd[dval(hd[gd])],0), putchar('\t');
+ out_pattern(stdout,dlhs(hd[gd])), putchar('\n');
+ gd=tl[gd];
+ while(gd!=NIL&&tag[dval(hd[gd])]!=LABEL)gd=tl[gd]; }
+ /* note, usual rhs is tries(pat,list(label(here,exp)))
+ grammar rhs is label(here,...) */
+ }
+ if(!SYNERR)
+ { word x; extern word lfrule,polyshowerror;
+ /* we invoke the code generator */
+ lfrule=0;
+ for(x=fil_defs(hd[files]);x!=NIL;x=tl[x])
+ if(id_type(hd[x])!=type_t)
+ { current_id=hd[x];
+ polyshowerror=0;
+ id_val(hd[x])=codegen(id_val(hd[x]));
+ if(polyshowerror)id_val(hd[x])=UNDEF;
+ /* nb - one remaining class of typerrs trapped in codegen,
+ namely polymorphic show or readvals */
+ }
+ current_id=0;
+ if(lfrule&&(verbosity||making))
+ printf("grammar optimisation: %d common left factors found\n",lfrule);
+ if(initialising&&ND!=NIL)
+ { fprintf(stderr,"panic: %s contains errors\n",okprel?"stdenv":"prelude");
+ exit(1); }
+ if(initialising)makedump(); else
+ if(normal(t)) /* file ends ".m", formerly if(!magic) */
+ fixexports(),makedump(),unfixexports();
+ /* changed 26.11.2019 to allow dump of magic scripts ending ".m" */
+ if(!errline&&errs&&(char *)hd[errs]==current_script)
+ errline=tl[errs]; /* soft error (posn not saved in dump) */
+ ND=alfasort(ND);
+ /* we could sort and remove pnames from each defs component immediately
+ after makedump(), instead of doing this in namescom */
+ loading=0;
+ return; }
+ /* otherwise syntax error found */
+ if(initialising)
+ { fprintf(stderr,"panic: cannot compile %s\n",okprel?"stdenv":"prelude"); exit(1); }
+ oldfiles=files;
+ unload();
+ if(normal(t)&&SYNERR!=2)makedump(); /* make syntax error dump */
+ /* allow dump of magic script in ".m", was if(!magic&&) 26.11.2019 */
+ SYNERR=0;
+ loading=0;
+}
+
+isfreeid(x)
+{ return(id_type(x)==type_t?t_class(x)==free_t:id_val(x)==FREE); }
+
+word internals=NIL; /* used by fix/unfixexports, list of names not exported */
+#define paint(x) id_val(x)=ap(EXPORT,id_val(x))
+#define unpainted(x) (tag[id_val(x)]!=AP||hd[id_val(x)]!=EXPORT)
+#define unpaint(x) id_val(x)=tl[id_val(x)]
+
+fixexports()
+{ extern exports,exportfiles,embargoes,freeids;
+ word e=exports,f;
+ /* printlist("exports: ",e); /* DEBUG */
+ for(;e!=NIL;e=tl[e])paint(hd[e]);
+ internals=NIL;
+ if(exports==NIL&&exportfiles==NIL&&embargoes==NIL) /*no %export in script*/
+ { for(e=freeids;e!=NIL;e=tl[e])
+ internals=cons(privatise(hd[hd[e]]),internals);
+ for(f=tl[files];f!=NIL;f=tl[f])
+ for(e=fil_defs(hd[f]);e!=NIL;e=tl[e])
+ { if(tag[hd[e]]==ID)
+ internals=cons(privatise(hd[e]),internals); }}
+ else for(f=files;f!=NIL;f=tl[f])
+ for(e=fil_defs(hd[f]);e!=NIL;e=tl[e])
+ { if(tag[hd[e]]==ID&&unpainted(hd[e]))
+ internals=cons(privatise(hd[e]),internals); }
+ /* optimisation, need not do this to `silent' components - fix later */
+ /*printlist("internals: ",internals); /* DEBUG */
+ for(e=exports;e!=NIL;e=tl[e])unpaint(hd[e]);
+} /* may not be interrupt safe, re unload() */
+
+unfixexports()
+{ /*printlist("internals: ",internals); /* DEBUG */
+ word i=internals;
+ if(mkexports)return; /* in this case don't want internals restored */
+ while(i!=NIL) /* lose */
+ publicise(hd[i]),i=tl[i];
+ internals=NIL;
+} /* may not be interrupt safe, re unload() */
+
+privatise(x) /* change id to pname, and return new id holding it as value */
+word x;
+{ extern word namebucket[],*pnvec;
+ word n = make_pn(x),h=namebucket[hash(get_id(x))],i;
+ if(id_type(x)==type_t)
+ t_info(x)=cons(datapair(getaka(x),0),get_here(x));
+ /* to assist identification of danging type refs - see typesharing code
+ in mkincludes */
+ /* assumption - nothing looks at the t_info after compilation */
+ if(id_val(x)==UNDEF) /* name specified but not defined */
+ id_val(x)= ap(datapair(getaka(x),0),get_here(x));
+ /* this will generate sensible error message on attempt to use value
+ see reduction rule for DATAPAIR */
+ pnvec[i=hd[n]]=x;
+ tag[n]=ID;hd[n]=hd[x];
+ tag[x]=STRCONS;hd[x]=i;
+ while(hd[h]!=x)h=tl[h];
+ hd[h]=n;
+ return(n);
+} /* WARNING - dependent on internal representation of ids and pnames */
+/* nasty problem - privatisation can screw AKA's */
+
+publicise(x) /* converse of the above, applied to the new id */
+word x;
+{ extern word namebucket[];
+ word i=id_val(x),h=namebucket[hash(get_id(x))];
+ tag[i]=ID,hd[i]=hd[x];
+ /* WARNING - USES FACT THAT tl HOLDS VALUE FOR BOTH ID AND PNAME */
+ if(tag[tl[i]]==AP&&tag[hd[tl[i]]]==DATAPAIR)
+ tl[i]=UNDEF; /* undo kludge, see above */
+ while(hd[h]!=x)h=tl[h];
+ hd[h]=i;
+ return(i);
+}
+
+static sigflag=0;
+
+sigdefer()
+{ /* printf("sigdefer()\n"); /* DEBUG */
+ sigflag=1; } /* delayed signal handler, installed during load_script() */
+
+mkincludes(includees)
+word includees;
+{ extern word FBS,BAD_DUMP,CLASHES,exportfiles,exports,TORPHANS;
+ word pid,result=NIL,tclashes=NIL;
+ includees=reverse(includees); /* process in order of occurrence in script */
+ if(pid=fork())
+ { /* parent */
+ word status;
+ if(pid==-1)
+ { perror("UNIX error - cannot create process"); /* will say why */
+ if(ideep>6) /* perhaps cyclic %include */
+ fprintf(stderr,"error occurs %d deep in %%include files\n",ideep);
+ if(ideep)exit(2);
+ SYNERR=2; /* special code to prevent makedump() */
+ printf("compilation of \"%s\" abandoned\n",current_script);
+ return(NIL); }
+ while(pid!=wait(&status));
+ if((WEXITSTATUS(status))==2) /* child aborted */
+ if(ideep)exit(2); /* recursive abortion of parent process */
+ else { SYNERR=2;
+ printf("compilation of \"%s\" abandoned\n",current_script);
+ return(NIL); }
+ /* if we get to here child completed normally, so carry on */
+ }
+ else { /* child does equivalent of `mira -make' on each includee */
+ extern word oldfiles;
+ (void)signal(SIGINT,SIG_DFL); /* don't trap interrupts */
+ ideep++; making=1; make_status=0; echoing=listing=verbosity=magic=0;
+ setjmp(env); /* will return here on blankerr (via reset) */
+ while(includees!=NIL&&!make_status) /* stop at first bad includee */
+ { undump((char *)hd[hd[hd[includees]]]);
+ if(ND!=NIL||files==NIL&&oldfiles!=NIL)make_status=1;
+ /* any errors in dump? */
+ includees=tl[includees];
+ } /* obscure bug - undump above can reinvoke compiler, which
+ side effects compiler variable `includees' - to fix this
+ had to make sure child is holding local copy of includees*/
+ exit(make_status); }
+ sigflag=0;
+ for(;includees!=NIL;includees=tl[includees])
+ { word x=NIL;
+ sighandler oldsig;
+ FILE *f;
+ char *fn=(char *)hd[hd[hd[includees]]];
+ extern word DETROP,MISSING,ALIASES,TSUPPRESSED,*stackp,*dstack;
+ (void)strcpy(dicp,fn);
+ (void)strcpy(dicp+strlen(dicp)-1,obsuffix);
+ if(!making) /* cannot interrupt load_script() */
+ oldsig=signal(SIGINT,(sighandler)sigdefer);
+ if(f=fopen(dicp,"r"))
+ x=load_script(f,fn,hd[tl[hd[includees]]],tl[tl[hd[includees]]],0),
+ fclose(f);
+ ld_stuff=cons(x,ld_stuff);
+ if(!making)(void)signal(SIGINT,oldsig);
+ if(sigflag)sigflag=0,(* oldsig)(); /* take deferred interrupt */
+ if(f&&!BAD_DUMP&&x!=NIL&&ND==NIL&&CLASHES==NIL&&ALIASES==NIL&&
+ TSUPPRESSED==NIL&&DETROP==NIL&&MISSING==NIL)
+ /* i.e. if load_script worked ok */
+ { /* stuff here is to share repeated file components
+ issues:
+ Consider only includees (fil_share=1), not insertees.
+ Effect of sharing is to replace value fields in later copies
+ by (pointers to) corresponding ids in first copy - so sharing
+ transmitted thru dumps. It is illegal to have more than one
+ copy of a (non-synonym) type in the same scope, even under
+ different names. */
+ word y,z;
+ /* printf("start share analysis\n"); /* DEBUG */
+ if(TORPHANS)rfl=shunt(x,rfl); /* file has type orphans */
+ for(y=x;y!=NIL;y=tl[y])fil_inodev(hd[y])=inodev(get_fil(hd[y]));
+ for(y=x;y!=NIL;y=tl[y])
+ if(fil_share(hd[y]))
+ for(z=result;z!=NIL;z=tl[z])
+ if(fil_share(hd[z])&&same_file(hd[y],hd[z])
+ &&fil_time(hd[y])==fil_time(hd[z]))
+ { word p=fil_defs(hd[y]),q=fil_defs(hd[z]);
+ for(;p!=NIL&&q!=NIL;p=tl[p],q=tl[q])
+ if(tag[hd[p]]==ID)
+ if(id_type(hd[p])==type_t&&
+ (tag[hd[q]]==ID||tag[pn_val(hd[q])]==ID))
+ { /* typeclash - record in tclashes */
+ word w=tclashes;
+ word orig=tag[hd[q]]==ID?hd[q]:pn_val(hd[q]);
+ if(t_class(hd[p])==synonym_t)continue;
+ while(w!=NIL&&((char *)hd[hd[w]]!=get_fil(hd[z])
+ ||hd[tl[hd[w]]]!=orig))
+ w=tl[w];
+ if(w==NIL)
+ w=tclashes=cons(strcons(get_fil(hd[z]),
+ cons(orig,NIL)),tclashes);
+ tl[tl[hd[w]]]=cons(hd[p],tl[tl[hd[w]]]);
+ }
+ else the_val(hd[q])=hd[p];
+ else the_val(hd[p])=hd[q];
+ /*following test redundant - remove when sure is ok*/
+ if(p!=NIL||q!=NIL)
+ fprintf(stderr,"impossible event in mkincludes\n");
+ /*break; /* z loop -- NO! (see liftbug) */
+ }
+ if(member(exportfiles,(word)fn))
+ { /* move ids of x onto exports */
+ for(y=x;y!=NIL;y=tl[y])
+ for(z=fil_defs(hd[y]);z!=NIL;z=tl[z])
+ if(isvariable(hd[z]))
+ tl[exports]=add1(hd[z],tl[exports]);
+ /* skip pnames, constructors (expanded later) */
+ }
+ result=append1(result,x);
+ /* keep `result' in front-first order */
+ if(hd[FBS]==NIL)FBS=tl[FBS];
+ else hd[FBS]=cons(tl[hd[hd[includees]]],hd[FBS]); /* hereinfo */
+ /* printf("share analysis finished\n"); /* DEBUG */
+ continue; }
+ /* something wrong - find out what */
+ if(!f)result=cons(make_fil(hd[hd[hd[includees]]],
+ fm_time(fn),0,NIL),result); else
+ if(x==NIL&&BAD_DUMP!= -2)result=append1(result,oldfiles),oldfiles=NIL;
+ else result=append1(result,x);
+ /* above for benefit of `oldfiles' */
+ /* BAD_DUMP -2 is nameclashes due to aliasing */
+ SYNERR=1;
+ printf("unsuccessful %%include directive ");
+ sayhere(tl[hd[hd[includees]]],1);
+/* if(!f)printf("\"%s\" non-existent or unreadable\n",fn), */
+ if(!f)printf("\"%s\" cannot be loaded\n",fn),
+ CLASHES=DETROP=MISSING=NIL;
+ /* just in case not cleared from a previous load_script() */
+ else
+ if(BAD_DUMP== -2)
+ printlist("aliasing causes nameclashes: ",CLASHES),
+ CLASHES=NIL; else
+ if(ALIASES!=NIL||TSUPPRESSED!=NIL)
+ { if(ALIASES!=NIL)
+ printf("alias fails (name%s not found in file",
+ tl[ALIASES]==NIL?"":"s"),
+ printlist("): ",ALIASES),ALIASES=NIL;
+ if(TSUPPRESSED!=NIL)
+ { printf("illegal alias (cannot suppress typename%s):",
+ tl[TSUPPRESSED]==NIL?"":"s");
+ while(TSUPPRESSED!=NIL)
+ printf(" -%s",get_id(hd[TSUPPRESSED])),
+ TSUPPRESSED=tl[TSUPPRESSED];
+ putchar('\n'); }
+ /* if -typename allowed, remember to look for type orphans */
+ }else
+ if(BAD_DUMP)printf("\"%s\" has bad data in dump file\n",fn); else
+ if(x==NIL)printf("\"%s\" contains syntax error\n",fn); else
+ if(ND!=NIL)
+ printf("\"%s\" contains undefined names or type errors\n",fn);
+ if(ND==NIL&&CLASHES!=NIL) /* can have this and failed aliasing */
+ printf("\"%s\" ",fn),printlist("causes nameclashes: ",CLASHES);
+ while(DETROP!=NIL&&tag[hd[DETROP]]==CONS)
+ { word fa=hd[tl[hd[DETROP]]],ta=tl[tl[hd[DETROP]]];
+ char *pn=get_id(hd[hd[DETROP]]);
+ if(fa== -1||ta== -1)
+ printf("`%s' has binding of wrong kind ",pn),
+ printf(fa== -1?"(should be \"= value\" not \"== type\")\n"
+ :"(should be \"== type\" not \"= value\")\n");
+ else
+ printf("`%s' has == binding of wrong arity ",pn),
+ printf("(formal has arity %d, actual has arity %d)\n",fa,ta);
+ DETROP=tl[DETROP]; }
+ if(DETROP!=NIL)
+ printf("illegal parameter binding (name%s not %%free in file",
+ tl[DETROP]==NIL?"":"s"),
+ printlist("): ",DETROP),DETROP=NIL;
+ if(MISSING!=NIL)
+ printf("missing parameter binding%s: ",tl[MISSING]==NIL?"":"s");
+ while(MISSING!=NIL)
+ printf("%s%s",(char *)hd[hd[MISSING]],tl[MISSING]==NIL?";\n":","),
+ MISSING=tl[MISSING];
+ printf("compilation abandoned\n");
+ stackp=dstack; /* in case of BAD_DUMP */
+ return(result); } /* for unload() */
+ if(tclashes!=NIL)
+ { printf("TYPECLASH - the following type%s multiply named:\n",
+ tl[tclashes]==NIL?" is":"s are");
+ /* structure of tclashes is list of strcons(filname,list-of-ids) */
+ for(;tclashes!=NIL;tclashes=tl[tclashes])
+ { printf("\'%s\' of file \"%s\", as: ",
+ getaka(hd[tl[hd[tclashes]]]),
+ (char *)hd[hd[tclashes]]);
+ printlist("",alfasort(tl[hd[tclashes]])); }
+ printf("typecheck cannot proceed - compilation abandoned\n");
+ SYNERR=1;
+ return(result); } /* for unload */
+ return(result);
+}
+
+word tlost=NIL;
+word pfrts=NIL; /* list of private free types bound in this script */
+
+readoption() /* readopt type orphans */
+{ word f,t;
+ extern word TYPERRS,FBS;
+ pfrts=tlost=NIL;
+ /* exclude anonymous free types, these dealt with later by mcheckfbs() */
+ if(FBS!=NIL)
+ for(f=FBS;f!=NIL;f=tl[f])
+ for(t=tl[hd[f]];t!=NIL;t=tl[t])
+ if(tag[hd[hd[t]]]==STRCONS&&tl[tl[hd[t]]]==type_t)
+ pfrts=cons(hd[hd[t]],pfrts);
+ /* this may needlessly scan `silent' files - fix later */
+ for(;rfl!=NIL;rfl=tl[rfl])
+ for(f=fil_defs(hd[rfl]);f!=NIL;f=tl[f])
+ if(tag[hd[f]]==ID)
+ if((t=id_type(hd[f]))==type_t)
+ { if(t_class(hd[f])==synonym_t)
+ t_info(hd[f])=fixtype(t_info(hd[f]),hd[f]); }
+ else id_type(hd[f])=fixtype(t,hd[f]);
+ if(tlost==NIL)return;
+ TYPERRS++;
+ printf("MISSING TYPENAME%s\n",tl[tlost]==NIL?"":"S");
+ printf("the following type%s no name in this scope:\n",
+ tl[tlost]==NIL?" is needed but has":"s are needed but have");
+ /* structure of tlost is list of cons(losttype,list-of-ids) */
+ for(;tlost!=NIL;tlost=tl[tlost])
+ { /* printf("tinfo_tlost=");out(stdout,t_info(hd[hd[tlost]]));
+ putchar(';'); /*DEBUG */
+ printf("\'%s\' of file \"%s\", needed by: ",
+ (char *)hd[hd[t_info(hd[hd[tlost]])]],
+ (char *)hd[tl[t_info(hd[hd[tlost]])]]);
+ printlist("",alfasort(tl[hd[tlost]])); }
+}
+
+/*fixtype(t,x)
+int t,x;
+{ int t1;
+ t1=fixtype1(t,x);
+ printf("fixing type of %s\n",get_id(x));
+ out_type(t); printf(" := ");
+ out_type(t1); putchar('\n');
+ return(t1);
+} /* DEBUG */
+
+fixtype(t,x) /* substitute out any indirected typenames in t */
+word t,x;
+{ switch(tag[t])
+ { case AP:
+ case CONS: tl[t]=fixtype(tl[t],x);
+ hd[t]=fixtype(hd[t],x);
+ default: return(t);
+ case STRCONS: if(member(pfrts,t))return(t); /* see jrcfree.bug */
+ while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/
+ if(tag[t]!=ID)
+ { /* lost type - record in tlost */
+ word w=tlost;
+ while(w!=NIL&&hd[hd[w]]!=t)w=tl[w];
+ if(w==NIL)
+ w=tlost=cons(cons(t,cons(x,NIL)),tlost);
+ tl[hd[w]]=add1(x,tl[hd[w]]);
+ }
+ return(t);
+ }
+}
+
+#define mask(c) (c&0xDF)
+/* masks out lower case bit, which is 0x20 */
+alfa_ls(a,b) /* 'DICTIONARY ORDER' - not currently used */
+char *a,*b;
+{ while(*a&&mask(*a)==mask(*b))a++,b++;
+ if(mask(*a)==mask(*b))return(strcmp(a,b)<0); /* lower case before upper */
+ return(mask(*a)<mask(*b));
+}
+
+alfasort(x) /* also removes non_IDs from result */
+word x;
+{ word a=NIL,b=NIL,hold=NIL;
+ if(x==NIL)return(NIL);
+ if(tl[x]==NIL)return(tag[hd[x]]!=ID?NIL:x);
+ while(x!=NIL) /* split x */
+ { if(tag[hd[x]]==ID)hold=a,a=cons(hd[x],b),b=hold;
+ x=tl[x]; }
+ a=alfasort(a),b=alfasort(b);
+ /* now merge two halves back together */
+ while(a!=NIL&&b!=NIL)
+ if(strcmp(get_id(hd[a]),get_id(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));
+}
+
+unsetids(d) /* d is a list of identifiers */
+word d;
+{ while(d!=NIL)
+ { if(tag[hd[d]]==ID)id_val(hd[d])=UNDEF,
+ id_who(hd[d])=NIL,
+ id_type(hd[d])=undef_t;
+ d=tl[d]; } /* should we remove from namebucket ? */
+}
+
+unload() /* clear out current script in preparation for reloading */
+{ extern word TABSTRS,SGC,speclocs,newtyps,rv_script,algshfns,nextpn,nolib,
+ includees,freeids;
+ word x;
+ sorted=0;
+ speclocs=NIL;
+ nextpn=0; /* lose pnames */
+ rv_script=0;
+ algshfns=NIL;
+ unsetids(newtyps);
+ newtyps=NIL;
+ unsetids(freeids);
+ freeids=includees=SGC=freeids=TABSTRS=ND=NIL;
+ unsetids(internals);
+ internals=NIL;
+ while(files!=NIL)
+ { unsetids(fil_defs(hd[files]));
+ fil_defs(hd[files])=NIL;
+ files = tl[files]; }
+ for(;ld_stuff!=NIL;ld_stuff=tl[ld_stuff])
+ for(x=hd[ld_stuff];x!=NIL;x=tl[x])unsetids(fil_defs(hd[x]));
+}
+
+yyerror(s) /* called by YACC in the event of a syntax error */
+char *s;
+{ extern word yychar;
+ if(SYNERR)return; /* error already reported, so shut up */
+ if(echoing)printf("\n");
+ printf("%s - unexpected ",s);
+ if(yychar==OFFSIDE&&(c==EOF||c=='|'))
+ { if(c==EOF) /* special case introduced by fix for dtbug */
+ printf("end of file"); else
+ printf("token '|'");
+ /* special case introduced by sreds fix to offside rule */
+ } else
+ { printf(yychar==0?commandmode?"newline":"end of file":"token ");
+ if(yychar>=256)putchar('\"');
+ if(yychar!=0)out2(stdout,yychar);
+ if(yychar>=256)putchar('\"'); }
+ printf("\n");
+ SYNERR=1;
+ reset_lex();
+}
+
+syntax(s) /* called by actions after discovering a (context sensitive) syntax
+ error */
+char *s;
+{ if(SYNERR)return;
+ if(echoing)printf("\n");
+ printf("syntax error: %s",s);
+ SYNERR=1; /* this will stop YACC at its next call to yylex() */
+ reset_lex();
+}
+
+acterror() /* likewise, but assumes error message output by caller */
+{ if(SYNERR)return;
+ SYNERR=1; /* to stop YACC at next symbol */
+ reset_lex();
+}
+
+mira_setup()
+{ extern word common_stdin,common_stdinb,cook_stdin;
+ setupheap();
+ tsetup();
+ reset_pns();
+ bigsetup();
+ common_stdin= ap(READ,0);
+ common_stdinb= ap(READBIN,0);
+ cook_stdin=ap(readvals(0,0),OFFSIDE);
+ nill= cons(CONST,NIL);
+ Void=make_id("()");
+ id_type(Void)=void_t;
+ id_val(Void)=constructor(0,Void);
+ message=make_id("sys_message");
+ main_id=make_id("main"); /* change to magic scripts 19.11.2013 */
+ concat=make_id("concat");
+ diagonalise=make_id("diagonalise");
+ standardout=constructor(0,"Stdout");
+ indent_fn=make_id("indent");
+ outdent_fn=make_id("outdent");
+ listdiff_fn=make_id("listdiff");
+ shownum1=make_id("shownum1");
+ showbool=make_id("showbool");
+ showchar=make_id("showchar");
+ showlist=make_id("showlist");
+ showstring=make_id("showstring");
+ showparen=make_id("showparen");
+ showpair=make_id("showpair");
+ showvoid=make_id("showvoid");
+ showfunction=make_id("showfunction");
+ showabstract=make_id("showabstract");
+ showwhat=make_id("showwhat");
+ primlib(); } /* sets up predefined ids, not referred to by RULES */
+
+void dieclean() /* called if evaluation is interrupted - see RULES */
+{ printf("<<...interrupt>>\n");
+#ifndef NOSTATSONINT
+ outstats(); /* suppress in presence of segfault on ^C with /count */
+#endif
+ exit(0);
+}
+
+/* the function process() creates a process and waits for it to die -
+ returning 1 in the child and 0 in the parent - it is used in the
+ evaluation command (see MIRANDA RULES) */
+process()
+{ word pid;
+ sighandler oldsig;
+ oldsig = signal(SIGINT,SIG_IGN);
+ /* do not let parent receive interrupts intended for child */
+ if(pid=fork())
+ { /* parent */
+ word status; /* see man 2 exit, wait, signal */
+ if(pid== -1)
+ { perror("UNIX error - cannot create process");
+ return(0);
+ }
+ while(pid!=wait(&status));
+ /* low byte of status is termination state of child, next byte is the
+ (low order byte of the) exit status */
+ if(WIFSIGNALED(status)) /* abnormal termination status */
+ { char *cd=status&0200?" (core dumped)":"";
+ char *pc=""; /* "probably caused by stack overflow\n";*/
+ switch(WTERMSIG(status))
+ { case SIGBUS: printf("\n<<...bus error%s>>\n%s",cd,pc); break;
+ case SIGSEGV: printf("\n<<...segmentation fault%s>>\n%s",cd,pc); break;
+ default: printf("\n<<...uncaught signal %d>>\n",WTERMSIG(status));
+ } }
+ /*if(status >>= 8)printf("\n(exit status %d)\n",status); */
+ (void)signal(SIGINT,oldsig); /* restore interrupt status */
+ return(0); }
+ else return(1); /* child */
+}
+
+/* Notice that the MIRANDA system has a two-level interrupt structure.
+ 1) Each evaluation (see RULES) is an interruptible process.
+ 2) If the command loop is interrupted outside an evaluation or during
+ compilation it reverts to the top level prompt - see set_jmp and
+ signal(reset) in commandloop() */
+
+primdef(n,v,t) /* used by "primlib", see below */
+char *n;
+word v,t;
+{ word x;
+ x= make_id(n);
+ primenv=cons(x,primenv);
+ id_val(x)= v;
+ id_type(x)=t; }
+
+predef(n,v,t) /* used by "privlib" and "stdlib", see below */
+char *n;
+word v,t;
+{ word x;
+ x= make_id(n);
+ addtoenv(x);
+ id_val(x)= isconstructor(x)?constructor(v,x):v;
+ id_type(x)=t;
+}
+
+primlib() /* called by "mira_setup", this routine enters
+ the primitive identifiers into the primitive environment */
+{ primdef("num",make_typ(0,0,synonym_t,num_t),type_t);
+ primdef("char",make_typ(0,0,synonym_t,char_t),type_t);
+ primdef("bool",make_typ(0,0,synonym_t,bool_t),type_t);
+ primdef("True",1,bool_t); /* accessible only to 'finger' */
+ primdef("False",0,bool_t); /* likewise - FIX LATER */
+}
+
+privlib() /* called when compiling <prelude>, adds some
+ internally defined identifiers to the environment */
+{ extern word ltchar;
+ predef("offside",OFFSIDE,ltchar); /* used by `indent' in prelude */
+ predef("changetype",I,wrong_t); /* wrong_t to prevent being typechecked */
+ predef("first",HD,wrong_t);
+ predef("rest",TL,wrong_t);
+/* the following added to make prelude compilable without stdenv */
+ predef("code",CODE,undef_t);
+ predef("concat",ap2(FOLDR,APPEND,NIL),undef_t);
+ predef("decode",DECODE,undef_t);
+ predef("drop",DROP,undef_t);
+ predef("error",ERROR,undef_t);
+ predef("filter",FILTER,undef_t);
+ predef("foldr",FOLDR,undef_t);
+ predef("hd",HD,undef_t);
+ predef("map",MAP,undef_t);
+ predef("shownum",SHOWNUM,undef_t);
+ predef("take",TAKE,undef_t);
+ predef("tl",TL,undef_t);
+}
+
+stdlib() /* called when compiling <stdenv>, adds some
+ internally defined identifiers to the environment */
+{ predef("arctan",ARCTAN_FN,undef_t);
+ predef("code",CODE,undef_t);
+ predef("cos",COS_FN,undef_t);
+ predef("decode",DECODE,undef_t);
+ predef("drop",DROP,undef_t);
+ predef("entier",ENTIER_FN,undef_t);
+ predef("error",ERROR,undef_t);
+ predef("exp",EXP_FN,undef_t);
+ predef("filemode",FILEMODE,undef_t);
+ predef("filestat",FILESTAT,undef_t); /* added Feb 91 */
+ predef("foldl",FOLDL,undef_t);
+ predef("foldl1",FOLDL1,undef_t); /* new at release 2 */
+ predef("hugenum",sto_dbl(DBL_MAX),undef_t);
+ /* max_normal() if present returns same value (see <math.h>) */
+ predef("last",LIST_LAST,undef_t);
+ predef("foldr",FOLDR,undef_t);
+ predef("force",FORCE,undef_t);
+ predef("getenv",GETENV,undef_t);
+ predef("integer",INTEGER,undef_t);
+ predef("log",LOG_FN,undef_t);
+ predef("log10",LOG10_FN,undef_t); /* new at release 2 */
+ predef("merge",MERGE,undef_t); /* new at release 2 */
+ predef("numval",NUMVAL,undef_t);
+ predef("read",STARTREAD,undef_t);
+ predef("readb",STARTREADBIN,undef_t);
+ predef("seq",SEQ,undef_t);
+ predef("shownum",SHOWNUM,undef_t);
+ predef("showhex",SHOWHEX,undef_t);
+ predef("showoct",SHOWOCT,undef_t);
+ predef("showfloat",SHOWFLOAT,undef_t); /* new at release 2 */
+ predef("showscaled",SHOWSCALED,undef_t); /* new at release 2 */
+ predef("sin",SIN_FN,undef_t);
+ predef("sqrt",SQRT_FN,undef_t);
+ predef("system",EXEC,undef_t); /* new at release 2 */
+ predef("take",TAKE,undef_t);
+ predef("tinynum",mktiny(),undef_t); /* new at release 2 */
+ predef("zip2",ZIP,undef_t); /* new at release 2 */
+}
+
+mktiny()
+{ volatile
+ double x=1.0,x1=x/2.0;
+ while(x1>0.0)x=x1,x1/=2.0;
+ return(sto_dbl(x));
+}
+/* min_subnormal() if present returns same value (see <math.h>) */
+
+size(x) /* measures the size of a compiled expression */
+word x;
+{ word s;
+ s= 0;
+ while(tag[x]==CONS||tag[x]==AP)
+ { s= s+1+size(hd[x]);
+ x= tl[x]; }
+ return(s); }
+
+makedump()
+{ char *obf=linebuf;
+ FILE *f;
+ (void)strcpy(obf,current_script);
+ (void)strcpy(obf+strlen(obf)-1,obsuffix);
+ f=fopen(obf,"w");
+ if(!f){ printf("WARNING: CANNOT WRITE TO %s\n",obf);
+ if(strcmp(current_script,PRELUDE)==0||
+ strcmp(current_script,STDENV)==0)
+ printf(
+ "TO FIX THIS PROBLEM PLEASE GET SUPER-USER TO EXECUTE `mira'\n");
+ if(making&&!make_status)make_status=1;
+ return; }
+ /* printf("dumping to %s\n",obf); /* DEBUG */
+ unlinkme=obf;
+ /* fchmod(fileno(f),0666); /* to make dumps writeable by all */ /* no! */
+ setprefix(current_script);
+ dump_script(files,f);
+ unlinkme=NULL;
+ fclose(f);
+}
+
+undump(t) /* restore t from dump, or recompile if necessary */
+char *t;
+{ extern word BAD_DUMP,CLASHES;
+ if(!normal(t)&&!initialising)return loadfile(t);
+ /* except for prelude, only .m files have dumps */
+ char obf[pnlim];
+ FILE *f;
+ sighandler oldsig;
+ word flen=strlen(t);
+ time_t t1=fm_time(t),t2;
+ if(flen>pnlim)
+ { printf("sorry, pathname too long (limit=%d): %s\n",pnlim,t);
+ return; } /* if anyone complains, should remove this limit */
+ (void)strcpy(obf,t);
+ (void)strcpy(obf+flen-1,obsuffix);
+ t2=fm_time(obf);
+ if(t2&&!t1)t2=0,unlink(obf); /* dump is orphan - remove */
+ if(!t2||t2<t1) /* dump is nonexistent or older than source - ignore */
+ { loadfile(t); return; }
+ f=fopen(obf,"r");
+ if(!f){ printf("cannot open %s\n",obf); loadfile(t); return; }
+ current_script=t;
+ loading=1;
+ oldfiles=NIL;
+ unload();
+/*if(!initialising)printf("undumping from %s\n",obf); /* DEBUG */
+ if(!initialising&&!making) /* ie this is the main script */
+ sigflag=0,
+ oldsig=signal(SIGINT,(sighandler)sigdefer);
+ /* can't take interrupt during load_script */
+ files=load_script(f,t,NIL,NIL,!making&!initialising);
+ fclose(f);
+ if(BAD_DUMP)
+ { extern word *stackp,*dstack;
+ unlink(obf); unload(); CLASHES=NIL; stackp=dstack;
+ printf("warning: %s contains incorrect data (file removed)\n",obf);
+ if(BAD_DUMP== -1)printf("(obsolete dump format)\n"); else
+ if(BAD_DUMP==1)printf("(wrong source file)\n"); else
+ printf("(error %d)\n",BAD_DUMP); }
+ if(!initialising&&!making) /* restore interrupt handler */
+ (void)signal(SIGINT,oldsig);
+ if(sigflag)sigflag=0,(*oldsig)(); /* take deferred interrupt */
+ /*if(!initialising)printf("%s undumped\n",obf); /* DEBUG */
+ if(CLASHES!=NIL)
+ { if(ideep==0)printf("cannot load %s ",obf),
+ printlist("due to name clashes: ",alfasort(CLASHES));
+ unload();
+ loading=0;
+ return; }
+ if(BAD_DUMP||src_update())loadfile(t);/* any sources modified since dump? */
+ else
+ if(initialising)
+ { if(ND!=NIL||files==NIL) /* error in dump of PRELUDE */
+ fprintf(stderr,"panic: %s contains errors\n",obf),
+ exit(1); } /* beware of dangling else ! (whence {}) */
+ else
+ if(verbosity||magic||mkexports) /* for less silent making s/mkexports/making/ */
+ if(files==NIL)printf("%s contains syntax error\n",t); else
+ if(ND!=NIL)printf("%s contains undefined names or type errors\n",t); else
+ if(!making&&!magic)printf("%s\n",t); /* added &&!magic 26.11.2019 */
+ if(!files==NIL&&!making&!initialising)unfixexports();
+ loading=0;
+}
+
+unlinkx(t) /* remove orphaned .x file */
+char *t;
+{ char *obf=linebuf;
+ (void)strcpy(obf,t);
+ (void)strcpy(obf+strlen(t)-1,obsuffix);
+ if(!stat(obf,&buf))unlink(obf);
+}
+
+void fpe_error()
+{ if(compiling)
+ { (void)signal(SIGFPE,(sighandler)fpe_error); /* reset SIGFPE trap */
+#ifdef sparc8
+ fpsetmask(commonmask); /* to clear sticky bits */
+#endif
+ syntax("floating point number out of range\n");
+ SYNERR=0; longjmp(env,1);
+ /* go straight back to commandloop - necessary because decoding very
+ large numbers can cause huge no. of repeated SIGFPE exceptions */
+ }
+ else printf("\nFLOATING POINT OVERFLOW\n"),exit(1);
+}
+
+char fbuf[512];
+
+filecopy(fil) /* copy the file "fil" to standard out */
+char *fil;
+{ word in=open(fil,0),n;
+ if(in== -1)return;
+ while((n=read(in,fbuf,512))>0)write(1,fbuf,n);
+ close(in);
+}
+
+filecp(fil1,fil2) /* copy file "fil1" to "fil2" (like `cp') */
+char *fil1,*fil2;
+{ word in=open(fil1,0),n;
+ word out=creat(fil2,0644);
+ if(in== -1||out== -1)return;
+ while((n=read(in,fbuf,512))>0)write(out,fbuf,n);
+ close(in);
+ close(out);
+}
+
+/* to define winsize and TIOCGWINSZ for twidth() */
+#include <termios.h>
+#include <sys/ioctl.h>
+
+twidth() /* returns width (in columns) of current window, less 2 */
+{
+#ifdef TIOCGWINSZ
+ static struct winsize tsize;
+ ioctl(fileno(stdout),TIOCGWINSZ,&tsize);
+ return (tsize.ws_col==0)?78:tsize.ws_col-2;
+#else
+#error TIOCGWINSZ undefined
+/* porting note: if you cannot find how to enable use of TIOCGWINSZ
+ comment out the above #error line */
+ return 78; /* give up, we will assume screen width to be 80 */
+#endif
+}
+
+/* was called when Miranda starts up and before /help, /aux
+ to clear screen - suppressed Oct 2019 */
+/* clrscr()
+{ printf("\x1b[2J\x1b[H"); fflush(stdout);
+} */
+
+/* the following code tests if we are in a UTF-8 locale */
+
+#ifdef CYGWIN
+#include <windows.h>
+
+utf8test()
+{ return GetACP()==65001; }
+/* codepage 1252 is Windows version of Latin-1; 65001 is UTF-8 */
+
+#else
+
+utf8test()
+{ char *lang;
+ if(!(lang=getenv("LC_CTYPE")))
+ lang=getenv("LANG");
+ if(lang&&
+ (strstr(lang,"UTF-8")||strstr(lang,"UTF8")||
+ strstr(lang,"utf-8")||strstr(lang,"utf8")))
+ return 1;
+ return 0;
+}
+#endif
+
+/* end of MIRANDA STEER */
+
diff --git a/new/trans.c b/new/trans.c
new file mode 100644
index 0000000..e50eb8a
--- /dev/null
+++ b/new/trans.c
@@ -0,0 +1,1026 @@
+/* MIRANDA TRANS */
+/* performs translation to combinatory logic */
+
+/**************************************************************************
+ * 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"
+
+ /* miscellaneous declarations */
+extern word nill,Void;
+extern word listdiff_fn,count_fn,from_fn;
+extern word diagonalise,concat;
+extern word lastname,initialising;
+extern word current_id,echoing;
+extern word errs;
+word newtyps=NIL; /* list of typenames declared in current script */
+word SGC=NIL; /* list of user defined sui-generis constructors */
+#define sui_generis(k) (/* k==Void|| */ member(SGC,k))
+ /* 3/10/88 decision to treat `()' as lifted */
+
+abstract(x,e) /* abstraction of template x from compiled expression e */
+word x,e;
+{ switch(tag[x])
+ { case ID:
+ if(isconstructor(x))
+ return(sui_generis(x)?ap(K,e):
+ ap2(Ug,primconstr(x),e));
+ else return(abstr(x,e));
+ case CONS:
+ if(hd[x]==CONST)
+ if(tag[tl[x]]==INT)return(ap2(MATCHINT,tl[x],e));
+ else return(ap2(MATCH,tl[x]==NILS?NIL:tl[x],e));
+ else return(ap(U_,abstract(hd[x],abstract(tl[x],e))));
+ case TCONS:
+ case PAIR: /* tuples */
+ return(ap(U,abstract(hd[x],abstract(tl[x],e))));
+ case AP:
+ if(sui_generis(head(x)))
+ return(ap(Uf,abstract(hd[x],abstract(tl[x],e))));
+ if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ return(ap2(ATLEAST,tl[hd[x]],abstract(tl[x],e)));
+ while(tag[x]==AP)
+ { e= abstract(tl[x],e);
+ x= hd[x]; }
+ /* now x must be a constructor */
+ default: ; }
+ if(isconstructor(x))
+ return(ap2(Ug,primconstr(x),e));
+ printf("error in declaration of \"%s\", undeclared constructor in pattern: ",
+ get_id(current_id)); /* something funny here - fix later */
+ out(stdout,x);
+ printf("\n");
+ return(NIL);
+}
+
+primconstr(x)
+word x;
+{ x=id_val(x);
+ while(tag[x]!=CONSTRUCTOR)x=tl[x];
+ return(x);
+ /* => constructor values are of the form TRY f k where k is the
+ original constructor value, and ! constructors are of the form
+ MKSTRICT i k */
+}
+
+memb(l,x) /* tests if x is a member of list "l" - used in testing for
+ repeated names - see rule for "v2" in MIRANDA RULES */
+word l,x;
+{ if(tag[x]==TVAR) /* type variable! */
+ while(l!=NIL&&!eqtvar(hd[l],x))l= tl[l];
+ else while(l!=NIL&&hd[l]!=x)l= tl[l];
+ return(l!=NIL); }
+
+abstr(x,e) /* "bracket abstraction" of variable x from code e */
+word x,e;
+{ switch(tag[e])
+ { case TCONS:
+ case PAIR:
+ case CONS: return(liscomb(abstr(x,hd[e]),abstr(x,tl[e])));
+ case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR)
+ return(ap(K,e)); /* don't go inside error info */
+ return(combine(abstr(x,hd[e]),abstr(x,tl[e])));
+ case LAMBDA:
+ case LET:
+ case LETREC:
+ case TRIES:
+ case LABEL:
+ case SHOW:
+ case LEXER:
+ case SHARE: fprintf(stderr,"impossible event in abstr (tag=%d)\n",tag[e]),
+ exit(1);
+ default: if(x==e||isvar_t(x)&&isvar_t(e)&&eqtvar(x,e))
+ return(I); /* see note */
+ return(ap(K,e));
+}} /* note - we allow abstraction wrt tvars - see genshfns() */
+
+#define mkindex(i) ((i)<256?(i):make(INT,i,0))
+ /* will fall over if i >= IBASE */
+
+abstrlist(x,e) /* abstraction of list of variables x from code e */
+word x,e;
+{ switch(tag[e])
+ { case TCONS:
+ case PAIR:
+ case CONS: return(liscomb(abstrlist(x,hd[e]),abstrlist(x,tl[e])));
+ case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR)
+ return(ap(K,e)); /* don't go inside error info */
+ else return(combine(abstrlist(x,hd[e]),abstrlist(x,tl[e])));
+ case LAMBDA: case LET: case LETREC: case TRIES: case LABEL: case SHOW:
+ case LEXER:
+ case SHARE: fprintf(stderr,
+ "impossible event in abstrlist (tag=%d)\n",tag[e]),
+ exit(1);
+ default: { word i=0;
+ while(x!=NIL&&hd[x]!=e)i++,x=tl[x];
+ if(x==NIL)return(ap(K,e));
+ return(ap(SUBSCRIPT,mkindex(i))); }
+}}
+
+word rv_script=0; /* flags readvals in use (for garbage collector) */
+
+codegen(x) /* returns expression x with abstractions performed */
+word x;
+{ extern word debug,commandmode,cook_stdin,common_stdin,common_stdinb,rv_expr;
+ switch(tag[x])
+ { case AP: if(commandmode /* beware of corrupting lastexp */
+ &&x!=cook_stdin&&x!=common_stdin&&x!=common_stdinb) /* but share $+ $- */
+ return(make(AP,codegen(hd[x]),codegen(tl[x])));
+ if(tag[hd[x]]==AP&&hd[hd[x]]==APPEND&&tl[hd[x]]==NIL)
+ return(codegen(tl[x])); /* post typecheck reversal of HR bug fix */
+ hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]);
+ /* otherwise do in situ */
+ return(tag[hd[x]]==AP&&hd[hd[x]]==G_ALT?leftfactor(x):x);
+ case TCONS:
+ case PAIR: return(make(CONS,codegen(hd[x]),codegen(tl[x])));
+ case CONS: if(commandmode)
+ return(make(CONS,codegen(hd[x]),codegen(tl[x])));
+ /* otherwise do in situ (see declare) */
+ hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]);
+ return(x);
+ case LAMBDA: return(abstract(hd[x],codegen(tl[x])));
+ case LET: return(translet(hd[x],tl[x]));
+ case LETREC: return(transletrec(hd[x],tl[x]));
+ case TRIES: return(transtries(hd[x],tl[x]));
+ case LABEL: return(codegen(tl[x]));
+ case SHOW: return(makeshow(hd[x],tl[x]));
+ case LEXER:
+ { word r=NIL,uses_state=0;;
+ while(x!=NIL)
+ { word rule=abstr(mklexvar(0),codegen(tl[tl[hd[x]]]));
+ rule=abstr(mklexvar(1),rule);
+ if(!(tag[rule]==AP&&hd[rule]==K))uses_state=1;
+ r=cons(cons(hd[hd[x]], /* start condition stuff */
+ cons(ap(hd[tl[hd[x]]],NIL), /* matcher [] */
+ rule)),
+ r);
+ x=tl[x]; }
+ if(!uses_state) /* strip off (K -) from each rule */
+ { for(x=r;x!=NIL;x=tl[x])tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];
+ r = ap(LEX_RPT,ap(LEX_TRY,r)); }
+ else r = ap(LEX_RPT1,ap(LEX_TRY1,r));
+ return(ap(r,0)); } /* 0 startcond */
+ case STARTREADVALS:
+ if(ispoly(tl[x]))
+ { extern word cook_stdin,polyshowerror,ND;
+ printf("type error - %s used at polymorphic type :: [",
+ cook_stdin&&x==hd[cook_stdin]?"$+":"readvals or $+");
+ out_type(redtvars(tl[x])),printf("]\n");
+ polyshowerror=1;
+ if(current_id)
+ ND=add1(current_id,ND),
+ id_type(current_id)=wrong_t,
+ id_val(current_id)=UNDEF;
+ if(hd[x])sayhere(hd[x],1); }
+ if(commandmode)rv_expr=1; else rv_script=1;
+ return(x);
+ case SHARE: if(tl[x]!= -1) /* arbitrary flag for already visited */
+ hd[x]=codegen(hd[x]),tl[x]= -1;
+ return(hd[x]);
+ default: if(x==NILS)return(NIL);
+ return(x); /* identifier, private name, or constant */
+}}
+
+word lfrule=0;
+
+leftfactor(x)
+
+/* grammar optimisations - x is of the form ap2(G_ALT,...)
+ G_ALT(G_SEQ a b) a => G_SEQ a (G_ALT b G_UNIT)
+ G_ALT(G_SEQ a b)(G_SEQ a c) => G_SEQ a (G_ALT b c)
+ G_ALT(G_SEQ a b)(G_ALT a d) => G_ALT(G_SEQ a (G_ALT b G_UNIT)) d
+ G_ALT(G_SEQ a b)(G_ALT(G_SEQ a c) d) => G_ALT(G_SEQ a (G_ALT b c)) d
+*/
+word x;
+{ word a,b,c,d;
+ if(tag[c=tl[hd[x]]]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ)
+ a=tl[hd[c]],b=tl[c]; else return(x);
+ if(same(a,d=tl[x]))
+ { hd[x]=ap(G_SEQ,a), tl[x]=ap2(G_ALT,b,G_UNIT); lfrule++;
+ /* printob("rule1: ",x); */
+ return(x); }
+ if(tag[d]==AP&&tag[hd[d]]==AP)
+ c=hd[hd[d]]; else return(x);
+ if(c==G_SEQ&&same(a,tl[hd[d]]))
+ { c=tl[d],
+ hd[x]=ap(G_SEQ,a), tl[x]=leftfactor(ap2(G_ALT,b,c)); lfrule++;
+ /* printob("rule2: ",x); */
+ return(x); }
+ if(c!=G_ALT)return(x);
+ if(same(a,c=tl[hd[d]]))
+ { d=tl[d];
+ hd[x]=ap(G_ALT,ap2(G_SEQ,a,ap2(G_ALT,b,G_UNIT)));
+ tl[x]=d; lfrule++;
+ /* printob("rule3: ",x); */
+ return(leftfactor(x)); }
+ if(tag[c]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ
+ &&same(a,tl[hd[c]]))
+ { c=tl[c],d=tl[d],
+ hd[x]=ap(G_ALT,ap2(G_SEQ,a,leftfactor(ap2(G_ALT,b,c))));
+ tl[x]=d; lfrule++;
+ /* printob("rule4: ",x); */
+ return(leftfactor(x)); }
+ return(x);
+}
+
+same(x,y) /* structural equality */
+word x,y;
+{ if(x==y)return(1);
+ if(tag[x]==ATOM||tag[y]==ATOM||tag[x]!=tag[y])return(0);
+ if(tag[x]<INT)return(hd[x]==hd[y]&&tl[x]==tl[y]);
+ if(tag[x]>STRCONS)return(same(hd[x],hd[y])&&same(tl[x],tl[y]));
+ return(hd[x]==hd[y]&&same(tl[x],tl[y])); /* INT..STRCONS */
+}
+
+static word was_poly;
+word polyshowerror;
+
+makeshow(here,type)
+word here,type;
+{ word f;
+ extern word ND;
+ was_poly=0; f=mkshow(0,0,type);
+ /* printob("showfn=",f); /* DEBUG */
+ if(here&&was_poly)
+ { extern char *current_script;
+ printf("type error in definition of %s\n",get_id(current_id));
+ sayhere(here,0);
+ printf(" use of \"show\" at polymorphic type ");
+ out_type(redtvars(type));
+ putchar('\n');
+ id_type(current_id)=wrong_t;
+ id_val(current_id)=UNDEF;
+ polyshowerror=1;
+ ND=add1(current_id,ND);
+ was_poly=0; }
+ return(f);
+}
+
+mkshow(s,p,t) /* build a show function appropriate to type t */
+word s,p,t; /* p is precedence - 0 for top level, 1 for internal */
+ /* s flags special case invoked from genshfns */
+{ extern word shownum1,showbool,showchar,showlist,showstring,showparen,
+ showvoid,showpair,showfunction,showabstract,showwhat;
+ word a=NIL;
+ while(tag[t]==AP)a=cons(tl[t],a),t=hd[t];
+ switch(t)
+ { case num_t: return(p?shownum1:SHOWNUM);
+ case bool_t: return(showbool);
+ case char_t: return(showchar);
+ case list_t: if(hd[a]==char_t)return(showstring);
+ return(ap(showlist,mkshow(s,0,hd[a])));
+ case comma_t: return(ap(showparen,ap2(showpair,mkshow(s,0,hd[a]),
+ mkshowt(s,hd[tl[a]]))));
+ case void_t: return(showvoid);
+ case arrow_t:return(showfunction);
+ default: if(tag[t]==ID)
+ { word r=t_showfn(t);
+ if(r==0) /* abstype without show function */
+ return(showabstract);
+ if(r==showwhat) /* dont apply to parameter showfns */
+ return(r);
+ while(a!=NIL)r=ap(r,mkshow(s,1,hd[a])),a=tl[a];
+ if(t_class(t)==algebraic_t)r=ap(r,p);
+ return(r);
+ /* note that abstype-showfns have only one precedence
+ and show their components (if any) at precedence 1
+ - if the latter is a problem could do parenthesis
+ stripping */
+ }
+ if(isvar_t(t)){ if(s)return(t); /* see genshfns */
+ was_poly=1;
+ return(showwhat); }
+ /* arbitrary - could be any strict function */
+ if(tag[t]==STRCONS) /* pname */ /* DEBUG */
+ { printf("warning - mkshow applied to suppressed type\n");
+ return(showwhat); }
+ else { printf("impossible event in mkshow ("),
+ out_type(t), printf(")\n");
+ return(showwhat); }
+ }
+}
+
+mkshowt(s,t) /* t is a (possibly singleton) tuple type */
+word s,t; /* flags special call from genshfns */
+{ extern word showpair;
+ if(tl[t]==void_t)return(mkshow(s,0,tl[hd[t]]));
+ return(ap2(showpair,mkshow(s,0,tl[hd[t]]),mkshowt(s,tl[t])));
+}
+
+word algshfns=NIL; /* list of showfunctions for all algebraic types in scope
+ (list of pnames) - needed to make dumps */
+
+genshfns() /* called after meta type check - create show functions for
+ algebraic types */
+{ word s;
+ for(s=newtyps;s!=NIL;s=tl[s])
+ if(t_class(hd[s])==algebraic_t)
+ { word f=0,r=t_info(hd[s]); /* r is list of constructors */
+ word ush= tl[r]==NIL&&member(SGC,hd[r])?Ush1:Ush;
+ for(;r!=NIL;r=tl[r])
+ { word t=id_type(hd[r]),k=id_val(hd[r]);
+ while(tag[k]!=CONSTRUCTOR)k=tl[k];/* lawful and !'d constructors*/
+ /* k now holds constructor(i,hd[r]) */
+ /* k=constructor(hd[k],datapair(get_id(tl[k]),0));
+ /* this `freezes' the name of the constructor */
+ /* incorrect, makes showfns immune to aliasing, should be
+ done at mkshow time, not genshfn time - FIX LATER */
+ while(isarrow_t(t))
+ k=ap(k,mkshow(1,1,tl[hd[t]])),t=tl[t]; /* NB 2nd arg */
+ k=ap(ush,k);
+ while(iscompound_t(t))k=abstr(tl[t],k),t=hd[t];
+ /* see kahrs.bug.m (this is the fix) */
+ if(f)f=ap2(TRY,k,f);
+ else f=k;
+ }
+ /* f~=0, placeholder types dealt with in specify() */
+ pn_val(t_showfn(hd[s]))=f;
+ algshfns=cons(t_showfn(hd[s]),algshfns);
+ }
+ else
+ if(t_class(hd[s])==abstract_t) /* if showfn present check type is ok */
+ if(t_showfn(hd[s]))
+ if(!abshfnck(hd[s],id_type(t_showfn(hd[s]))))
+ printf("warning - \"%s\" has type inappropriate for a show-function\n",
+ get_id(t_showfn(hd[s]))),t_showfn(hd[s])=0;
+}
+
+abshfnck(t,f) /* t is an abstype, is f right type for its showfn? */
+word t,f;
+{ word n=t_arity(t),i=1;
+ while(i<=n)
+ if(isarrow_t(f))
+ { word h=tl[hd[f]];
+ if(!(isarrow_t(h)&&isvar_t(tl[hd[h]])&&gettvar(tl[hd[h]])==i
+ &&islist_t(tl[h])&&tl[tl[h]]==char_t))return(0);
+ i++,f=tl[f];
+ } else return(0);
+ if(!(isarrow_t(f)&&islist_t(tl[f])&&tl[tl[f]]==char_t))return(0);
+ f=tl[hd[f]];
+ while(iscompound_t(f)&&isvar_t(tl[f])&&gettvar(tl[f])==n--)f=hd[f];
+ return(f==t);
+}
+
+transtries(id,x)
+word id,x; /* x is a list of alternative values, in reverse order */
+{ word r,h=0,earliest;
+ if(fallible(hd[x])) /* add default last case */
+ { word oldn=tag[id]==ID?datapair(get_id(id),0):0;
+ r=ap(BADCASE,h=cons(oldn,0));
+ /* 0 is placeholder for here-info */
+ /* oldn omitted if id is pattern - FIX LATER */ }
+ else r=codegen(earliest=hd[x]), x = tl[x];
+ while(x!=NIL)r=ap2(TRY,codegen(earliest=hd[x]),r), x=tl[x];
+ if(h)tl[h]=hd[earliest]; /* first line-no is the best marker */
+ return(r);
+}
+
+translet(d,e) /* compile block with body e and def d */
+word d,e;
+{ word x=mklazy(d);
+ return(ap(abstract(dlhs(x),codegen(e)),codegen(dval(x))));
+}
+/* nasty bug, codegen(dval(x)) was interfering with abstract(dlhs(x)...
+ to fix made codegen on tuples be NOT in situ 20/11/88 */
+
+transletrec(dd,e) /* better method, using list indexing - Jan 88 */
+word e,dd;
+{ word lhs=NIL,rhs=NIL,pn=1;
+ /* list of defs (x=e) is combined to listwise def `xs=es' */
+ for(;dd!=NIL;dd=tl[dd])
+ { word x=hd[dd];
+ if(tag[dlhs(x)]==ID) /* couldn't be constructor, by grammar */
+ lhs=cons(dlhs(x),lhs),
+ rhs=cons(codegen(dval(x)),rhs);
+ else { word i=0,ids,p=mkgvar(pn++); /* see note 1 */
+ x=new_mklazy(x); ids=dlhs(x);
+ lhs=cons(p,lhs),rhs=cons(codegen(dval(x)),rhs);
+ for(;ids!=NIL;ids=tl[ids],i++)
+ lhs=cons(hd[ids],lhs),
+ rhs=cons(ap2(SUBSCRIPT,mkindex(i),p),rhs);
+ }
+ }
+ if(tl[lhs]==NIL) /* singleton */
+ return(ap(abstr(hd[lhs],codegen(e)),ap(Y,abstr(hd[lhs],hd[rhs]))));
+ return(ap(abstrlist(lhs,codegen(e)),ap(Y,abstrlist(lhs,rhs))));
+}
+/* note 1: we here use the alternative `mklazy' transformation
+ pat = e => x1=p!0;...;xn=p!(n-1);p=(lambda(pat)[xs])e|conferror;
+ where p is a private name (need be unique only within a given letrec)
+*/
+
+mklazy(d) /* transforms local p=e to ids=($p.ids)e|conferror */
+word d;
+{ if(irrefutable(dlhs(d)))return(d);
+{ word ids=mktuple(dlhs(d));
+ if(ids==NIL){ printf("impossible event in mklazy\n"); return(d); }
+ dval(d)=ap2(TRY,ap(lambda(dlhs(d),ids),dval(d)),
+ ap(CONFERROR,cons(dlhs(d),here_inf(dval(d)))));
+ dlhs(d)=ids;
+ return(d);
+}}
+
+new_mklazy(d) /* transforms local p=e to ids=($p.ids)e|conferror
+ with ids a LIST (not tuple as formerly) */
+word d;
+{ word ids=get_ids(dlhs(d));
+ if(ids==NIL){ printf("impossible event in new_mklazy\n"); return(d); }
+ dval(d)=ap2(TRY,ap(lambda(dlhs(d),ids),dval(d)),
+ ap(CONFERROR,cons(dlhs(d),here_inf(dval(d)))));
+ dlhs(d)=ids;
+ return(d);
+}
+
+here_inf(rhs) /* rhs is of form tries(id,val_list) */
+word rhs;
+{ word x=tl[rhs];
+ while(tl[x]!=NIL)x=tl[x]; /* find earliest alternative */
+ return(hd[hd[x]]); /* hd[x] is of form label(here_info,value) */
+}
+
+irrefutable(x) /* x built from suigeneris constr's and (unrepeated) names */
+word x;
+{ if(tag[x]==CONS)return(0); /* includes constants */
+ if(isconstructor(x))return(sui_generis(x));
+ if(tag[x]==ID)return(1);
+ if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ return(0);
+ return(irrefutable(hd[x])&&irrefutable(tl[x]));
+}
+
+combine(x,y)
+word x,y;
+{ word a,b,a1,b1;
+ a= tag[x]==AP&&hd[x]==K;
+ b= tag[y]==AP&&hd[y]==K;
+ if(a&&b)return(ap(K,ap(tl[x],tl[y])));
+ /* rule of K propagation */
+ if(a&&y==I)return(tl[x]);
+ /* rule 'eta */
+ b1= tag[y]==AP&&tag[hd[y]]==AP&&hd[hd[y]]==B;
+ if(a)if(b1)return(ap3(B1,tl[x],tl[hd[y]],tl[y])); else
+ /* Mark Scheevel's new B1 introduction rule -- adopted Aug 83 */
+ if(tag[tl[x]]==AP&&tag[hd[tl[x]]]==AP&&hd[hd[tl[x]]]==COND)
+ return(ap3(COND,tl[hd[tl[x]]],ap(K,tl[tl[x]]),y));
+ else return(ap2(B,tl[x],y));
+ a1= tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==B;
+ if(b)if(a1)if(tag[tl[hd[x]]]==AP&&hd[tl[hd[x]]]==COND)
+ return(ap3(COND,tl[tl[hd[x]]],tl[x],y));
+ else return(ap3(C1,tl[hd[x]],tl[x],tl[y]));
+ else return(ap2(C,x,tl[y]));
+ if(a1)if(tag[tl[hd[x]]]==AP&&hd[tl[hd[x]]]==COND)
+ return(ap3(COND,tl[tl[hd[x]]],tl[x],y));
+ else return(ap3(S1,tl[hd[x]],tl[x],y));
+ else return(ap2(S,x,y)); }
+
+liscomb(x,y) /* the CONSy analogue of "combine" */
+word x,y;
+{ word a,b;
+ a= tag[x]==AP&&hd[x]==K;
+ b= tag[y]==AP&&hd[y]==K;
+ if(a&&b)return(ap(K,cons(tl[x],tl[y])));
+ /* K propagation again */
+ if(a)if(y==I)return(ap(P,tl[x])); /* eta P - new rule added 20/11/88 */
+ else return(ap2(B_p,tl[x],y));
+ if(b)return(ap2(C_p,x,tl[y]));
+ return(ap2(S_p,x,y)); }
+/* B_p,C_p,S_p are the CONSy analogues of B,C,S
+ see MIRANDA REDUCE for their definitions */
+
+compzf(e,qq,diag) /* compile a zf expression with body e and qualifiers qq
+ (listed in reverse order); diag is 0 for sequential
+ and 1 for diagonalising zf expressions */
+word e,qq,diag;
+{ word hold=NIL,r=0,g1= -1; /* r is number of generators */
+ while(qq!=NIL) /* unreverse qualifier list */
+ { if(hd[hd[qq]]==REPEAT)qq=fixrepeats(qq);
+ hold=cons(hd[qq],hold);
+ if(hd[hd[qq]]==GUARD)r++; /* count filters */
+ qq = tl[qq]; }
+ for(qq=hold;qq!=NIL&&hd[hd[qq]]==GUARD;qq=tl[qq])r--; /* less leading filters */
+ if(hd[hd[hold]]==GENERATOR)g1=tl[tl[hd[hold]]]; /* rhs of 1st generator */
+ e=transzf(e,hold,diag?diagonalise:concat);
+ /* diagonalise [ // ] comprehensions, but not [ | ] ones */
+ if(diag)
+ while(r--)e=ap(concat,e); /* see funny version of rule 3 below */
+ return(e==g1?ap2(APPEND,NIL,e):e); /* test in g1 is to fix HR bug */
+}
+/* HR bug - if Rule 1 applied at outermost level, type info is lost
+ eg [p|p<-3] ==> 3 (reported by Ham Richards, Nov 89)
+*/
+
+transzf(e,qq,conc) /* Bird and Wadler page 63 */
+word e,qq,conc;
+{ word q,q2;
+ if(qq==NIL)return(cons(e,NIL));
+ q=hd[qq];
+ if(hd[q]==GUARD)
+ return(ap3(COND,tl[q],transzf(e,tl[qq],conc),NIL));
+ if(tl[qq]==NIL)
+ if(hd[tl[q]]==e&&isvariable(e))return(tl[tl[q]]); /* Rule 1 */
+ else if(irrefutable(hd[tl[q]]))
+ return(ap2(MAP,lambda(hd[tl[q]],e),tl[tl[q]])); /* Rule 2 */
+ else /* Rule 2 warped for refutable patterns */
+ return(ap2(FLATMAP,lambda(hd[tl[q]],cons(e,NIL)),tl[tl[q]]));
+ q2=hd[tl[qq]];
+ if(hd[q2]==GUARD)
+ if(conc==concat) /* Rule 3 */
+ { tl[tl[q]]=ap2(FILTER,lambda(hd[tl[q]],tl[q2]),tl[tl[q]]);
+ tl[qq]=tl[tl[qq]];
+ return(transzf(e,qq,conc)); }
+ else /* funny [//] version of Rule 3 to avoid creating weak lists */
+ { e=ap3(COND,tl[q2],cons(e,NIL),NIL);
+ tl[qq]=tl[tl[qq]];
+ return(transzf(e,qq,conc)); } /* plus wrap result with concat */
+ return(ap(conc,transzf(transzf(e,tl[qq],conc),cons(q,NIL),conc)));
+ /* Rule 4 */
+}
+
+fixrepeats(qq) /* expands multi-lhs generators in zf expressions */
+word qq;
+{ word q = hd[qq];
+ word rhs = q;
+ qq = tl[qq];
+ while(hd[rhs]==REPEAT)rhs = tl[tl[rhs]];
+ rhs = tl[tl[rhs]]; /* rhs now contains the common right hand side */
+ while(hd[q]==REPEAT)
+ { qq = cons(cons(GENERATOR,cons(hd[tl[q]],rhs)),qq);
+ q = tl[tl[q]];
+ }
+ return(cons(q,qq));
+} /* EFFICIENCY PROBLEM - rhs gets re-evaluated for each lhs, fix later */
+ /* likewise re-typechecked, although this probably doesn't matter */
+
+lastlink(x) /* finds last link of a list -- needed with zf body elision */
+word x;
+{ while(tl[x]!=NIL)x=tl[x];
+ return(x);
+}
+
+#define ischar(x) ((x)>=0&&(x)<=255)
+
+genlhs(x) /* x is an expression found on the lhs of <- and genlhs returns
+ the corresponding pattern */
+word x;
+{ word hold;
+ switch(tag[x])
+ { case AP:
+ if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS&&isnat(tl[x]))
+ return(ap2(PLUS,tl[x],genlhs(tl[hd[x]]))); /* n+k pattern */
+ case CONS:
+ case TCONS:
+ case PAIR:
+ hold=genlhs(hd[x]); return(make(tag[x],hold,genlhs(tl[x])));
+ case ID:
+ if(member(idsused,x))return(cons(CONST,x));
+ if(!isconstructor(x))idsused=cons(x,idsused); return(x);
+ case INT: return(cons(CONST,x));
+ case DOUBLE: syntax("floating point literal in pattern\n");
+ return(nill);
+ case ATOM: if(x==True||x==False||x==NILS||x==NIL||ischar(x))
+ return(cons(CONST,x));
+ default: syntax("illegal form on left of <-\n");
+ return(nill);
+}}
+
+#ifdef OBSOLETE
+genexp(x) /* undoes effect of genlhs - sorry about that! (see qualifiers1)*/
+word x;
+{ switch(tag[x])
+ { case AP: return(ap(genexp(hd[x]),genexp(tl[x])));
+ case TCONS: return(tcons(genexp(hd[x]),genexp(tl[x])));
+ case PAIR: return(pair(genexp(hd[x]),genexp(tl[x])));
+ case CONS: return(hd[x]==CONST?tl[x]
+ :cons(genexp(hd[x]),genexp(tl[x])));
+ default: return(x); /* must be ID or constant */
+}}
+#endif
+
+word speclocs=NIL; /* list of cons(id,hereinfo) giving location of spec for
+ ids both defined and specified - needed to locate errs
+ in meta_tcheck, abstr_mcheck */
+getspecloc(x)
+word x;
+{ word s=speclocs;
+ while(s!=NIL&&hd[hd[s]]!=x)s=tl[s];
+ return(s==NIL?id_who(x):tl[hd[s]]); }
+
+declare(x,e) /* translates <pattern> = <exp> at top level */
+word x,e;
+{ if(tag[x]==ID&&!isconstructor(x))decl1(x,e);else
+ { word bindings=scanpattern(x,x,share(tries(x,cons(e,NIL)),undef_t),
+ ap(CONFERROR,cons(x,hd[e])));
+ /* hd[e] is here-info */
+ /* note creation of share node to force sharing on code generation
+ and typechecking */
+ if(bindings==NIL){ errs=hd[e];
+ syntax("illegal lhs for definition\n");
+ return; }
+ lastname=0;
+ while(bindings!=NIL)
+ { word h;
+ if(id_val(h=hd[hd[bindings]])!=UNDEF)
+ { errs=hd[e]; nameclash(h); return; }
+ id_val(h)=tl[hd[bindings]];
+ if(id_who(h)!=NIL)speclocs=cons(cons(h,id_who(h)),speclocs);
+ id_who(h)=hd[e]; /* here-info */
+ if(id_type(h)==undef_t)addtoenv(h);
+ bindings = tl[bindings];
+ }
+}}
+
+scanpattern(p,x,e,fail) /* declare ids in x as components of `p=e', each as
+ n = ($p.n)e, result is list of bindings */
+word p,x,e,fail;
+{ if(hd[x]==CONST||isconstructor(x))return(NIL);
+ if(tag[x]==ID){ word binding=
+ cons(x,ap2(TRY,ap(lambda(p,x),e),fail));
+ return(cons(binding,NIL)); }
+ if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ return(scanpattern(p,tl[x],e,fail));
+ return(shunt(scanpattern(p,hd[x],e,fail),scanpattern(p,tl[x],e,fail)));
+}
+
+get_ids(x) /* return list of names in pattern x (without repetitions) */
+word x;
+{ if(hd[x]==CONST||isconstructor(x))return(NIL);
+ if(tag[x]==ID)return(cons(x,NIL));
+ if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ return(get_ids(tl[x]));
+ return(UNION(get_ids(hd[x]),get_ids(tl[x])));
+}
+
+mktuple(x) /* extract tuple-structure of names from pattern x */
+word x;
+{ if(hd[x]==CONST||isconstructor(x))return(NIL);
+ if(tag[x]==ID)return(x);
+ if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ return(mktuple(tl[x]));
+{ word y=mktuple(tl[x]); x=mktuple(hd[x]);
+ return(x==NIL?y:y==NIL?x:pair(x,y));
+}}
+
+decl1(x,e) /* declare name x to have the value denoted by e */
+word x,e;
+{ if(id_val(x)!=UNDEF&&lastname!=x)
+ { errs=hd[e]; nameclash(x); return; }
+ if(id_val(x)==UNDEF)
+ { id_val(x)= tries(x,cons(e,NIL));
+ if(id_who(x)!=NIL)speclocs=cons(cons(x,id_who(x)),speclocs);
+ id_who(x)= hd[e]; /* here-info */
+ if(id_type(x)==undef_t)addtoenv(x);
+ } else
+ if(!fallible(hd[tl[id_val(x)]]))
+ errs=hd[e],
+ printf("%ssyntax error: unreachable case in defn of \"%s\"\n",
+ echoing?"\n":"",get_id(x)),
+ acterror();
+ else tl[id_val(x)]= cons(e,tl[id_val(x)]);
+/* multi-clause definitions are composed as tries(id,rhs_list)
+ where id is included purely for diagnostic purposes
+ note that rhs_list is reversed - put right by code generation */
+}
+
+fallible(e) /* e is "fallible" rhs - if not sure, says yes */
+word e;
+{ for(;;)
+ { if(tag[e]==LABEL)e=tl[e];
+ if(tag[e]==LETREC||tag[e]==LET)e=tl[e]; else
+ if(tag[e]==LAMBDA)
+ if(irrefutable(hd[e]))e=tl[e];
+ else return(1); else
+ if(tag[e]==AP&&tag[hd[e]]==AP&&tag[hd[hd[e]]]==AP&&hd[hd[hd[e]]]==COND)
+ e=tl[e]; else
+ return(e==FAIL); /* test for nested (COND a b FAIL) */
+ }
+} /* NOTE
+ When an rhs contains FAIL as a result of compiling an elseless guard set
+ it is of the form
+ XX ::= ap3(COND,a,b,FAIL) | let[rec](def[s],XX) | lambda(pat,XX)
+ an rhs is fallible if
+ 1) it is an XX, as above, or
+ 2) it is of the form lambda(pat1,...,lambda(patn,e)...)
+ where at least one of the patterns pati is refutable.
+ */
+
+/* combinator to select i'th out of n args *//*
+k(i,n)
+int i,n;
+{ if(i==1)return(n==1?I:n==2?K:ap2(B,K,k(1,n-1)));
+ if(i==2&&n==2)return(KI); /* redundant but saves space *//*
+ return(ap(K,k(i-1,n-1)));
+} */
+
+#define arity_check if(t_arity(tf)!=arity)\
+ printf("%ssyntax error: \
+wrong number of parameters for typename \"%s\" (%d expected)\n",\
+ echoing?"\n":"",get_id(tf),t_arity(tf)),errs=here,acterror()
+
+decltype(tf,class,info,here) /* declare a user defined type */
+word tf,class,info,here;
+{ word arity=0;
+ extern word errs;
+ while(tag[tf]==AP)arity++,tf=hd[tf];
+ if(class==synonym_t&&id_type(tf)==type_t&&t_class(tf)==abstract_t
+ &&t_info(tf)==undef_t)
+ { /* this is binding for declared but not yet bound abstract typename */
+ arity_check;
+ id_who(tf)=here;
+ t_info(tf)=info;
+ return; }
+ if(class==abstract_t&&id_type(tf)==type_t&&t_class(tf)==synonym_t)
+ { /* this is abstype declaration of already bound typename */
+ arity_check;
+ t_class(tf)=abstract_t;
+ return; }
+ if(id_val(tf)!=UNDEF)
+ { errs=here; nameclash(tf); return; }
+ if(class!=synonym_t)newtyps=add1(tf,newtyps);
+ id_val(tf)=make_typ(arity,class==algebraic_t?make_pn(UNDEF):0,class,info);
+ if(id_type(tf)!=undef_t){ errs=here; respec_error(tf); return; }
+ else addtoenv(tf);
+ id_who(tf)=here;
+ id_type(tf)=type_t;
+}
+
+declconstr(x,n,t) /* declare x to be constructor number n of type t */
+word x,n,t; /* x must be an identifier */
+{ id_val(x)=constructor(n,x);
+ if(n>>16)
+ { syntax("algebraic type has too many constructors\n"); return; }
+ if(id_type(x)!=undef_t){ errs=id_who(x); respec_error(x); return; }
+ else addtoenv(x);
+ id_type(x) = t;
+} /* the value of a constructor x is constructor(constr_tag,x)
+ where constr_tag is a small natural number */
+
+/* #define DEPSDEBUG .
+ /* switches on debugging printouts for dependency analysis in block() */
+#ifdef DEPSDEBUG
+pd(def)
+word def;
+{ out1(stdout,dlhs(def)); }
+
+pdlist(defs)
+word defs;
+{ putchar('(');
+ for(;defs!=NIL;defs=tl[defs])
+ pd(hd[defs]),printf(tl[defs]==NIL?"":",");
+ putchar(')');
+}
+#endif
+
+block(defs,e,keep) /* semantics of "where" - performs dependency analysis */
+/* defs has form list(defn(pat,typ,val)), e is body of block */
+/* if `keep' hold together as single letrec */
+word defs,e,keep;
+{ word ids=NIL,deftoids=NIL,g=NIL,d;
+ extern word SYNERR,detrop;
+ /* return(letrec(defs,e)); /* release one semantics was just this */
+ if(SYNERR)return(NIL); /* analysis falls over on empty patterns */
+ for(d=defs;d!=NIL;d=tl[d]) /* first collect all ids defined in block */
+ { word x = get_ids(dlhs(hd[d]));
+ ids=UNION(ids,x);
+ deftoids=cons(cons(hd[d],x),deftoids);
+ }
+ defs=sort(defs);
+ for(d=defs;d!=NIL;d=tl[d]) /* now build dependency relation g */
+ { word x=intersection(deps(dval(hd[d])),ids),y=NIL;
+ for(;x!=NIL;x=tl[x]) /* replace each id by corresponding def */
+ y=add1(invgetrel(deftoids,hd[x]),y);
+ g=cons(cons(hd[d],add1(hd[d],y)),g);
+ /* treat all defs as recursive for now */
+ }
+ g=reverse(g); /* keep in address order of first components */
+#ifdef DEPSDEBUG
+ { word g1=g;
+ printf("g=");
+ for(;g1!=NIL;g1=tl[g1])
+ pd(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';');
+ printf("\n"); }
+#endif
+/* g is list(cons(def,defs))
+ where defs are all on which def immediately depends, plus self */
+ g = tclos(g); /* now g is list(cons(def,ultdefs)) */
+#ifdef DEPSDEBUG
+ { word g1=g;
+ printf("tclos(g)=");
+ for(;g1!=NIL;g1=tl[g1])
+ pd(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';');
+ printf("\n"); }
+#endif
+ { /* check for unused definitions */
+ word x=intersection(deps(e),ids),y=NIL,*g1= &g;
+ for(;x!=NIL;x=tl[x])
+ { word d=invgetrel(deftoids,hd[x]);
+ if(!member(y,d))y=UNION(y,getrel(g,d)); }
+ defs=setdiff(defs,y); /* these are de trop */
+ if(defs!=NIL)detrop=append1(detrop,defs);
+ if(keep) /* if local polymorphism not required */
+ return(letrec(y,e)); /* analysis was solely to find unwanted defs */
+ /* remove redundant entries from g */
+ /* no, leave in for typecheck - could remove afterwards
+ while(*g1!=NIL&&defs!=NIL)
+ if(hd[hd[*g1]]==hd[defs])*g1=tl[*g1]; else
+ if(hd[hd[*g1]]<hd[defs])g1= &tl[*g1];
+ else defs=tl[defs]; */
+ }
+ g = msc(g); /* g is list(defgroup,ultdefs) */
+#ifdef DEPSDEBUG
+ { word g1=g;
+ printf("msc(g)=");
+ for(;g1!=NIL;g1=tl[g1])
+ pdlist(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';');
+ printf("\n"); }
+#endif
+ g = tsort(g); /* g is list(defgroup) in dependency order */
+#ifdef DEPSDEBUG
+ { word g1=g;
+ printf("tsort(g)=");
+ for(;g1!=NIL;g1=tl[g1])
+ pdlist(hd[g1]),putchar(';');
+ printf("\n"); }
+#endif
+ g = reverse(g); /* reconstruct block inside-first */
+ while(g!=NIL)
+ { if(tl[hd[g]]==NIL &&
+ intersection(get_ids(dlhs(hd[hd[g]])),deps(dval(hd[hd[g]])))==NIL
+ )e=let(hd[hd[g]],e); /* single non-recursive def */
+ else e=letrec(hd[g],e);
+ g=tl[g]; }
+ return(e);
+}
+/* Implementation note:
+ tsort will fall over if there is a non-list strong component because it
+ was originally written on assumption that relation is over identifiers.
+ Whence need to pretend all defs recursive until after tsort.
+ Could do better - some defs may be subsidiary to others */
+
+tclos(r) /* fast transitive closure - destructive in r */
+word r; /* r is of form list(cons(x,xs)) */
+{ word r1;
+ for(r1=r;r1!=NIL;r1=tl[r1])
+ { word x= less1(tl[hd[r1]],hd[hd[r1]]);
+ /* invariant x intersect tl[hd[r1]] = NIL */
+ while(x!=NIL)
+ { x=imageless(r,x,tl[hd[r1]]);
+ tl[hd[r1]]=UNION(tl[hd[r1]],x); }
+ }
+ return(r);
+}
+
+getrel(r,x) /* r is list(cons(x,xs)) - return appropriate xs, else NIL */
+word r,x;
+{ while(r!=NIL&&hd[hd[r]]!=x)r=tl[r];
+ return(r==NIL?NIL:tl[hd[r]]);
+}
+
+invgetrel(r,x) /* return first x1 such that `x1 r x' error if none found */
+word r,x;
+{ while(r!=NIL&&!member(tl[hd[r]],x))r=tl[r];
+ if(r==NIL)fprintf(stderr,"impossible event in invgetrel\n"),exit(1);
+ return(hd[hd[r]]);
+}
+
+
+imageless(r,y,z) /* image of set y in reln r, less set z */
+word r,y,z;
+{ word i=NIL;
+ while(r!=NIL&&y!=NIL)
+ if(hd[hd[r]]==hd[y])
+ i=UNION(i,less(tl[hd[r]],z)),r=tl[r],y=tl[y]; else
+ if(hd[hd[r]]<hd[y])r=tl[r];
+ else y=tl[y];
+ return(i);
+}
+
+less(x,y) /* non-destructive set difference x-y */
+word x,y;
+{ word r=NIL;
+ while(x!=NIL&&y!=NIL)
+ if(hd[x]==hd[y])x=tl[x],y=tl[y]; else
+ if(hd[x]<hd[y])r=cons(hd[x],r),x=tl[x];
+ else y=tl[y];
+ return(shunt(r,x));
+}
+
+less1(x,a) /* non-destructive set difference x- {a} */
+word x,a;
+{ word r=NIL;
+ while(x!=NIL&&hd[x]!=a)r=cons(hd[x],r),x=tl[x];
+ return(shunt(r,x==NIL?NIL:tl[x]));
+}
+
+sort(x) /* into address order */
+word x;
+{ word a=NIL,b=NIL,hold=NIL;
+ if(x==NIL||tl[x]==NIL)return(x);
+ while(x!=NIL) /* split x */
+ { hold=a,a=cons(hd[x],b),b=hold;
+ x=tl[x]; }
+ a=sort(a),b=sort(b);
+ /* now merge two halves back together */
+ while(a!=NIL&&b!=NIL)
+ if(hd[a]<hd[b])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));
+}
+
+sortrel(x) /* sort relation into address order of first components */
+word x; /* x is a list of cons(y,ys) */
+{ word a=NIL,b=NIL,hold=NIL;
+ if(x==NIL||tl[x]==NIL)return(x);
+ while(x!=NIL) /* split x */
+ { hold=a,a=cons(hd[x],b),b=hold;
+ x=tl[x]; }
+ a=sortrel(a),b=sortrel(b);
+ /* now merge two halves back together */
+ while(a!=NIL&&b!=NIL)
+ if(hd[hd[a]]<hd[hd[b]])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));
+}
+
+specify(x,t,h) /* semantics of a "::" statement */
+word x,t,h; /* N.B. t not yet in reduced form */
+{ extern word showwhat;
+ if(tag[x]!=ID&&t!=type_t){ errs=h;
+ syntax("incorrect use of ::\n");
+ return; }
+ if(t==type_t)
+ { word a=0;
+ while(tag[x]==AP)a++,x=hd[x];
+ if(!(id_val(x)==UNDEF&&id_type(x)==undef_t))
+ { errs=h; nameclash(x); return; }
+ id_type(x)=type_t;
+ if(id_who(x)==NIL)id_who(x)=h; /* premise always true, see above */
+ /* if specified and defined, locate by definition */
+ id_val(x)=make_typ(a,showwhat,placeholder_t,NIL);/* placeholder type */
+ addtoenv(x);
+ newtyps=add1(x,newtyps);
+ return; }
+ if(id_type(x)!=undef_t){ errs=h; respec_error(x); return; }
+ id_type(x)=t;
+ if(id_who(x)==NIL)id_who(x)=h; /* as above */
+ else speclocs=cons(cons(x,h),speclocs);
+ if(id_val(x)==UNDEF)addtoenv(x);
+}
+
+respec_error(x) /* only one type spec per name allowed - IS THIS RIGHT? */
+word x;
+{ extern word primenv;
+ if(echoing)putchar('\n');
+ printf("syntax error: type of \"%s\" already declared%s\n",get_id(x),
+ member(primenv,x)?" (in standard environment)":"");
+ acterror();
+}
+
+nameclash(x) /* only one top level binding per name allowed */
+word x;
+{ extern word primenv;
+ if(echoing)putchar('\n');
+ printf("syntax error: nameclash, \"%s\" already defined%s\n",get_id(x),
+ member(primenv,x)?" (in standard environment)":"");
+ acterror();
+}
+
+nclashcheck(n,dd,hr) /* is n already bound in list of definitions dd */
+word n,dd,hr;
+{ while(dd!=NIL&&!nclchk(n,dlhs(hd[dd]),hr))dd=tl[dd];
+}
+
+nclchk(n,p,hr) /* is n already bound in pattern p */
+word n,p,hr;
+{ if(hd[p]==CONST)return(0);
+ if(tag[p]==ID)
+ { if(n!=p)return(0);
+ if(echoing)putchar('\n');
+ errs=hr,
+ printf(
+"syntax error: conflicting definitions of \"%s\" in where clause\n",
+ get_id(n)),
+ acterror();
+ return(1); }
+ if(tag[p]==AP&&hd[p]==PLUS) /* hd of n+k pattern */
+ return(0);
+ return(nclchk(n,hd[p],hr)||nclchk(n,tl[p],hr));
+}
+
+transtypeid(x) /* recognises literal type constants - see RULES */
+word x;
+{ char *n=get_id(x);
+ return(strcmp(n,"bool")==0?bool_t:
+ strcmp(n,"num")==0?num_t:
+ strcmp(n,"char")==0?char_t:
+ x);
+}
+
+/* end of MIRANDA TRANS */
+
diff --git a/new/types.c b/new/types.c
new file mode 100644
index 0000000..f20627f
--- /dev/null
+++ b/new/types.c
@@ -0,0 +1,1613 @@
+/* MIRANDA TYPECHECKER */
+
+/**************************************************************************
+ * 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"
+word R=NIL; /* direct-and-indirect dependency graph */
+word TABSTRS=NIL; /* list of abstype declarations */
+word ND; /* undefined names used in script */
+word SBND; /* names specified but not defined (handled separately) */
+word FBS; /* list of bindings caused by parameterised %include's */
+word ATNAMES; /* global var set by abstr_check */
+word NT=NIL; /* undefined typenames used in script */
+word TYPERRS;
+word bnf_t=0;
+word current_id=0,lastloc=0,lineptr=0; /* used to locate type errors */
+word showchain=NIL; /* links together all occurrences of special forms (show)
+ encountered during typecheck */
+extern word rfl;
+
+#include <setjmp.h>
+jmp_buf env1; /* for longjmp - see man (3) setjmp */
+
+checktypes() /* outcome indicated by setting of flags SYNERR, TYPERRS, ND */
+{ word s;
+ extern word freeids,SYNERR,fnts;
+ ATNAMES=TYPERRS=0;
+ NT=R=SBND=ND=NIL; /* NT=R= added 4/6/88 */
+ if(setjmp(env1)==1)goto L;
+ if(rfl!=NIL)readoption();
+ for(s=reverse(fil_defs(hd[files]));s!=NIL;s=tl[s])
+ comp_deps(hd[s]); /* for each identifier in current script, compute
+ dependencies to form R */
+ R=tclos(sortrel(R));
+ if(FBS!=NIL)mcheckfbs();
+ abstr_mcheck(TABSTRS);
+L:if(TYPERRS)
+ { /* badly formed types, so give up */
+ TABSTRS=NT=R=NIL;
+ printf("typecheck cannot proceed - compilation abandoned\n");
+ SYNERR=1;
+ return; }
+ if(freeids!=NIL)redtfr(freeids);
+ /* printgraph("dependency analysis:",R); /* for debugging */
+ genshfns();
+ if(fnts!=NIL)genbnft();
+ R=msc(R);
+ /* printgraph("strong components:",R); /* for debugging */
+ s=tsort(R);
+ /* printlist("topological sort:",s); /* for debugging */
+ NT=R=NIL; /* must be invariant across the call */
+ while(s!=NIL)infer_type(hd[s]),s=tl[s];
+ checkfbs();
+ while(TABSTRS!=NIL)
+ abstr_check(hd[TABSTRS]),TABSTRS=tl[TABSTRS];
+ if(SBND!=NIL)
+ printlist("SPECIFIED BUT NOT DEFINED: ",alfasort(SBND)),SBND=NIL;
+ fixshows();
+ lastloc=0;
+ return;
+}
+
+/* NOTES
+ let element ::= id | list(id)
+ let graph1 ::= list(cons(id,list(id)))
+ let graph2 ::= list(cons(element,list(id)))
+ we define:
+ comp_deps(id)->builds R::graph1, direct dependencies
+ R=tclos(sortrel(R))::graph1, direct and indirect dependencies
+ msc(R)->collects maximal strong components in R, now R::graph2
+ tsort(graph2)->list(element), topologically sorted
+ infer_type(element)->fills in the id_type field(s) of element
+*/
+/* R occupies quadratic worst-case space - does anyone know a better way? */
+
+comp_deps(n) /* adds to R an entry of the form cons(n,RHS) where n is an
+ identifier and RHS is a list of all the identifiers in the
+ current script upon which n directly depends */
+/* it also meta-typechecks type specifications, and puts them in reduced
+ form, as it goes */
+word n;
+{ word rhs=NIL,r;
+ /* printf("comp_deps(%s)\n",get_id(n)); /* DEBUG */
+ if(id_type(n)==type_t)
+ { if(t_class(n)==algebraic_t)
+ { r=t_info(n);
+ while(r!=NIL) /* meta type check constructors */
+ { current_id=hd[r];
+ id_type(hd[r])=redtvars(meta_tcheck(id_type(hd[r])));
+ r=tl[r]; }
+ }
+ else if(t_class(n)==synonym_t)
+ current_id=n,t_info(n)=meta_tcheck(t_info(n));
+ else if(t_class(n)==abstract_t)
+ if(t_info(n)==undef_t)
+ printf("error: script contains no binding for abstract typename\
+ \"%s\"\n",get_id(n)),sayhere(id_who(n),1),TYPERRS++;
+ else current_id=n,t_info(n)=meta_tcheck(t_info(n));
+ /* placeholder types - no action */
+ current_id=0;
+ return; }
+ if(tag[id_val(n)]==CONSTRUCTOR)return;
+ /* primitive constructors require no type analysis */
+ if(id_type(n)!=undef_t) /* meta typecheck spec, if present */
+ { current_id=n;
+ if(tag[id_type(n)]==CONS)
+ { /* signature identifier */
+ if(id_val(n)==UNDEF)SBND=add1(n,SBND);
+ id_type(n)=redtvars(meta_tcheck(hd[id_type(n)]));
+ current_id=0;
+ return; } /* typechecked separately, under TABSTRS */
+ id_type(n)=redtvars(meta_tcheck(id_type(n)));
+ current_id=0; }
+ if(id_val(n)==FREE)return; /* no further analysis required */
+ if(id_val(n)==UNDEF) /* name specified but not defined */
+ { SBND=add1(n,SBND); /* change of policy (as for undefined sigid, above) */
+ return; } /* now not added to ND, so script can be %included */
+ r=deps(id_val(n));
+ while(r!=NIL)
+ { if(id_val(hd[r])!=UNDEF&&id_type(hd[r])==undef_t)
+ /* only defined names without explicitly assigned types
+ cause dependency */
+ rhs=add1(hd[r],rhs);
+ r=tl[r]; }
+ R=cons(cons(n,rhs),R);
+}
+
+tsort(g) /* topological sort - returns a list of the elements in the domain
+ of relation g, in an order such that each element is preceded by everything
+ it depends on */
+word g; /* the structure of g is "graph2" see NOTES above */
+{ word NP=NIL; /* NP is set of elements with no predecessor */
+ word g1=g, r=NIL; /* r is result */
+ g=NIL;
+ while(g1!=NIL)
+ { if(tl[hd[g1]]==NIL)NP=cons(hd[hd[g1]],NP);
+ else g=cons(hd[g1],g);
+ g1=tl[g1]; }
+ while(NP!=NIL)
+ { word D=NIL; /* ids to be removed from range of g */
+ while(NP!=NIL)
+ { r=cons(hd[NP],r);
+ if(tag[hd[NP]]==ID)D=add1(hd[NP],D);
+ else D=UNION(D,hd[NP]);
+ NP=tl[NP]; }
+ g1=g;g=NIL;
+ while(g1!=NIL)
+ { word rhs=setdiff(tl[hd[g1]],D);
+ if(rhs==NIL)NP=cons(hd[hd[g1]],NP);
+ else tl[hd[g1]]=rhs,g=cons(hd[g1],g);
+ g1=tl[g1]; }
+ }
+ if(g!=NIL)fprintf(stderr,"error: impossible event in tsort\n");
+ return(reverse(r));
+}
+
+msc(R) /* collects maximal strong components in R, converting it from "graph1"
+ to "graph2" form - destructive in R */
+word R;
+{ word R1=R;
+ while(R1!=NIL)
+ { word *r= &tl[hd[R1]],l=hd[hd[R1]];
+ if(remove1(l,r))
+ { hd[hd[R1]]=cons(l,NIL);
+ while(*r!=NIL)
+ { word n=hd[*r],*R2= &tl[R1];
+ while(*R2!=NIL&&hd[hd[*R2]]!=n)R2= &tl[*R2]; /* find n-entry in R */
+ if(*R2!=NIL&&member(tl[hd[*R2]],l))
+ { *r=tl[*r]; /* remove n from r */
+ *R2=tl[*R2]; /* remove n's entry from R */
+ hd[hd[R1]]=add1(n,hd[hd[R1]]);
+ }
+ else r= &tl[*r];
+ }
+ }
+ R1=tl[R1];
+ }
+ return(R);
+}
+
+word meta_pending=NIL;
+
+meta_tcheck(t) /* returns type t with synonyms substituted out and checks that
+ the result is well formed */
+word t;
+{ word tn=t,i=0;
+ /* TO DO -- TIDY UP ERROR MESSAGES AND SET ERRLINE (ERRS) IF POSS */
+ while(iscompound_t(tn))
+ tl[tn]=meta_tcheck(tl[tn]),i++,tn=hd[tn];
+ if(tag[tn]==STRCONS)goto L; /* patch to handle free type bindings */
+ if(tag[tn]!=ID)
+ { if(i>0&&(isvar_t(tn)||tn==bool_t||tn==num_t||tn==char_t))
+ { TYPERRS++;
+ if(tag[current_id]==DATAPAIR)
+ locate_inc(),
+ printf("badly formed type \""),out_type(t),
+ printf("\" in binding for \"%s\"\n",(char *)hd[current_id]),
+ printf("("),out_type(tn),printf(" has zero arity)\n");
+ else
+ printf("badly formed type \""),out_type(t),
+ printf("\" in %s for \"%s\"\n",
+ id_type(current_id)==type_t?"== binding":"specification",
+ get_id(current_id)),
+ printf("("),out_type(tn),printf(" has zero arity)\n"),
+ sayhere(getspecloc(current_id),1);
+ sterilise(t); }
+ return(t); }
+ if(id_type(tn)==undef_t&&id_val(tn)==UNDEF)
+ { TYPERRS++;
+ if(!member(NT,tn))
+ { if(tag[current_id]==DATAPAIR)locate_inc();
+ printf("undeclared typename \"%s\" ",get_id(tn));
+ if(tag[current_id]==DATAPAIR)
+ printf("in binding for %s\n",(char *)hd[current_id]);
+ else sayhere(getspecloc(current_id),1);
+ NT=add1(tn,NT); }
+ return(t); }else
+ if(id_type(tn)!=type_t||t_arity(tn)!=i)
+ { TYPERRS++;
+ if(tag[current_id]==DATAPAIR)
+ locate_inc(),
+ printf("badly formed type \""),out_type(t),
+ printf("\" in binding for \"%s\"\n",(char *)hd[current_id]);
+ else
+ printf("badly formed type \""),out_type(t),
+ printf("\" in %s for \"%s\"\n",
+ id_type(current_id)==type_t?"== binding":"specification",
+ get_id(current_id));
+ if(id_type(tn)!=type_t)
+ printf("(%s not defined as typename)\n",get_id(tn));
+ else printf("(typename %s has arity %d)\n",get_id(tn),t_arity(tn));
+ if(tag[current_id]!=DATAPAIR)
+ sayhere(getspecloc(current_id),1);
+ sterilise(t);
+ return(t); }
+L:if(t_class(tn)!=synonym_t)return(t);
+ if(member(meta_pending,tn))
+ { TYPERRS++;/* report cycle */
+ if(tag[current_id]==DATAPAIR)locate_inc();
+ printf("error: cycle in type \"==\" definition%s ",
+ meta_pending==NIL?"":"s");
+ printelement(meta_pending); putchar('\n');
+ if(tag[current_id]!=DATAPAIR)
+ sayhere(id_who(tn),1);
+ longjmp(env1,1); /* fatal error - give up */
+/* t_class(tn)=algebraic_t;t_info(tn)=NIL;
+ /* to make sure we dont fall in here again! */
+ return(t); }
+ meta_pending=cons(tn,meta_pending);
+ tn=NIL;
+ while(iscompound_t(t))
+ tn=cons(tl[t],tn),t=hd[t];
+ t=meta_tcheck(ap_subst(t_info(t),tn));
+ meta_pending=tl[meta_pending];
+ return(t);
+}
+/* needless inefficiency - we recheck the rhs of a synonym every time we
+ use it */
+
+sterilise(t) /* to prevent multiple reporting of metatype errors from
+ namelist :: type */
+word t;
+{ if(tag[t]==AP)hd[t]=list_t,tl[t]=num_t;
+}
+
+word tvcount=1;
+#define NTV mktvar(tvcount++)
+ /* brand new type variable */
+#define reset_SUBST (current_id=tvcount>=hashsize?clear_SUBST():0)
+
+infer_type(x) /* deduces the types of the identifiers in x - no result,
+ works by filling in id_type fields */
+word x; /* x is an "element" */
+{ if(tag[x]==ID)
+ { word t,oldte=TYPERRS;
+ current_id=x;
+ t = subst(etype(id_val(x),NIL,NIL));
+ if(id_type(x)==undef_t)id_type(x)=redtvars(t);
+ else /* x already has assigned type */
+ if(!subsumes(t,instantiate(id_type(x))))
+ { TYPERRS++;
+ printf("incorrect declaration ");
+ sayhere(getspecloc(x),1); /* or: id_who(x) to locate defn */
+ printf("specified, "); report_type(x); putchar('\n');
+ printf("inferred, %s :: ",get_id(x)); out_type(redtvars(t));
+ putchar('\n'); }
+ if(TYPERRS>oldte)id_type(x)=wrong_t,
+ id_val(x)=UNDEF,
+ ND=add1(x,ND);
+ reset_SUBST; }
+ else{ /* recursive group of names */
+ word x1,oldte,ngt=NIL;
+ for(x1=x;x1!=NIL;x1=tl[x1])
+ ngt=cons(NTV,ngt),
+ id_type(hd[x1])=ap(bind_t,hd[ngt]);
+ for(x1=x;x1!=NIL;x1=tl[x1])
+ { oldte=TYPERRS,
+ current_id=hd[x1],
+ unify(tl[id_type(hd[x1])],etype(id_val(hd[x1]),NIL,ngt));
+ if(TYPERRS>oldte)
+ id_type(hd[x1])=wrong_t,
+ id_val(hd[x1])=UNDEF,ND=add1(hd[x1],ND); }
+ for(x1=x;x1!=NIL;x1=tl[x1])
+ if(id_type(hd[x1])!=wrong_t)
+ id_type(hd[x1])=redtvars(ult(tl[id_type(hd[x1])]));
+ reset_SUBST;
+ }
+}
+
+word hereinc; /* location of currently-being-processed %include */
+word lasthereinc;
+
+mcheckfbs()
+{ word ff,formals,n;
+ lasthereinc=0;
+ for(ff=FBS;ff!=NIL;ff=tl[ff])
+ { hereinc=hd[hd[FBS]];
+ for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals])
+ { word t=tl[tl[hd[formals]]];
+ if(t!=type_t)continue;
+ current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
+ t_info(hd[hd[formals]])=meta_tcheck(t_info(hd[hd[formals]]));
+ /*ATNAMES=cons(hd[hd[formals]],ATNAMES?ATNAMES:NIL); */
+ current_id=0;
+ }
+ if(TYPERRS)return; /* to avoid misleading error messages */
+ for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals])
+ { word t=tl[tl[hd[formals]]];
+ if(t==type_t)continue;
+ current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
+ tl[tl[hd[formals]]]=redtvars(meta_tcheck(t));
+ current_id=0;
+ }
+ /* above double traverse is very inefficient way of doing types first
+ would be better to have bindings sorted in this order beforehand */
+ }
+ /* all imported names must now have their types reduced to
+ canonical form wrt the parameter bindings */
+ /* alternative method - put info in ATNAMES, see above and in abstr_check */
+ /* a problem with this is that types do not print in canonical form */
+ if(TYPERRS)return;
+ for(ff=tl[files];ff!=NIL;ff=tl[ff])
+ for(formals=fil_defs(hd[ff]);formals!=NIL;formals=tl[formals])
+ if(tag[n=hd[formals]]==ID)
+ if(id_type(n)==type_t)
+ { if(t_class(n)==synonym_t)t_info(n)=meta_tcheck(t_info(n)); }
+ else id_type(n)=redtvars(meta_tcheck(id_type(n)));
+} /* wasteful if many includes */
+
+redtfr(x) /* ensure types of freeids are in reduced form */
+word x;
+{ for(;x!=NIL;x=tl[x])
+ tl[tl[hd[x]]] = id_type(hd[hd[x]]);
+}
+
+checkfbs()
+/* FBS is list of entries of form cons(hereinfo,formals) where formals
+ has elements of form cons(id,cons(datapair(orig,0),type)) */
+{ word oldte=TYPERRS,formals;
+ lasthereinc=0;
+ for(;FBS!=NIL;FBS=tl[FBS])
+ for(hereinc=hd[hd[FBS]],formals=tl[hd[FBS]];
+ formals!=NIL;formals=tl[formals])
+ { word t,t1=fix_type(tl[tl[hd[formals]]]);
+ if(t1==type_t)continue;
+ current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
+ t = subst(etype(the_val(hd[hd[formals]]),NIL,NIL));
+ if(!subsumes(t,instantiate(t1)))
+ { TYPERRS++;
+ locate_inc();
+ printf("binding for parameter `%s' has wrong type\n",
+ (char *)hd[current_id]);
+ printf( "required :: "); out_type(tl[tl[hd[formals]]]);
+ printf("\n actual :: "); out_type(redtvars(t));
+ putchar('\n'); }
+ the_val(hd[hd[formals]])=codegen(the_val(hd[hd[formals]])); }
+ if(TYPERRS>oldte)
+ { /* badly typed parameter bindings, so give up */
+ extern word SYNERR;
+ TABSTRS=NT=R=NIL;
+ printf("compilation abandoned\n");
+ SYNERR=1; }
+ reset_SUBST;
+}
+
+fix_type(t,x) /* substitute out any indirected typenames in t */
+word t,x;
+{ switch(tag[t])
+ { case AP:
+ case CONS: tl[t]=fixtype(tl[t],x);
+ hd[t]=fixtype(hd[t],x);
+ default: return(t);
+ case STRCONS: while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/
+ return(t);
+ }
+}
+
+locate_inc()
+{ if(lasthereinc==hereinc)return;
+ printf("incorrect %%include directive ");
+ sayhere(lasthereinc=hereinc,1);
+}
+
+abstr_mcheck(tabstrs) /* meta-typecheck abstract type declarations */
+word tabstrs;
+{ while(tabstrs!=NIL)
+ { word atnames=hd[hd[tabstrs]],sigids=tl[hd[tabstrs]],rtypes=NIL;
+ if(cyclic_abstr(atnames))return;
+ while(sigids!=NIL) /* compute representation types */
+ { word rt=rep_t(id_type(hd[sigids]),atnames);
+ /*if(rt==id_type(hd[sigids]))
+ printf("abstype declaration error: \"%s\" has a type unrelated to \
+the abstraction\n",get_id(hd[sigids])),
+ sayhere(getspecloc(hd[sigids]),1),
+ TYPERRS++; /* suppressed June 89, see karen.m, secret.m */
+ rtypes=cons(rt,rtypes);
+ sigids=tl[sigids]; }
+ rtypes=reverse(rtypes);
+ hd[hd[tabstrs]]=cons(hd[hd[tabstrs]],rtypes);
+ tabstrs=tl[tabstrs];
+ }
+}
+
+abstr_check(x) /* typecheck the implementation equations of a type abstraction
+ with the given signature */
+word x;
+{ word rtypes=tl[hd[x]],sigids=tl[x];
+/*int holdat=ATNAMES;
+ ATNAMES=shunt(hd[hd[x]],ATNAMES); */
+ ATNAMES=hd[hd[x]];
+ txchange(sigids,rtypes); /* install representation types */
+ /* report_types("concrete signature:\n",sigids); /* DEBUG */
+ for(x=sigids;x!=NIL;x=tl[x])
+ { word t,oldte=TYPERRS;
+ current_id=hd[x];
+ t=subst(etype(id_val(hd[x]),NIL,NIL));
+ if(!subsumes(t,instantiate(id_type(hd[x]))))
+ { TYPERRS++;
+ printf("abstype implementation error\n");
+ printf("\"%s\" is bound to value of type: ",get_id(hd[x]));
+ out_type(redtvars(t));
+ printf("\ntype expected: ");
+ out_type(id_type(hd[x]));
+ putchar('\n');
+ sayhere(id_who(hd[x]),1); }
+ if(TYPERRS>oldte)
+ id_type(hd[x])=wrong_t,id_val(hd[x])=UNDEF,ND=add1(hd[x],ND);
+ reset_SUBST; }
+ /* restore the abstract types - for "finger" */
+ for(x=sigids;x!=NIL;x=tl[x],rtypes=tl[rtypes])
+ if(id_type(hd[x])!=wrong_t)id_type(hd[x])=hd[rtypes];
+ ATNAMES= /* holdat */ 0;
+}
+
+cyclic_abstr(atnames) /* immediately-cyclic acts of dta are illegal */
+word atnames;
+{ word x,y=NIL;
+ for(x=atnames;x!=NIL;x=tl[x])y=ap(y,t_info(hd[x]));
+ for(x=atnames;x!=NIL;x=tl[x])
+ if(occurs(hd[x],y))
+ { printf("illegal type abstraction: cycle in \"==\" binding%s ",
+ tl[atnames]==NIL?"":"s");
+ printelement(atnames); putchar('\n');
+ sayhere(id_who(hd[x]),1);
+ TYPERRS++; return(1); }
+ return(0);
+}
+
+txchange(ids,x) /* swap the id_type of each id with the corresponding type
+ in the list x */
+word ids,x;
+{ while(ids!=NIL)
+ { word t=id_type(hd[ids]);
+ id_type(hd[ids])=hd[x],hd[x]=t;
+ ids=tl[ids],x=tl[x]; }
+}
+
+report_type(x)
+word x;
+{ printf("%s",get_id(x));
+ if(id_type(x)==type_t)
+ if(t_arity(x)>5)printf("(arity %d)",t_arity(x));
+ else { word i,j;
+ for(i=1;i<=t_arity(x);i++)
+ { putchar(' ');
+ for(j=0;j<i;j++)putchar('*'); }
+ }
+ printf(" :: ");
+ out_type(id_type(x));
+}
+
+report_types(header,x)
+char *header;
+word x;
+{ printf("%s",header);
+ while(x!=NIL)
+ report_type(hd[x]),putchar(';'),x=tl[x];
+ putchar('\n');
+}
+
+typesfirst(x) /* rearrange list of ids to put types first */
+word x;
+{ word *y= &x,z=NIL;
+ while(*y!=NIL)
+ if(id_type(hd[*y])==type_t)
+ z=cons(hd[*y],z),*y=tl[*y];
+ else y= &tl[*y];
+ return(shunt(z,x));
+}
+
+rep_t1(T,L) /* computes the representation type corresponding to T, wrt the
+ abstract typenames in L */
+ /* will need to apply redtvars to result, see below */
+ /* if no substitutions found, result is identically T */
+word T,L;
+{ word args=NIL,t1,new=0;
+ for(t1=T;iscompound_t(t1);t1=hd[t1])
+ { word a=rep_t1(tl[t1],L);
+ if(a!=tl[t1])new=1;
+ args=cons(a,args); }
+ if(member(L,t1))return(ap_subst(t_info(t1),args));
+ /* call to redtvars removed 26/11/85
+ leads to premature normalisation of subterms */
+ if(!new)return(T);
+ while(args!=NIL)
+ t1=ap(t1,hd[args]),args=tl[args];
+ return(t1);
+}
+
+rep_t(T,L) /* see above */
+word T,L;
+{ word t=rep_t1(T,L);
+ return(t==T?t:redtvars(t));
+}
+
+type_of(x) /* returns the type of expression x, in reduced form */
+word x;
+{ word t;
+ TYPERRS=0;
+ t=redtvars(subst(etype(x,NIL,NIL)));
+ fixshows();
+ if(TYPERRS>0)t=wrong_t;
+ return(t);
+}
+
+checktype(x) /* is expression x well-typed ? */
+ /* not currently used */
+word x;
+{ TYPERRS=0;
+ etype(x,NIL,NIL);
+ reset_SUBST;
+ return(!TYPERRS);
+}
+
+#define bound_t(t) (iscompound_t(t)&&hd[t]==bind_t)
+#define tf(a,b) ap2(arrow_t,a,b)
+#define tf2(a,b,c) tf(a,tf(b,c))
+#define tf3(a,b,c,d) tf(a,tf2(b,c,d))
+#define tf4(a,b,c,d,e) tf(a,tf3(b,c,d,e))
+#define lt(a) ap(list_t,a)
+#define pair_t(x,y) ap2(comma_t,x,ap2(comma_t,y,void_t))
+
+word tfnum,tfbool,tfbool2,tfnum2,tfstrstr,tfnumnum,ltchar,
+ tstep,tstepuntil;
+
+tsetup()
+{ tfnum=tf(num_t,num_t);
+ tfbool=tf(bool_t,bool_t);
+ tfnum2=tf(num_t,tfnum);
+ tfbool2=tf(bool_t,tfbool);
+ ltchar=lt(char_t);
+ tfstrstr=tf(ltchar,ltchar);
+ tfnumnum=tf(num_t,num_t);
+ tstep=tf2(num_t,num_t,lt(num_t));
+ tstepuntil=tf(num_t,tstep);
+}
+
+word exec_t=0,read_t=0,filestat_t=0; /* set lazily, when used */
+
+genlstat_t() /* type of %lex state */
+{ return(pair_t(num_t,num_t)); }
+
+genbnft() /* if %bnf used, find out input type of parsing fns */
+{ word bnftokenstate=findid("bnftokenstate");
+ if(bnftokenstate!=NIL&&id_type(bnftokenstate)==type_t)
+ if(t_arity(bnftokenstate)==0)
+ bnf_t=t_class(bnftokenstate)==synonym_t?
+ t_info(bnftokenstate):bnftokenstate;
+ else printf("warning - bnftokenstate has arity>0 (ignored by parser)\n"),
+ bnf_t=void_t;
+ else bnf_t=void_t; /* now bnf_t holds the state type */
+ bnf_t=ap2(comma_t,ltchar,ap2(comma_t,bnf_t,void_t));
+} /* the input type for parsers is lt(bnf_t)
+ note that tl[hd[tl[bnf_t]]] holds the state type */
+
+extern word col_fn;
+
+checkcolfn() /* if offside rule used, check col_fn has right type */
+{ word t=id_type(col_fn),f=tf(tl[hd[tl[bnf_t]]],num_t);
+ if(t==undef_t||t==wrong_t
+ /* will be already reported - do not generate further typerrs
+ in both cases col_fn will behave as undefined name */
+ ||subsumes(instantiate(t),f))
+ { col_fn=0; return; } /* no further action required */
+ printf("`bnftokenindentation' has wrong type for use in offside rule\n");
+ printf("type required :: "); out_type(f); putchar('\n');
+ printf(" actual type :: "); out_type(t); putchar('\n');
+ sayhere(getspecloc(col_fn),1);
+ TYPERRS++;
+ col_fn= -1; /* error flag */
+} /* note that all parsing fns get type wrong_t if offside rule used
+ anywhere and col_fn has wrong type - strictly this is overkill */
+
+etype(x,env,ngt) /* infer a type for an expression, by using unification */
+word x,env; /* env is list of local bindings of variables to types */
+word ngt; /* ngt is list of non-generic type variables */
+{ word a,b,c,d; /* initialise to 0 ? */
+ switch(tag[x])
+ { case AP: if(hd[x]==BADCASE||hd[x]==CONFERROR)return(NTV);
+ /* don't type check insides of error messages */
+ { word ft=etype(hd[x],env,ngt),at=etype(tl[x],env,ngt),rt=NTV;
+ if(!unify1(ft,ap2(arrow_t,at,rt)))
+ { ft=subst(ft);
+ if(isarrow_t(ft))
+ if(tag[hd[x]]==AP&&hd[hd[x]]==G_ERROR)
+ type_error8(at,tl[hd[ft]]);
+ else
+ type_error("unify","with",at,tl[hd[ft]]);
+ else type_error("apply","to",ft,at);
+ return(NTV); }
+ return(rt); }
+ case CONS: { word ht=etype(hd[x],env,ngt),rt=etype(tl[x],env,ngt);
+ if(!unify1(ap(list_t,ht),rt))
+ { type_error("cons","to",ht,rt);
+ return(NTV); }
+ return(rt); }
+ case LEXER: { word hold=lineptr;
+ lineptr=hd[tl[tl[hd[x]]]];
+ tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label(hereinf,-)*/
+ a=etype(tl[tl[hd[x]]],env,ngt);
+ while((x=tl[x])!=NIL)
+ { lineptr=hd[tl[tl[hd[x]]]];
+ tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label... */
+ if(!unify1(a,b=etype(tl[tl[hd[x]]],env,ngt)))
+ { type_error7(a,b);
+ lineptr=hold;
+ return(NTV); }
+ }
+ lineptr=hold;
+ return(tf(ltchar,lt(a))); }
+ case TCONS: return(ap2(comma_t,etype(hd[x],env,ngt),
+ etype(tl[x],env,ngt)));
+ case PAIR: return(ap2(comma_t,etype(hd[x],env,ngt),
+ ap2(comma_t,etype(tl[x],env,ngt),void_t)));
+ case DOUBLE:
+ case INT: return(num_t);
+ case ID: a=env;
+ while(a!=NIL) /* take local binding, if present */
+ if(hd[hd[a]]==x)
+ return(linst(tl[hd[a]]=subst(tl[hd[a]]),ngt));
+ else a=tl[a];
+ a=id_type(x); /* otherwise pick up global binding */
+ if(bound_t(a))return(tl[a]);
+ if(a==type_t)type_error1(x);
+ if(a==undef_t)
+ { extern word commandmode;
+ if(commandmode)type_error2(x);
+ else
+ if(!member(ND,x)) /* report first occurrence only */
+ { if(lineptr)sayhere(lineptr,0);
+ else if(tag[current_id]==DATAPAIR) /* see checkfbs */
+ locate_inc();
+ printf("undefined name \"%s\"\n",get_id(x));
+ ND=add1(x,ND); }
+ return(NTV); }
+ if(a==wrong_t)return(NTV);
+ return(instantiate(ATNAMES?rep_t(a,ATNAMES):a));
+ case LAMBDA: a=NTV; b=NTV;
+ d=cons(a,ngt);
+ c=conforms(hd[x],a,env,d);
+ if(c==-1||!unify(b,etype(tl[x],c,d)))return(NTV);
+ return(tf(a,b));
+ case LET: { word e,def=hd[x];
+ a=NTV,e=conforms(dlhs(def),a,env,cons(a,ngt));
+ current_id=cons(dlhs(def),current_id);
+ c=lineptr; lineptr=dval(def);
+ b = unify(a,etype(dval(def),env,ngt));
+ lineptr=c;
+ current_id=tl[current_id];
+ if(e==-1||!b)return(NTV);
+ return(etype(tl[x],e,ngt)); }
+ case LETREC: { word e=env,s=NIL;
+ a=NIL; c=ngt;
+ for(d=hd[x];d!=NIL;d=tl[d])
+ if(dtyp(hd[d])==undef_t)
+ a=cons(hd[d],a), /* unspecified defs */
+ dtyp(hd[d])=(b=NTV),
+ c=cons(b,c), /* collect non-generic tvars */
+ e=conforms(dlhs(hd[d]),b,e,c);
+ else dtyp(hd[d])=meta_tcheck(dtyp(hd[d])),
+ /* should do earlier, and locate errs properly*/
+ s=cons(hd[d],s), /* specified defs */
+ e=cons(cons(dlhs(hd[d]),dtyp(hd[d])),e);
+ if(e==-1)return(NTV);
+ b=1;
+ for(;a!=NIL;a=tl[a])
+ { current_id=cons(dlhs(hd[a]),current_id);
+ d=lineptr; lineptr=dval(hd[a]);
+ b &= unify(dtyp(hd[a]),etype(dval(hd[a]),e,c));
+ lineptr=d; current_id=tl[current_id]; }
+ for(;s!=NIL;s=tl[s])
+ { current_id=cons(dlhs(hd[s]),current_id);
+ d=lineptr; lineptr=dval(hd[s]);
+ if(!subsumes(a=etype(dval(hd[s]),e,ngt),
+ linst(dtyp(hd[s]),ngt)))
+ /* would be better to set lineptr to spec here */
+ b=0,type_error6(dlhs(hd[s]),dtyp(hd[s]),a);
+ lineptr=d; current_id=tl[current_id]; }
+ if(!b)return(NTV);
+ return(etype(tl[x],e,ngt)); }
+ case TRIES: { word hold=lineptr;
+ a=NTV;
+ x=tl[x];
+ while(x!=NIL&&(lineptr=hd[hd[x]],
+ unify(a,etype(tl[hd[x]],env,ngt)))
+ )x=tl[x];
+ lineptr=hold;
+ if(x!=NIL)return(NTV);
+ return(a); }
+ case LABEL: { word hold=lineptr,t;
+ lineptr=hd[x];
+ t=etype(tl[x],env,ngt);
+ lineptr=hold;
+ return(t); }
+ case STARTREADVALS: if(tl[x]==0)
+ hd[x]=lineptr, /* insert here-info */
+ tl[x]=NTV,
+ showchain=cons(x,showchain);
+ return(tf(ltchar,lt(tl[x])));
+ case SHOW: hd[x]=lineptr; /* insert here-info */
+ showchain=cons(x,showchain);
+ return(tf(tl[x]=NTV,ltchar));
+ case SHARE: if(tl[x]==undef_t)
+ { word h=TYPERRS;
+ tl[x]=subst(etype(hd[x],env,ngt));
+ if(TYPERRS>h)hd[x]=UNDEF,tl[x]=wrong_t; }
+ if(tl[x]==wrong_t)
+ { TYPERRS++; return(NTV); }
+ return(tl[x]);
+ case CONSTRUCTOR: a=id_type(tl[x]);
+ return(instantiate(ATNAMES?rep_t(a,ATNAMES):a));
+ case UNICODE: return(char_t);
+ case ATOM: if(x<256)return(char_t);
+ switch(x)
+ {
+ case S:a=NTV,b=NTV,c=NTV;
+ d=tf3(tf2(a,b,c),tf(a,b),a,c);
+ return(d);
+ case K:a=NTV,b=NTV;
+ return(tf2(a,b,a));
+ case Y:a=NTV;
+ return(tf(tf(a,a),a));
+ case C:a=NTV,b=NTV,c=NTV;
+ return(tf3(tf2(a,b,c),b,a,c));
+ case B:a=NTV,b=NTV,c=NTV;
+ return(tf3(tf(a,b),tf(c,a),c,b));
+ case FORCE:
+ case G_UNIT:
+ case G_RULE:
+ case I:a=NTV;
+ return(tf(a,a));
+ case G_ZERO:return(NTV);
+ case HD:a=NTV;
+ return(tf(lt(a),a));
+ case TL:a=lt(NTV);
+ return(tf(a,a));
+ case BODY:a=NTV,b=NTV;
+ return(tf(ap(a,b),a));
+ case LAST:a=NTV,b=NTV;
+ return(tf(ap(a,b),b));
+ case S_p:a=NTV,b=NTV;
+ c=lt(b);
+ return(tf3(tf(a,b),tf(a,c),a,c));
+ case U:
+ case U_: a=NTV,b=NTV;
+ c=lt(a);
+ return(tf2(tf2(a,c,b),c,b));
+ case Uf: a=NTV,b=NTV,c=NTV;
+ return(tf2(tf2(tf(a,b),a,c),b,c));
+ case COND: a=NTV;
+ return(tf3(bool_t,a,a,a));
+ case EQ:case GR:case GRE:
+ case NEQ: a=NTV;
+ return(tf2(a,a,bool_t));
+ case NEG: return(tfnum);
+ case AND:
+ case OR: return(tfbool2);
+ case NOT: return(tfbool);
+ case MERGE:
+ case APPEND: a=lt(NTV);
+ return(tf2(a,a,a));
+ case STEP: return(tstep);
+ case STEPUNTIL: return(tstepuntil);
+ case MAP: a=NTV; b=NTV;
+ return(tf2(tf(a,b),lt(a),lt(b)));
+ case FLATMAP: a=NTV,b=lt(NTV);
+ return(tf2(tf(a,b),lt(a),b));
+ case FILTER: a=NTV; b=lt(a);
+ return(tf2(tf(a,bool_t),b,b));
+ case ZIP: a=NTV; b=NTV;
+ return(tf2(lt(a),lt(b),lt(pair_t(a,b))));
+ case FOLDL: a=NTV; b=NTV;
+ return(tf3(tf2(a,b,a),a,lt(b),a));
+ case FOLDL1: a=NTV;
+ return(tf2(tf2(a,a,a),lt(a),a));
+ case LIST_LAST: a=NTV;
+ return(tf(lt(a),a));
+ case FOLDR: a=NTV; b=NTV;
+ return(tf3(tf2(a,b,b),b,lt(a),b));
+ case MATCHINT:
+ case MATCH: a=NTV,b=NTV;
+ return(tf3(a,b,a,b));
+ case TRY: a=NTV;
+ return(tf2(a,a,a));
+ case DROP:
+ case TAKE: a=lt(NTV);
+ return(tf2(num_t,a,a));
+ case SUBSCRIPT:a=NTV;
+ return(tf2(num_t,lt(a),a));
+ case P: a=NTV;
+ b=lt(a);
+ return(tf2(a,b,b));
+ case B_p: a=NTV,b=NTV;
+ c=lt(a);
+ return(tf3(a,tf(b,c),b,c));
+ case C_p: a=NTV,b=NTV;
+ c=lt(b);
+ return(tf3(tf(a,b),c,a,c));
+ case S1: a=NTV,b=NTV,c=NTV,d=NTV;
+ return(tf4(tf2(a,b,c),tf(d,a),tf(d,b),d,c));
+ case B1: a=NTV,b=NTV,c=NTV,d=NTV;
+ return(tf4(tf(a,b),tf(c,a),tf(d,c),d,b));
+ case C1: a=NTV,b=NTV,c=NTV,d=NTV;
+ return(tf4(tf2(a,b,c),tf(d,a),b,d,c));
+ case SEQ: a=NTV,b=NTV;
+ return(tf2(a,b,b));
+ case ITERATE1:
+ case ITERATE: a=NTV;
+ return(tf2(tf(a,a),a,lt(a)));
+ case EXEC: { if(!exec_t)
+ a=ap2(comma_t,ltchar,ap2(comma_t,num_t,void_t)),
+ exec_t=tf(ltchar,ap2(comma_t,ltchar,a));
+ return(exec_t); }
+ case READBIN:
+ case READ: { if(!read_t)
+ read_t=tf(char_t,ltchar);
+ /* $- is ap(READ,0) */
+ return(read_t); }
+ case FILESTAT: { if(!filestat_t)
+ filestat_t=tf(ltchar,pair_t(pair_t(num_t,num_t),num_t));
+ return(filestat_t); }
+ case FILEMODE:
+ case GETENV:
+ case NB_STARTREAD:
+ case STARTREADBIN:
+ case STARTREAD: return(tfstrstr);
+ case GETARGS: return(tf(char_t,lt(ltchar)));
+ case SHOWHEX:
+ case SHOWOCT:
+ case SHOWNUM: return(tf(num_t,ltchar));
+ case SHOWFLOAT:
+ case SHOWSCALED: return(tf2(num_t,num_t,ltchar));
+ case NUMVAL: return(tf(ltchar,num_t));
+ case INTEGER: return(tf(num_t,bool_t));
+ case CODE: return(tf(char_t,num_t));
+ case DECODE: return(tf(num_t,char_t));
+ case LENGTH: return(tf(lt(NTV),num_t));
+ case ENTIER_FN: case ARCTAN_FN: case EXP_FN: case SIN_FN:
+ case COS_FN: case SQRT_FN: case LOG_FN: case LOG10_FN:
+ return(tfnumnum);
+ case MINUS:case PLUS:case TIMES:case INTDIV:case FDIV:
+ case MOD:case POWER: return(tfnum2);
+ case True: case False: return(bool_t);
+ case NIL: a=lt(NTV);
+ return(a);
+ case NILS: return(ltchar);
+ case MKSTRICT: a=NTV;
+ return(tf(char_t,tf(a,a)));
+/* the following are not the true types of the G_fns, which have the action
+ Ai->lt(bnf_t)->(B:lt(bnf_t))
+ here represented by the type Ai->B. G_CLOSE interfaces the parser fns to
+ the outside world */
+ case G_ALT: a=NTV;
+ return(tf2(a,a,a));
+ case G_ERROR: a=NTV;
+ return(tf2(a,tf(lt(bnf_t),a),a));
+ case G_OPT:
+ case G_STAR: a=NTV;
+ return(tf(a,lt(a)));
+ case G_FBSTAR: a=NTV; b=tf(a,a);
+ return(tf(b,b));
+ case G_SYMB: return(tfstrstr);
+ case G_ANY: return(ltchar);
+ case G_SUCHTHAT: return(tf(tf(ltchar,bool_t),ltchar));
+ case G_END: return(lt(bnf_t));
+ case G_STATE: return(tl[hd[tl[bnf_t]]]);
+ case G_SEQ: a=NTV; b=NTV;
+ return(tf2(a,tf(a,b),b));
+ /* G_RULE has same type as I */
+ case G_CLOSE: a=NTV;
+ if(col_fn) /* offside rule used */
+ if(col_fn== -1) /* arbitrary flag */
+ TYPERRS++; /*overkill, see note on checkcolfn*/
+ else checkcolfn();
+ return(tf3(ltchar,a,lt(bnf_t),a));
+ case OFFSIDE: return(ltchar);
+ /* pretend, used by indent, see prelude */
+ case FAIL: /* compiled from last guard on rhs */
+ case CONFERROR:
+ case BADCASE:
+ case UNDEF: return(NTV);
+ case ERROR: return(tf(ltchar,NTV));
+ default: printf("do not know type of ");
+ out(stdout,x);
+ putchar('\n');
+ return(wrong_t);
+ }
+ default: printf("unexpected tag in etype ");
+ out(stdout,tag[x]);
+ putchar('\n');
+ return(wrong_t);
+ }
+}
+
+rhs_here(r)
+word r;
+{ if(tag[r]==LABEL)return(hd[r]);
+ if(tag[r]==TRIES)return(hd[hd[lastlink(tl[r])]]);
+ return(0); /* something wrong */
+} /* efficiency hack, sometimes we set lineptr to rhs, can extract here_info
+ as above when needed */
+
+conforms(p,t,e,ngt) /* returns new environment of local type bindings obtained
+ by conforming pattern p to type t; -1 means failure */
+word p,t,e,ngt;
+{ if(e==-1)return(-1);
+ if(tag[p]==ID&&!isconstructor(p))return(cons(cons(p,t),e));
+ if(hd[p]==CONST)
+ { unify(etype(tl[p],e,ngt),t); return(e); }
+ if(tag[p]==CONS)
+ { word at=NTV;
+ if(!unify(lt(at),t))return(-1);
+ return(conforms(tl[p],t,conforms(hd[p],at,e,ngt),ngt)); }
+ if(tag[p]==TCONS)
+ { word at=NTV,bt=NTV;
+ if(!unify(ap2(comma_t,at,bt),t))return(-1);
+ return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); }
+ if(tag[p]==PAIR)
+ { word at=NTV,bt=NTV;
+ if(!unify(ap2(comma_t,at,ap2(comma_t,bt,void_t)),t))return(-1);
+ return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); }
+ if(tag[p]==AP&&tag[hd[p]]==AP&&hd[hd[p]]==PLUS) /* n+k pattern */
+ { if(!unify(num_t,t))return(1);
+ return(conforms(tl[p],num_t,e,ngt)); }
+{ word p_args=NIL,pt;
+ while(tag[p]==AP)p_args=cons(tl[p],p_args),p=hd[p];
+ if(!isconstructor(p))
+ { type_error4(p); return(-1); }
+ if(id_type(p)==undef_t)
+ { type_error5(p); return(-1); }
+ pt= /*instantiate(id_type(p)); */
+ instantiate(ATNAMES?rep_t(id_type(p),ATNAMES):id_type(p));
+ while(p_args!=NIL&&isarrow_t(pt))
+ { e=conforms(hd[p_args],tl[hd[pt]],e,ngt),pt=tl[pt],p_args=tl[p_args];
+ if(e==-1)return(-1); }
+ if(p_args!=NIL||isarrow_t(pt)){ type_error3(p); return(-1); }
+ if(!unify(pt,t))return(-1);
+ return(e);
+}}
+
+locate(s) /* for locating type errors */
+char *s;
+{ TYPERRS++;
+ if(TYPERRS==1||lastloc!=current_id) /* avoid tedious repetition */
+ if(current_id)
+ if(tag[current_id]==DATAPAIR) /* see checkfbs */
+ { locate_inc();
+ printf("%s in binding for %s\n",s,(char *)hd[current_id]);
+ return; }
+ else
+ { extern word fnts;
+ word x=current_id;
+ printf("%s in definition of ",s);
+ while(tag[x]==CONS)
+ if(tag[tl[x]]==ID&&member(fnts,tl[x]))
+ printf("nonterminal "),x=hd[x]; else /*note1*/
+ out_formal1(stdout,hd[x]),printf(", subdef of "),
+ x=tl[x];
+ printf("%s",get_id(x));
+ putchar('\n'); }
+ else printf("%s in expression\n",s);
+ if(lineptr)sayhere(lineptr,0); else
+ if(current_id&&id_who(current_id)!=NIL)sayhere(id_who(current_id),0);
+ lastloc=current_id;
+}
+/* note1: this is hack to suppress extra `subdef of <fst start symb>' when
+ reporting error in defn of non-terminal in %bnf stuff */
+
+sayhere(h,nl) /* h is hereinfo - reports location (in parens, newline if nl)
+ and sets errline/errs if not already set */
+word h,nl;
+{ extern word errs,errline;
+ extern char *current_script;
+ if(tag[h]!=FILEINFO)
+ { h=rhs_here(h);
+ if(tag[h]!=FILEINFO)
+ { fprintf(stderr,"(impossible event in sayhere)\n"); return; }}
+ printf("(line %3d of %s\"%s\")",tl[h],
+ (char *)hd[h]==current_script?"":"%insert file ",(char *)hd[h]);
+ if(nl)putchar('\n'); else putchar(' ');
+ if((char *)hd[h]==current_script)
+ { if(!errline) /* tells editor where first error is */
+ errline=tl[h]; }
+ else { if(!errs)errs=h; }
+}
+
+type_error(a,b,t1,t2)
+char *a,*b;
+word t1,t2;
+{ t1=redtvars(ap(subst(t1),subst(t2)));
+ t2=tl[t1];t1=hd[t1];
+ locate("type error");
+ printf("cannot %s ",a);out_type(t1);
+ printf(" %s ",b);out_type(t2);putchar('\n');
+}
+
+type_error1(x) /* typename in expression */
+word x;
+{ locate("type error");
+ printf("typename used as identifier (%s)\n",get_id(x));
+}
+
+type_error2(x) /* undefined name in expression */
+word x;
+{ if(compiling)return; /* treat as type error only in $+ data */
+ TYPERRS++;
+ printf("undefined name - %s\n",get_id(x));
+}
+
+type_error3(x) /* constructor used at wrong arity in formal */
+word x;
+{ locate("error");
+ printf("constructor \"%s\" used at wrong arity in formal\n", get_id(x));
+}
+
+type_error4(x) /* non-constructor as head of formal */
+word x;
+{ locate("error");
+ printf("illegal object \""); out_pattern(stdout,x);
+ printf("\" as head of formal\n");
+}
+
+type_error5(x) /* undeclared constructor in formal */
+word x;
+{ locate("error");
+ printf("undeclared constructor \""); out_pattern(stdout,x);
+ printf("\" in formal\n");
+ ND=add1(x,ND);
+}
+
+type_error6(x,f,a)
+word x,f,a;
+{ TYPERRS++;
+ printf("incorrect declaration "); sayhere(lineptr,1);
+ printf("specified, %s :: ",get_id(x)); out_type(f); putchar('\n');
+ printf("inferred, %s :: ",get_id(x)); out_type(redtvars(subst(a)));
+ putchar('\n');
+}
+
+type_error7(t,args)
+word t,args;
+{ word i=1;
+ while((args=tl[args])!=NIL)i++;
+ locate("type error");
+ printf(i==1?"1st":i==2?"2nd":i==3?"3rd":"%dth",i);
+ printf(" arg of zip has type :: ");
+ out_type(redtvars(subst(t)));
+ printf("\n - should be list\n");
+}
+
+type_error8(t1,t2)
+word t1,t2;
+{ word big;
+ t1=subst(t1); t2=subst(t2);
+ if(same(hd[t1],hd[t2]))
+ t1=tl[t1],t2=tl[t2]; /* discard `[bnf_t]->' */
+ t1=redtvars(ap(t1,t2));
+ t2=tl[t1];t1=hd[t1];
+ big = size(t1)>=10 || size(t2)>=10;
+ locate("type error");
+ printf("cannot unify%s ",big?"\n ":"");out_type(t1);
+ printf(big?"\nwith\n ":" with ");out_type(t2);putchar('\n');
+}
+
+unify(t1,t2) /* works by side-effecting SUBST, returns 1,0 as it succeeds
+ or fails */
+word t1,t2;
+{ t1=subst(t1),t2=subst(t2);
+ if(t1==t2)return(1);
+ if(isvar_t(t1)&&!occurs(t1,t2))
+ { addsubst(t1,t2); return(1); }
+ if(isvar_t(t2)&&!occurs(t2,t1))
+ { addsubst(t2,t1); return(1); }
+ if(iscompound_t(t1)&&iscompound_t(t2)&&
+ unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2]))return(1);
+ type_error("unify","with",t1,t2);
+ return(0);
+}
+
+unify1(t1,t2) /* inner call - exactly like unify, except error reporting is
+ done only by top level, see above */
+ /* we do this to avoid printing inner parts of types */
+word t1,t2;
+{ t1=subst(t1),t2=subst(t2);
+ if(t1==t2)return(1);
+ if(isvar_t(t1)&&!occurs(t1,t2))
+ { addsubst(t1,t2); return(1); }
+ if(isvar_t(t2)&&!occurs(t2,t1))
+ { addsubst(t2,t1); return(1); }
+ if(iscompound_t(t1)&&iscompound_t(t2))
+ return(unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2]));
+ return(0);
+}
+
+subsumes(t1,t2) /* like unify but lop-sided; returns 1,0 as t2 falls, doesnt
+ fall under t1 */
+word t1,t2;
+{ if(t2==wrong_t)return(1);
+ /* special case, shows up only when compiling prelude (changetype etc) */
+ return(subsu1(t1,t2,t2)); }
+
+subsu1(t1,t2,T2)
+word t1,t2,T2;
+{ t1=subst(t1);
+ if(t1==t2)return(1);
+ if(isvar_t(t1)&&!occurs(t1,T2))
+ { addsubst(t1,t2); return(1); }
+ if(iscompound_t(t1)&&iscompound_t(t2))
+ return(subsu1(hd[t1],hd[t2],T2)&&subsu1(tl[t1],tl[t2],T2));
+ return(0);
+}
+
+walktype(t,f) /* make a copy of t with f applied to its variables */
+word t;
+word (*f)();
+{ if(isvar_t(t))return((*f)(t));
+ if(iscompound_t(t))
+ { word h1=walktype(hd[t],f);
+ word t1=walktype(tl[t],f);
+ return(h1==hd[t]&&t1==tl[t]?t:ap(h1,t1)); }
+ return(t);
+}
+
+occurs(tv,t) /* does tv occur in type t? */
+word tv,t;
+{ while(iscompound_t(t))
+ { if(occurs(tv,tl[t]))return(1);
+ t=hd[t]; }
+ return(tv==t);
+}
+
+ispoly(t) /* does t contain tvars? (should call subst first) */
+word t;
+{ while(iscompound_t(t))
+ { if(ispoly(tl[t]))return(1);
+ t=hd[t]; }
+ return(isvar_t(t));
+}
+
+word SUBST[hashsize]; /* hash table of substitutions */
+
+clear_SUBST()
+/* To save time and space we call this after a type inference to clear out
+ substitutions in extinct variables. Calling this too often can slow you
+ down - whence #define reset_SUBST, see above */
+{ word i;
+ fixshows();
+ for(i=0;i<hashsize;i++)SUBST[i]=0;
+ /*printf("tvcount=%d\n",tvcount); /* probe */
+ tvcount=1;
+ return(0); /* see defn of reset_SUBST */
+}
+/* doubling hashsize from 512 to 1024 speeded typecheck by only 3% on
+ parser.m (=350 line block, used c. 5000 tvars) - may be worth increasing
+ for very large programs however. Guesstimate - further increase from
+ 512 would be worthwhile on blocks>2000 lines */
+
+fixshows()
+{ while(showchain!=NIL)
+ { tl[hd[showchain]]=subst(tl[hd[showchain]]);
+ showchain=tl[showchain]; }
+}
+
+lookup(tv) /* find current substitution for type variable */
+word tv;
+{ word h=SUBST[hashval(tv)];
+ while(h)
+ { if(eqtvar(hd[hd[h]],tv))return(tl[hd[h]]);
+ h=tl[h]; }
+ return(tv); /* no substitution found, so answer is self */
+}
+
+addsubst(tv,t) /* add new substitution to SUBST */
+word tv,t;
+{ word h=hashval(tv);
+ SUBST[h]=cons(cons(tv,t),SUBST[h]);
+}
+
+ult(tv) /* fully substituted out value of a type var */
+word tv;
+{ word s=lookup(tv);
+ return(s==tv?tv:subst(s));
+}
+
+subst(t) /* returns fully substituted out value of type expression */
+word t;
+{ return(walktype(t,ult));
+}
+
+word localtvmap=NIL;
+word NGT=0;
+
+lmap(tv)
+word tv;
+{ word l;
+ if(non_generic(tv))return(tv);
+ for(l=localtvmap;l!=NIL;l=tl[l])
+ if(hd[hd[l]]==tv)return(tl[hd[l]]);
+ localtvmap=cons(cons(tv,l=NTV),localtvmap);
+ return(l);
+}
+
+linst(t,ngt) /* local instantiate */
+word t; /* relevant tvars are those not in ngt */
+{ localtvmap=NIL; NGT=ngt;
+ return(walktype(t,lmap));
+}
+
+non_generic(tv)
+word tv;
+{ word x;
+ for(x=NGT;x!=NIL;x=tl[x])
+ if(occurs(tv,subst(hd[x])))return(1);
+ return(0);
+} /* note that when a non-generic tvar is unified against a texp, all tvars
+ in texp become non-generic; this is catered for by call to subst above
+ (obviating the need for unify to directly side-effect NGT) */
+
+word tvmap=NIL;
+
+mapup(tv)
+word tv;
+{ word *m= &tvmap;
+ tv=gettvar(tv);
+ while(--tv)m= &tl[*m];
+ if(*m==NIL)*m=cons(NTV,NIL);
+ return(hd[*m]);
+}
+
+instantiate(t) /* make a copy of t with a new set of type variables */
+word t; /* t MUST be in reduced form - see redtvars */
+{ tvmap=NIL;
+ return(walktype(t,mapup));
+}
+
+ap_subst(t,args) /* similar, but with a list of substitions for the type
+ variables provided (args). Again, t must be in reduced form */
+word t,args;
+{ word r;
+ tvmap=args;
+ r=walktype(t,mapup);
+ tvmap=NIL; /* ready for next use */
+ return(r);
+}
+
+
+mapdown(tv)
+word tv;
+{ word *m= &tvmap;
+ word i=1;
+ while(*m!=NIL&&!eqtvar(hd[*m],tv))m= &tl[*m],i++;
+ if(*m==NIL)*m=cons(tv,NIL);
+ return(mktvar(i));
+}
+
+redtvars(t) /* renames the variables in t, in order of appearance to walktype,
+ using the numbers 1,2,3... */
+word t;
+{ tvmap=NIL;
+ return(walktype(t,mapdown));
+}
+
+
+remove1(e,ss) /* destructively remove e from set with address ss, returning
+ 1 if e was present, 0 otherwise */
+word e,*ss;
+{ while(*ss!=NIL&&hd[*ss]<e)ss= &tl[*ss]; /* we assume set in address order */
+ if(*ss==NIL||hd[*ss]!=e)return(0);
+ *ss=tl[*ss];
+ return(1);
+}
+
+setdiff(s1,s2) /* destructive on s1, returns set difference */
+word s1,s2; /* both are in ascending address order */
+{ word *ss1= &s1;
+ while(*ss1!=NIL&&s2!=NIL)
+ if(hd[*ss1]==hd[s2])*ss1=tl[*ss1]; else /* removes element */
+ if(hd[*ss1]<hd[s2])ss1= &tl[*ss1];
+ else s2=tl[s2];
+ return(s1);
+}
+
+add1(e,s) /* inserts e destructively into set s, kept in ascending address
+ order */
+word e,s;
+{ word s1=s;
+ if(s==NIL||e<hd[s])return(cons(e,s));
+ if(e==hd[s])return(s); /* no duplicates! */
+ while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1];
+ if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else
+ if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]);
+ return(s);
+}
+
+word NEW; /* nasty hack, see rules */
+
+newadd1(e,s) /* as above, but with side-effect on NEW */
+word e,s;
+{ word s1=s;
+ NEW=1;
+ if(s==NIL||e<hd[s])return(cons(e,s));
+ if(e==hd[s]){ NEW=0; return(s); } /* no duplicates! */
+ while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1];
+ if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else
+ if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]);
+ else NEW=0;
+ return(s);
+}
+
+UNION(s1,s2) /* destructive on s1; s1, s2 both in address order */
+word s1,s2;
+{ word *ss= &s1;
+ while(*ss!=NIL&&s2!=NIL)
+ if(hd[*ss]==hd[s2])ss= &tl[*ss],s2=tl[s2]; else
+ if(hd[*ss]<hd[s2])ss= &tl[*ss];
+ else *ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2];
+ if(*ss==NIL)
+ while(s2!=NIL)*ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2];
+ /* must copy tail of s2, in case of later destructive operations on s1 */
+ return(s1);
+}
+
+intersection(s1,s2) /* s1, s2 and result all in address order */
+word s1,s2;
+{ word r=NIL;
+ while(s1!=NIL&&s2!=NIL)
+ if(hd[s1]==hd[s2])r=cons(hd[s1],r),s1=tl[s1],s2=tl[s2]; else
+ if(hd[s1]<hd[s2])s1=tl[s1];
+ else s2=tl[s2];
+ return(reverse(r));
+}
+
+deps(x) /* returns list of the free identifiers in expression x */
+word x;
+{ word d=NIL;
+L:switch(tag[x])
+{ case AP:
+ case TCONS:
+ case PAIR:
+ case CONS: d=UNION(d,deps(hd[x]));
+ x=tl[x];
+ goto L;
+ case ID: return(isconstructor(x)?d:add1(x,d));
+ case LAMBDA: /* d=UNION(d,patdeps(hd[x]));
+ /* should add this - see sahbug3.m */
+ return(rembvars(UNION(d,deps(tl[x])),hd[x]));
+ case LET: d=rembvars(UNION(d,deps(tl[x])),dlhs(hd[x]));
+ return(UNION(d,deps(dval(hd[x]))));
+ case LETREC: { word y;
+ d=UNION(d,deps(tl[x]));
+ for(y=hd[x];y!=NIL;y=tl[y])
+ d=UNION(d,deps(dval(hd[y])));
+ for(y=hd[x];y!=NIL;y=tl[y])
+ d=rembvars(d,dlhs(hd[y]));
+ return(d); }
+ case LEXER: while(x!=NIL)
+ d=UNION(d,deps(tl[tl[hd[x]]])),
+ x=tl[x];
+ return(d);
+ case TRIES:
+ case LABEL: x=tl[x]; goto L;
+ case SHARE: x=hd[x]; goto L; /* repeated analysis - fix later */
+ default: return(d);
+}}
+
+rembvars(x,p) /* x is list of ids in address order, remove bv's of pattern p
+ (destructive on x) */
+word x,p;
+{ L:
+ switch(tag[p])
+ { case ID: return(remove1(p,&x),x);
+ case CONS: if(hd[p]==CONST)return(x);
+ x=rembvars(x,hd[p]);p=tl[p];goto L;
+ case AP: if(tag[hd[p]]==AP&&hd[hd[p]]==PLUS)
+ p=tl[p]; /* for n+k patterns */
+ else { x=rembvars(x,hd[p]);p=tl[p]; }
+ goto L;
+ case PAIR:
+ case TCONS: x=rembvars(x,hd[p]);p=tl[p];goto L;
+ default: fprintf(stderr, "impossible event in rembvars\n");
+ return(x);
+}}
+
+member(s,x)
+word s,x;
+{ while(s!=NIL&&x!=hd[s])s=tl[s];
+ return(s!=NIL);
+}
+
+printgraph(title,g) /* for debugging info */
+char *title;
+word g;
+{ printf("%s\n",title);
+ while(g!=NIL)
+ { printelement(hd[hd[g]]); putchar(':');
+ printelement(tl[hd[g]]); printf(";\n");
+ g=tl[g]; }
+}
+
+printelement(x)
+word x;
+{ if(tag[x]!=CONS){ out(stdout,x); return; }
+ putchar('(');
+ while(x!=NIL)
+ { out(stdout,hd[x]);
+ x=tl[x];
+ if(x!=NIL)putchar(' '); }
+ putchar(')');
+}
+
+printlist(title,l) /* for debugging */
+char *title;
+word l;
+{ printf("%s",title);
+ while(l!=NIL)
+ { printelement(hd[l]);
+ l=tl[l];
+ if(l!=NIL)putchar(','); }
+ printf(";\n");
+}
+
+printob(title,x) /* for debugging */
+char *title;
+word x;
+{ printf("%s",title); out(stdout,x); putchar('\n');
+ return(x); }
+
+print2obs(title,title2,x,y) /* for debugging */
+char *title,*title2;
+word x,y;
+{ printf("%s",title); out(stdout,x); printf("%s",title2); out(stdout,y); putchar('\n');
+}
+
+word allchars=0; /* flag used by tail */
+
+out_formal1(f,x)
+FILE *f;
+word x;
+{ extern word nill;
+ if(hd[x]==CONST)x=tl[x];
+ if(x==NIL)fprintf(f,"[]"); else
+ if(tag[x]==CONS&&tail(x)==NIL)
+ if(allchars)
+ { fprintf(f,"\"");while(x!=NIL)fprintf(f,"%s",charname(hd[x])),x=tl[x];
+ fprintf(f,"\""); } else
+ { fprintf(f,"[");
+ while(x!=nill&&x!=NIL)
+ { out_pattern(f,hd[x]);
+ x=tl[x];
+ if(x!=nill&&x!=NIL)fprintf(f,","); }
+ fprintf(f,"]"); } else
+ if(tag[x]==AP||tag[x]==CONS)
+ { fprintf(f,"("); out_pattern(f,x);
+ fprintf(f,")"); } else
+ if(tag[x]==TCONS||tag[x]==PAIR)
+ { fprintf(f,"(");
+ while(tag[x]==TCONS)
+ { out_pattern(f,hd[x]);
+ x=tl[x]; fprintf(f,","); }
+ out_pattern(f,hd[x]); fprintf(f,","); out_pattern(f,tl[x]);
+ fprintf(f,")"); } else
+ if(tag[x]==INT&&neg(x)||tag[x]==DOUBLE&&get_dbl(x)<0)
+ { fprintf(f,"("); out(f,x); fprintf(f,")"); } /* -ve numbers */
+ else
+ out(f,x); /* all other cases */
+}
+
+out_pattern(f,x)
+FILE *f;
+word x;
+{ if(tag[x]==CONS)
+ if(hd[x]==CONST&&(tag[tl[x]]==INT||tag[tl[x]]==DOUBLE))out(f,tl[x]); else
+ if(hd[x]!=CONST&&tail(x)!=NIL)
+ { out_formal(f,hd[x]); fprintf(f,":"); out_pattern(f,tl[x]); }
+ else out_formal(f,x);
+ else out_formal(f,x);
+}
+
+out_formal(f,x)
+FILE *f;
+word x;
+{ if(tag[x]!=AP)
+ out_formal1(f,x); else
+ if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
+ { out_formal(f,tl[x]); fprintf(f,"+"); out(f,tl[hd[x]]); }
+ else
+ { out_formal(f,hd[x]); fprintf(f," "); out_formal1(f,tl[x]); }
+}
+
+tail(x)
+word x;
+{ allchars=1;
+ while(tag[x]==CONS)allchars&=(is_char(hd[x])),x=tl[x];
+ return(x);
+}
+
+out_type(t) /* for printing external representation of types */
+word t;
+{ while(isarrow_t(t))
+ { out_type1(tl[hd[t]]);
+ printf("->");
+ t=tl[t]; }
+ out_type1(t);
+}
+
+out_type1(t)
+word t;
+{ if(iscompound_t(t)&&!iscomma_t(t)&&!islist_t(t)&&!isarrow_t(t))
+ { out_type1(hd[t]);
+ putchar(' ');
+ t=tl[t]; }
+ out_type2(t);
+}
+
+out_type2(t)
+word t;
+{ if(islist_t(t))
+ { putchar('[');
+ out_type(tl[t]); /* could be out_typel, but absence of parentheses
+ might be confusing */
+ putchar(']'); }else
+ if(iscompound_t(t))
+ { putchar('(');
+ out_typel(t);
+ if(iscomma_t(t)&&tl[t]==void_t)putchar(',');
+ /* type of a one-tuple -- an anomaly that should never occur */
+ putchar(')'); }else
+ switch(t)
+ {
+ case bool_t: printf("bool"); return;
+ case num_t: printf("num"); return;
+ case char_t: printf("char"); return;
+ case wrong_t: printf("WRONG"); return;
+ case undef_t: printf("UNKNOWN"); return;
+ case void_t: printf("()"); return;
+ case type_t: printf("type"); return;
+ default: if(tag[t]==ID)printf("%s",get_id(t));else
+ if(isvar_t(t))
+ { word n=gettvar(t);
+ /*if(1)printf("t%d",n-1); else /* experiment, suppressed */
+ /*if(n<=26)putchar('a'+n-1); else /* experiment */
+ if(n>0&&n<7)while(n--)putchar('*'); /* 6 stars max */
+ else printf("%d",n); }else
+ if(tag[t]==STRCONS) /* pname - see hack in privatise */
+ { extern char *current_script;
+ if(tag[pn_val(t)]==ID)printf("%s",get_id(pn_val(t))); else
+ /* ?? one level of indirection sometimes present */
+ if(strcmp((char *)hd[tl[t_info(t)]],current_script)==0)
+ printf("%s",(char *)hd[hd[t_info(t)]]); else /* elision */
+ printf("`%s@%s'",
+ (char *)hd[hd[t_info(t)]], /* original typename */
+ (char *)hd[tl[t_info(t)]]); /* sourcefile */ }
+ else printf("<BADLY FORMED TYPE:%d,%d,%d>",tag[t],hd[t],tl[t]);
+ }
+}
+
+out_typel(t)
+word t;
+{ while(iscomma_t(t))
+ { out_type(tl[hd[t]]);
+ t=tl[t];
+ if(iscomma_t(t))putchar(',');
+ else if(t!=void_t)printf("<>"); } /* "tuple-cons", shouldn't occur free */
+ if(t==void_t)return;
+ out_type(t);
+}
+
+/* end of MIRANDA TYPECHECKER */
+
generated by cgit v1.2.1 (git 2.18.0) at 2024-12-23 00:36:55 +0000