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, 0 insertions, 12015 deletions
diff --git a/new/big.c b/new/big.c
deleted file mode 100644
index 7a1cfe1..0000000
--- a/new/big.c
+++ /dev/null
@@ -1,643 +0,0 @@
-/* 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
deleted file mode 100644
index c7463ac..0000000
--- a/new/data.c
+++ /dev/null
@@ -1,1250 +0,0 @@
-/* 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
deleted file mode 100644
index a4e9d09..0000000
--- a/new/lex.c
+++ /dev/null
@@ -1,1213 +0,0 @@
-/* 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
deleted file mode 100644
index 04f7267..0000000
--- a/new/reduce.c
+++ /dev/null
@@ -1,2376 +0,0 @@
-/* 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
deleted file mode 100644
index e44698b..0000000
--- a/new/rules.y
+++ /dev/null
@@ -1,1686 +0,0 @@
-/* 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
deleted file mode 100644
index 27c238d..0000000
--- a/new/steer.c
+++ /dev/null
@@ -1,2208 +0,0 @@
-/* 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
deleted file mode 100644
index e50eb8a..0000000
--- a/new/trans.c
+++ /dev/null
@@ -1,1026 +0,0 @@
-/* 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
deleted file mode 100644
index f20627f..0000000
--- a/new/types.c
+++ /dev/null
@@ -1,1613 +0,0 @@
-/* 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 01:36:31 +0000