diff options
| author | Jakob Kaivo <jkk@ung.org> | 2022-03-04 12:32:20 -0500 |
|---|---|---|
| committer | Jakob Kaivo <jkk@ung.org> | 2022-03-04 12:32:20 -0500 |
| commit | 55f277e77428d7423ae906a8e1f1324d35b07a7d (patch) | |
| tree | 5c1c04703dff89c46b349025d2d3ec88ea9b3819 | |
import Miranda 2.066 from upstream
156 files changed, 37635 insertions, 0 deletions
@@ -0,0 +1 @@ +2020.01.31 @@ -0,0 +1 @@ +1580476718 @@ -0,0 +1,2 @@ +host: x86_64 Linux 5.10.0-11-amd64 +gcc version 10.2.1 20210110 (Debian 10.2.1-6) diff --git a/.nextxversion b/.nextxversion new file mode 100755 index 0000000..d3bdf13 --- /dev/null +++ b/.nextxversion @@ -0,0 +1,5 @@ +#!/bin/sh +set `cat .xversion` +echo $1 $2 `expr $3 + 1` > .xversion +cat .xversion +#running this makes existing .x files obsolete diff --git a/.version b/.version new file mode 120000 index 0000000..a9eca26 --- /dev/null +++ b/.version @@ -0,0 +1 @@ +miralib/.version
\ No newline at end of file diff --git a/.xversion b/.xversion new file mode 100644 index 0000000..a69c581 --- /dev/null +++ b/.xversion @@ -0,0 +1 @@ +#define XVERSION 83 @@ -0,0 +1 @@ +miralib/COPYING
\ No newline at end of file diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e23cefd --- /dev/null +++ b/Makefile @@ -0,0 +1,77 @@ +all: mira miralib/menudriver exfiles +#install paths relative to / +#for linux, MacOS X, Cygwin: +BIN=usr/bin +LIB=usr/lib#beware no spaces after LIB +MAN=usr/share/man/man1 +#for Solaris: +#BIN=usr/local/bin +#LIB=usr/local/lib#beware no spaces after LIB +#MAN=usr/local/man/man1 +CC = gcc -w +CFLAGS = #-O #-DCYGWIN #-DUWIN #-DIBMRISC #-Dsparc7 #-Dsparc8 +#be wary of using anything higher than -O as the garbage collector may fall over +#if using gcc rather than clang try without -O first +EX = #.exe #needed for CYGWIN, UWIN +YACC = byacc #Berkeley yacc, gnu yacc not compatible +# -Dsparc7 needed for Solaris 2.7 +# -Dsparc8 needed for Solaris 2.8 or later +mira: big.o cmbnms.o data.o lex.o reduce.o steer.o trans.o types.o utf8.o y.tab.o \ + version.c miralib/.version fdate .host Makefile + $(CC) $(CFLAGS) -DVERS=`cat miralib/.version` -DVDATE="\"`./revdate`\"" \ + -DHOST="`./quotehostinfo`" version.c cmbnms.o y.tab.o data.o lex.o \ + big.o reduce.o steer.o trans.o types.o utf8.o -lm -o mira + strip mira$(EX) +y.tab.c y.tab.h: rules.y + $(YACC) -d rules.y +big.o cmbns.o data.o lex.o reduce.o steer.o trans.o types.o y.tab.o: \ + data.h combs.h utf8.h y.tab.h Makefile +data.o: .xversion +big.o data.o lex.o reduce.o steer.o trans.o types.o: big.h +big.o data.o lex.o reduce.o steer.o rules.y types.o: lex.h +utf8.o: utf8.h Makefile +cmbnms.o: cmbnms.c Makefile +cmbnms.c combs.h: gencdecs + ./gencdecs +miralib/menudriver: menudriver.c Makefile + $(CC) $(CFLAGS) menudriver.c -o miralib/menudriver + chmod 755 miralib/menudriver$(EX) + strip miralib/menudriver$(EX) +#alternative: use shell script +# ln -s miralib/menudriver.sh miralib/menudriver +tellcc: + @echo $(CC) $(CFLAGS) +cleanup: +#to be done on moving to a new host + -rm -rf *.o fdate miralib/menudriver mira$(EX) + ./unprotect + -rm -f miralib/preludx miralib/stdenv.x miralib/ex/*.x #miralib/ex/*/*.x + ./hostinfo > .host +install: + make -s all + cp mira$(EX) /$(BIN) + cp mira.1 /$(MAN) + rm -rf /$(LIB)/miralib + ./protect + cp -pPR miralib /$(LIB)/miralib + ./unprotect + find /$(LIB)/miralib -exec chown `./ugroot` {} \; +release: + make -s all + -rm -rf usr + mkdir -p $(BIN) $(LIB) $(MAN) + cp mira$(EX) $(BIN) + cp mira.1 $(MAN) + ./protect + cp -pPR miralib $(LIB)/miralib + ./unprotect + find usr -exec chown `./ugroot` {} \; + tar czf `rname`.tgz ./usr + -rm -rf usr +SOURCES = .xversion big.c big.h gencdecs data.h data.c lex.h lex.c reduce.c rules.y \ + steer.c trans.c types.c utf8.h utf8.c version.c fdate.c +sources: $(SOURCES); @echo $(SOURCES) +exfiles: + @-./mira -make -lib miralib ex/*.m +mira.1.html: mira.1 Makefile + man2html mira.1 | sed '/Return to Main/d' > mira.1.html @@ -0,0 +1,90 @@ +This directory contains everything you should need to create a working +version of the Miranda system. Before compiling Miranda on a new host: + make cleanup +removes old object files and collects information about the current +platform in .host. + +Then + make +should recreate a working version of Miranda, in this directory. To try +it out say `./mira'. (See below for what to do if things go wrong.) +Before doing the `make' you might want to inspect the first few lines of +Makefile which sets the options to cc and a few other things that might +need adjusting. + +There is a selection of example Miranda scripts in the directory `ex'. +For stress testing the garbage collector try ./mira ex/parafs.m (say +output). Note that in a mira session /e opens the editor (default vi) +on the current script. + +Other makefile targets supported are (need to be executed as root):- + make install +copies the mira executables and associated files (miralib, mira.1) to +the appropriate places in the root filing system, so they can be +accessed by all users; and + make release +creates a gzipped tar image of the binaries suitable for installing +Miranda on other machines of the same object code type. To use the tar +image on another machine, be root, and say + cd / + tar xzpf [pathname] +where [pathname] is the gzipped tarfile. + +Before `make install' or `make release' you should inspect paths BIN, +LIB, MAN at the top of the Makefile and modify if needed, to put things +at the places in the root filing system where you want them to go. + +Be aware that the garbage collector works by scanning the C stack to +find anything that is or seems to be a pointer into the heap (see +bases() in data.c) and is therefore somewhat fragile as it can be foxed +by aggressive compiler optimisations. GC errors manifest as "impossible +event" messages, or segmentation faults. If these appear try +recompiling at a lower level of optimisation (e.g. without -O) or with +a different C compiler - e.g. clang instead of gcc or vice versa. + +------------------------------------------------------------------------ + +What to do if things need changing +---------------------------------- + +It is possible that everything will work first time, just on saying +`make'. If however you are obliged to make changes for the new host +(the XYZ machine say) it best to proceed as follows. + +The second line of the Makefile defines some CFLAGS (used by cc) as +delivered most of these are commented out, leaving -O as the only flag. +Add a flag + -DXYZ +to the CFLAGS line. Then at each place in a source file where you have +to change something, do it in the following style + + #ifdef XYZ + your modified code + #else + the original code + #endif + +You will see that this method has been used to cater for certain machine +dependencies at a few places in the sources. Looking to see where this +has already been done is likely to give you an idea as to which lines +may need modifying for your machine. + +If you are running under System 5 UNIX you may include -DSYSTEM5 in the +CFLAGS line of the Makefile, as a couple of system 5 dependencies are +#ifdef'd in the sources (relate to signal(), unclear if they are still +needed). + +One other place where platform dependency is possible is in twidth() +near bottom of file steer.c, which uses an ioctl() call to find width of +current window. This feature isn't critical, however, just aesthetic. + +The sources have no documentation other than embedded comments: you have +to figure out how things work from these and the Makefile. + +Reports of problems encountered, changes needed, etc to mira-bugs (at) +miranda.org.uk + Thanks! + +David Turner +University of Kent +13.01.2020 diff --git a/allexterns b/allexterns new file mode 100644 index 0000000..fd98f01 --- /dev/null +++ b/allexterns @@ -0,0 +1,143 @@ +/* extern declarations from .c files, grouped by type 10.1.2020 */ +extern char **ARGV,*current_script,*dic,*dicp,*dicp,*dicq,linebuf[],*miralib,*obsuffix,*vdate,*vdate,*host,*yysterm[],*cmbnms[]; +extern FILE *s_in,*s_out; +extern int ARGC,atcount,atgc,atobject,blankerr,collecting,debug,ideep,loading,lfrule,UTF8,UTF8OUT,yychar; +extern long claims,nogcs; +extern long long cellcount; +extern void obey(word); +extern word algshfns, + ALIASES, + ATNAMES, + BAD_DUMP, + bereaved, + big_one, + bnf_t, + c, + CLASHES, + col_fn, + commandmode, + common_stdin, + common_stdinb, + concat, + cook_stdin, + count_fn, + *cstack, + current_id, + detrop, + DETROP, + diagonalise, + DICSPACE, + *dstack, + echoing, + embargoes, + eprodnts, + errline, + errs, + exec_t, + exportfiles, + exports, + FBS, + fileq, + filestat_t, + fnts, + freeids, + from_fn, + gvars, + idsused, + ihlist, + inbnf, + includees, + indent_fn, + inexplist, + initialising, + inlex, + internals, + k_i, + lastid, + lastname, + ld_stuff, + lexdefs, + lexstates, + lexvar, + line_no, + lineptr, + linostack, + listdiff_fn, + listing, + litstack, + localtvmap, + ltchar, + magic, + make_status, + making, + margstack, + message, + meta_pending, + MISSING, + namebucket[], + ND, + NEW, + newtyps, + nextpn, + nill, + nolib, + nonterminals, + NT, + ntmap, + ntspecmap, + oldfiles, + outdent_fn, + outfilq, + *pnvec, + prefixstack, + primenv, + R, + read_t, + rfl, + rv_expr, + rv_script, + SBND, + SGC, + showabstract, + showbool, + showchain, + showchar, + showfunction, + showlist, + shownum1, + showpair, + showparen, + showstring, + showvoid, + showwhat, + sourcemc, + SPACELIMIT, + speclocs, + sreds, + *stackp, + standardout, + strictif, + SUBST[], + SUPPRESSED, + suppressids, + SYNERR, + TABSTRS, + tfbool, + tfbool2, + tfnum, + tfnum2, + tfnumnum, + tfstrstr, + tlost, + TORPHANS, + tstep, + tstepuntil, + TSUPPRESSED, + tvmap, + TYPERRS, + verbosity, + vergstack, + version, + Void, + waiting; +extern YYSTYPE yyval,*yyvs,*yyvsp; @@ -0,0 +1,656 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "lex.h" +#include "big.h" +#include <errno.h> + +static double logIBASE,log10IBASE; +word big_one; + +static word big_plus(word,word,int); +static word big_sub(word,word); +static word len(word); +static word longdiv(word,word); +static word ms2d(word); +static word msd(word); +static word shift(word,word); +static word shortdiv(word,word); +static word stimes(word,word); + +void bigsetup() +{ logIBASE=log((double)IBASE); + log10IBASE=log10((double)IBASE); + big_one=make(INT,1,0); +} + +int isnat(x) +word x; +{ return(tag[x]==INT&&poz(x)); +} + +word sto_int(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_int(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; int 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); +} + +int 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 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; int 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 int 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,"%ld",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,"%.5lo",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 */ + @@ -0,0 +1,62 @@ +/* DEFINITIONS FOR MIRANDA INTEGER PACKAGE (variable length) */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#define SIGNBIT 020000000000 + /* most significant bit of 32 bit word */ +#define IBASE 0100000 + /* 2^15 (ie 8^5) so digit is a positive short */ +#define MAXDIGIT 077777 +#define DIGITWIDTH 15 +#define digit0(x) (hd[x]&MAXDIGIT) +#define digit(x) hd[x] +#define rest(x) tl[x] +#define poz(x) (!(hd[x]&SIGNBIT)) +#define neg(x) (hd[x]&SIGNBIT) +#define bigzero(x) (!digit(x)&&!rest(x)) +#define getsmallint(x) (hd[x]&SIGNBIT?-digit0(x):digit(x)) +#define stosmallint(x) make(INT,(x)<0?SIGNBIT|(-(x)):(x),0) +long long get_int(word); +word sto_int(long long); +double bigtodbl(word); +long double bigtoldbl(word); /* not currently used */ +double biglog(word); +double biglog10(word); +int bigcmp(word,word); +word bigdiv(word,word); +word bigmod(word,word); +word bignegate(word); +word bigoscan(char *,char *); +word bigplus(word,word); +word bigpow(word,word); +word bigscan(char *); +void bigsetup(void); +word bigsub(word,word); +word bigtimes(word,word); +word bigtostr(word); +word bigtostr8(word); +word bigtostrx(word); +word bigxscan(char *,char *); +word dbltobig(double); +int isnat(word); +word strtobig(word,int); +#define force_dbl(x) (tag[x]==INT?bigtodbl(x):get_dbl(x)) +#define PTEN 10000 + /* largest power of ten < IBASE (used by bigscan) */ +#define PSIXTEEN 4096 + /* largest power of sixteen <= IBASE (used by bigtostr) */ +#define PEIGHT 0100000 + /* (=32768) largest power of eight <= IBASE (used by bigtostr) */ +#define TENW 4 + /* number of factors of 10 in PTEN */ +#define OCTW 5 + /* number of factors of 8 in IBASE */ + +/* END OF DEFINITIONS FOR INTEGER PACKAGE */ + diff --git a/cmbnms.c b/cmbnms.c new file mode 100644 index 0000000..fdfef1f --- /dev/null +++ b/cmbnms.c @@ -0,0 +1,144 @@ +/* file created by gencdecs - do not edit manually */ +char *cmbnms[] = { +"S", +"K", +"Y", +"C", +"B", +"CB", +"I", +"HD", +"TL", +"BODY", +"LAST", +"S_p", +"U", +"Uf", +"U_", +"Ug", +"COND", +"EQ", +"NEQ", +"NEG", +"AND", +"OR", +"NOT", +"APPEND", +"STEP", +"STEPUNTIL", +"GENSEQ", +"MAP", +"ZIP", +"TAKE", +"DROP", +"FLATMAP", +"FILTER", +"FOLDL", +"MERGE", +"FOLDL1", +"LIST_LAST", +"FOLDR", +"MATCH", +"MATCHINT", +"TRY", +"SUBSCRIPT", +"ATLEAST", +"P", +"B_p", +"C_p", +"S1", +"B1", +"C1", +"ITERATE", +"ITERATE1", +"SEQ", +"FORCE", +"MINUS", +"PLUS", +"TIMES", +"INTDIV", +"FDIV", +"MOD", +"GR", +"GRE", +"POWER", +"CODE", +"DECODE", +"LENGTH", +"ARCTAN_FN", +"EXP_FN", +"ENTIER_FN", +"LOG_FN", +"LOG10_FN", +"SIN_FN", +"COS_FN", +"SQRT_FN", +"FILEMODE", +"FILESTAT", +"GETENV", +"EXEC", +"WAIT", +"INTEGER", +"SHOWNUM", +"SHOWHEX", +"SHOWOCT", +"SHOWSCALED", +"SHOWFLOAT", +"NUMVAL", +"STARTREAD", +"STARTREADBIN", +"NB_STARTREAD", +"READVALS", +"NB_READ", +"READ", +"READBIN", +"GETARGS", +"Ush", +"Ush1", +"KI", +"G_ERROR", +"G_ALT", +"G_OPT", +"G_STAR", +"G_FBSTAR", +"G_SYMB", +"G_ANY", +"G_SUCHTHAT", +"G_END", +"G_STATE", +"G_SEQ", +"G_RULE", +"G_UNIT", +"G_ZERO", +"G_CLOSE", +"G_COUNT", +"LEX_RPT", +"LEX_RPT1", +"LEX_TRY", +"LEX_TRY_", +"LEX_TRY1", +"LEX_TRY1_", +"DESTREV", +"LEX_COUNT", +"LEX_COUNT0", +"LEX_FAIL", +"LEX_STRING", +"LEX_CLASS", +"LEX_CHAR", +"LEX_DOT", +"LEX_SEQ", +"LEX_OR", +"LEX_RCONTEXT", +"LEX_STAR", +"LEX_OPT", +"MKSTRICT", +"BADCASE", +"CONFERROR", +"ERROR", +"FAIL", +"False", +"True", +"NIL", +"NILS", +"UNDEF", +0}; @@ -0,0 +1,143 @@ +/* file created by gencdecs - do not edit manually */ +#define S (CMBASE+0) +#define K (CMBASE+1) +#define Y (CMBASE+2) +#define C (CMBASE+3) +#define B (CMBASE+4) +#define CB (CMBASE+5) +#define I (CMBASE+6) +#define HD (CMBASE+7) +#define TL (CMBASE+8) +#define BODY (CMBASE+9) +#define LAST (CMBASE+10) +#define S_p (CMBASE+11) +#define U (CMBASE+12) +#define Uf (CMBASE+13) +#define U_ (CMBASE+14) +#define Ug (CMBASE+15) +#define COND (CMBASE+16) +#define EQ (CMBASE+17) +#define NEQ (CMBASE+18) +#define NEG (CMBASE+19) +#define AND (CMBASE+20) +#define OR (CMBASE+21) +#define NOT (CMBASE+22) +#define APPEND (CMBASE+23) +#define STEP (CMBASE+24) +#define STEPUNTIL (CMBASE+25) +#define GENSEQ (CMBASE+26) +#define MAP (CMBASE+27) +#define ZIP (CMBASE+28) +#define TAKE (CMBASE+29) +#define DROP (CMBASE+30) +#define FLATMAP (CMBASE+31) +#define FILTER (CMBASE+32) +#define FOLDL (CMBASE+33) +#define MERGE (CMBASE+34) +#define FOLDL1 (CMBASE+35) +#define LIST_LAST (CMBASE+36) +#define FOLDR (CMBASE+37) +#define MATCH (CMBASE+38) +#define MATCHINT (CMBASE+39) +#define TRY (CMBASE+40) +#define SUBSCRIPT (CMBASE+41) +#define ATLEAST (CMBASE+42) +#define P (CMBASE+43) +#define B_p (CMBASE+44) +#define C_p (CMBASE+45) +#define S1 (CMBASE+46) +#define B1 (CMBASE+47) +#define C1 (CMBASE+48) +#define ITERATE (CMBASE+49) +#define ITERATE1 (CMBASE+50) +#define SEQ (CMBASE+51) +#define FORCE (CMBASE+52) +#define MINUS (CMBASE+53) +#define PLUS (CMBASE+54) +#define TIMES (CMBASE+55) +#define INTDIV (CMBASE+56) +#define FDIV (CMBASE+57) +#define MOD (CMBASE+58) +#define GR (CMBASE+59) +#define GRE (CMBASE+60) +#define POWER (CMBASE+61) +#define CODE (CMBASE+62) +#define DECODE (CMBASE+63) +#define LENGTH (CMBASE+64) +#define ARCTAN_FN (CMBASE+65) +#define EXP_FN (CMBASE+66) +#define ENTIER_FN (CMBASE+67) +#define LOG_FN (CMBASE+68) +#define LOG10_FN (CMBASE+69) +#define SIN_FN (CMBASE+70) +#define COS_FN (CMBASE+71) +#define SQRT_FN (CMBASE+72) +#define FILEMODE (CMBASE+73) +#define FILESTAT (CMBASE+74) +#define GETENV (CMBASE+75) +#define EXEC (CMBASE+76) +#define WAIT (CMBASE+77) +#define INTEGER (CMBASE+78) +#define SHOWNUM (CMBASE+79) +#define SHOWHEX (CMBASE+80) +#define SHOWOCT (CMBASE+81) +#define SHOWSCALED (CMBASE+82) +#define SHOWFLOAT (CMBASE+83) +#define NUMVAL (CMBASE+84) +#define STARTREAD (CMBASE+85) +#define STARTREADBIN (CMBASE+86) +#define NB_STARTREAD (CMBASE+87) +#define READVALS (CMBASE+88) +#define NB_READ (CMBASE+89) +#define READ (CMBASE+90) +#define READBIN (CMBASE+91) +#define GETARGS (CMBASE+92) +#define Ush (CMBASE+93) +#define Ush1 (CMBASE+94) +#define KI (CMBASE+95) +#define G_ERROR (CMBASE+96) +#define G_ALT (CMBASE+97) +#define G_OPT (CMBASE+98) +#define G_STAR (CMBASE+99) +#define G_FBSTAR (CMBASE+100) +#define G_SYMB (CMBASE+101) +#define G_ANY (CMBASE+102) +#define G_SUCHTHAT (CMBASE+103) +#define G_END (CMBASE+104) +#define G_STATE (CMBASE+105) +#define G_SEQ (CMBASE+106) +#define G_RULE (CMBASE+107) +#define G_UNIT (CMBASE+108) +#define G_ZERO (CMBASE+109) +#define G_CLOSE (CMBASE+110) +#define G_COUNT (CMBASE+111) +#define LEX_RPT (CMBASE+112) +#define LEX_RPT1 (CMBASE+113) +#define LEX_TRY (CMBASE+114) +#define LEX_TRY_ (CMBASE+115) +#define LEX_TRY1 (CMBASE+116) +#define LEX_TRY1_ (CMBASE+117) +#define DESTREV (CMBASE+118) +#define LEX_COUNT (CMBASE+119) +#define LEX_COUNT0 (CMBASE+120) +#define LEX_FAIL (CMBASE+121) +#define LEX_STRING (CMBASE+122) +#define LEX_CLASS (CMBASE+123) +#define LEX_CHAR (CMBASE+124) +#define LEX_DOT (CMBASE+125) +#define LEX_SEQ (CMBASE+126) +#define LEX_OR (CMBASE+127) +#define LEX_RCONTEXT (CMBASE+128) +#define LEX_STAR (CMBASE+129) +#define LEX_OPT (CMBASE+130) +#define MKSTRICT (CMBASE+131) +#define BADCASE (CMBASE+132) +#define CONFERROR (CMBASE+133) +#define ERROR (CMBASE+134) +#define FAIL (CMBASE+135) +#define False (CMBASE+136) +#define True (CMBASE+137) +#define NIL (CMBASE+138) +#define NILS (CMBASE+139) +#define UNDEF (CMBASE+140) +#define ATOMLIMIT (CMBASE+141) @@ -0,0 +1,1315 @@ +/* MIRANDA DATA REPRESENTATIONS */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +#include "lex.h" +#define INITSPACE 1250000 +word SPACE=INITSPACE; /* false ceiling in heap to improve paging behaviour + during compilation */ +extern word SPACELIMIT; /* see steer.c for default value */ + /* SPACELIMIT controls the size of the heap (i.e. the number of list + cells available) - the minimum survivable number given the need to + compile the prelude etc is probably about 6000 */ + /* Note: the size of a list cell is 2 ints + 1 char */ +#define BIGTOP (SPACELIMIT + ATOMLIMIT) +word listp=ATOMLIMIT-1; +word *hdspace,*tlspace; +long long cellcount=0; +long claims=0; +long nogcs=0; +extern int atgc,loading; /* flags, set in steer.c */ + +word *dstack=0,*stackp,*dlim; +/* stackp=dstack; /* if load_script made interruptible, add to reset */ + +#define poschar(c) !(negchar((c)-1)) +#define negchar(c) (c&128) + /* safest to test for -ve chars this way, since not all m/c's do sign + extension - DT Jan 84 */ + +static void bases(void); +static void bindparams(word,word); +static void dsetup(void); +static void dump_defs(word,FILE *); +static void dump_ob(word,FILE *); +static word hdsort(word); +static word load_defs(FILE *); +static void mark(word); +static void unscramble(word); + +word trueheapsize() +{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); } + +void setupheap() +{ hdspace=(word *)malloc(SPACELIMIT*sizeof(word)); + tlspace=(word *)malloc(SPACELIMIT*sizeof(word)); + hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT; + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + tag=(char *)calloc(BIGTOP+1,sizeof(char)); + /* NB use calloc because it sets contents to zero */ + /* tag[TOP] must be zero and exists as a sentinel */ + if(hdspace==NULL||tlspace==NULL||tag==NULL)mallocfail("heap"); +} + +void resetheap() /* warning - cannot do this dynamically, because both the + compiler and the reducer hold onto absolute heap addresses + during certain space consuming computations */ +{ if(SPACELIMIT<trueheapsize()) + fprintf(stderr,"impossible event in resetheap\n"),exit(1); + hdspace=(word *)realloc((char *)hdspace,SPACELIMIT*sizeof(word)); + if(hdspace==NULL)mallocfail("heap"); + tlspace=(word *)realloc((char *)tlspace,SPACELIMIT*sizeof(word)); + if(tlspace==NULL)mallocfail("heap"); + hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT; + tag=(char *)realloc(tag,BIGTOP+1); + if(tag==NULL)mallocfail("heap"); + tag[BIGTOP]=0; + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + if(SPACE<INITSPACE&&INITSPACE<=SPACELIMIT)SPACE=INITSPACE,tag[TOP]=0; + /* tag[TOP] is always zero and exists as a sentinel */ +} + +void mallocfail(x) +char *x; +{ fprintf(stderr,"panic: cannot find enough free space for %s\n",x); + exit(1); +} + +void resetgcstats() +{ cellcount= -claims; + nogcs = 0; + initclock(); +} + +word make(t,x,y) /* creates a new cell with "tag" t, "hd" x and "tl" y */ +unsigned char t; word x,y; +{ while(poschar(tag[++listp])); + /* find next cell with zero or negative tag (=unwanted) */ + if(listp==TOP) + { if(SPACE!=SPACELIMIT) + if(!compiling)SPACE=SPACELIMIT; else + if(claims<=SPACE/4&&nogcs>1) + { /* during compilation we raise false ceiling whenever residency + reaches 75% on 2 successive gc's */ + static word wait=0; + word sp=SPACE; + if(wait)wait--; else + SPACE+= SPACE/2,wait=2, + SPACE=5000*(1+(SPACE-1)/5000); /* round upwards */ + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + if(atgc&&SPACE>sp) + printf( "\n<<increase heap from %ld to %ld>>\n",sp,SPACE); + } + if(listp==TOP) + { +#if defined ORION105 + asm("savew6"); + gc(); + asm("restw6"); +#elif defined sparc + asm("ta 0x03"); /* see /usr/include/sun4/trap.h */ + /* asm("ta ST_FLUSH_WINDOWS"); */ + gc(); +#else + gc(); +#endif + if(t>STRCONS)mark(x); + if(t>=INT)mark(y); + return(make(t,x,y)); } + } + claims++; + tag[listp]= t; + hd[listp]= x; + tl[listp]= y; + return(listp); } + +/* cons ap ap2 ap3 are all #defined in terms of make + - see MIRANDA DECLARATIONS */ + +void setwd(x,a,b) +word x,a,b; +{ hd[x]= a; + tl[x]= b; } + +int collecting=0; /* flag for reset(), in case interrupt strikes in gc */ + +void gc() /* the "garbage collector" */ +{ char *p1; + extern word making; + collecting=1; + p1= &(tag[ATOMLIMIT]); + if(atgc) + printf("\n<<gc after %ld claims>>\n",claims); + if(claims<=SPACE/10 && nogcs>1 && SPACE==SPACELIMIT) + { /* if heap utilisation exceeds 90% on 2 successive gc's, give up */ + static word hnogcs=0; + if(nogcs==hnogcs) + { extern int ideep; + extern char *current_script; + fprintf(stderr,"<<not enough heap space -- task abandoned>>\n"); + if(!compiling)outstats(); + if(compiling&&ideep==0) + fprintf(stderr,"not enough heap to compile current script\n"), + fprintf(stderr,"script = \"%s\", heap = %ld\n",current_script,SPACE); + exit(1); } /* if compiling should reset() instead - FIX LATER */ + else hnogcs=nogcs+1; } + nogcs++; + while(*p1= -*p1)p1++; /* make all tags -ve (= unwanted) */ + bases(); +/*if(atgc)printf("bases() done\n"); /* DEBUG */ + listp= ATOMLIMIT - 1; + cellcount+= claims; + claims= 0; + collecting=0; +} +/* int Icount; /* DEBUG */ + +void gcpatch() /* called when gc interrupted - see reset in steer.c */ +/* must not allocate any cells between calling this and next gc() */ +{ char *p1; + for(p1= &(tag[ATOMLIMIT]);*p1;p1++)if(negchar(*p1))*p1= -*p1; + /* otherwise mutator crashes on funny tags */ +} + +void bases() /* marks everthing that must be saved */ +{ word *p; + extern YYSTYPE yyval; + extern word *cstack; + extern word fileq,primenv; + extern word cook_stdin,common_stdin,common_stdinb,rv_expr,rv_script; + extern word margstack,vergstack,litstack,linostack,prefixstack; + extern word idsused,suppressids,lastname, + eprodnts,nonterminals,ntmap,ihlist,ntspecmap,gvars,lexvar; + extern word R,TABSTRS,SGC,ND,SBND,NT,current_id,meta_pending; + extern word showchain,newtyps,algshfns,errs,speclocs; + extern word SUBST[],tvmap,localtvmap; + extern word tfnum,tfbool,tfbool2,tfnum2,tfstrstr, + tfnumnum,ltchar,bnf_t,tstep,tstepuntil; + extern word exec_t,read_t,filestat_t; + extern word big_one; + extern word nill,standardout; + extern word lexstates,lexdefs,oldfiles,includees,embargoes,exportfiles, + exports,internals, freeids,tlost,detrop,rfl,bereaved,ld_stuff; + extern word CLASHES,ALIASES,SUPPRESSED,TSUPPRESSED,DETROP,MISSING,fnts,FBS; + extern word outfilq,waiting; + /* Icount=0; /* DEBUG */ + p= (word *)&p; +/* we follow everything on the C stack that looks like a pointer into +list space. This is failsafe in that the worst that can happen,if e.g. a +stray integer happens to point into list space, is that the garbage +collector will collect less garbage than it could have done */ + if(p<cstack) /* which way does stack grow? */ + while(++p!=cstack)mark(*p);/* for machines with stack growing downwards */ + else + while(--p!=cstack)mark(*p);/* for machines with stack growing upwards */ + mark(*cstack); +/* now follow all pointer-containing external variables */ + mark(outfilq); + mark(waiting); + if(compiling||rv_expr||rv_script) /* rv flags indicate `readvals' in use */ + { extern YYSTYPE *yyvs, *yyvsp; + extern word namebucket[]; + extern word *pnvec,nextpn; /* private name vector */ + extern word make_status; + word i; + mark(make_status); + mark(primenv); + mark(fileq); + mark(idsused); + mark(eprodnts); + mark(nonterminals); + mark(ntmap); + mark(ihlist); + mark(ntspecmap); + mark(gvars); + mark(lexvar); + mark(common_stdin); + mark(common_stdinb); + mark(cook_stdin); + mark(margstack); + mark(vergstack); + mark(litstack); + mark(linostack); + mark(prefixstack); + mark(files); + mark(oldfiles); + mark(includees); + mark(freeids); + mark(exports); + mark(internals); + mark(CLASHES); + mark(ALIASES); + mark(SUPPRESSED); + mark(TSUPPRESSED); + mark(DETROP); + mark(MISSING); + mark(FBS); + mark(lexstates); + mark(lexdefs); + for(i=0;i<128;i++) + if(namebucket[i])mark(namebucket[i]); + for(p=dstack;p<stackp;p++)mark(*p); + if(loading) + { mark(algshfns); + mark(speclocs); + mark(exportfiles); + mark(embargoes); + mark(rfl); + mark(detrop); + mark(bereaved); + mark(ld_stuff); + mark(tlost); + for(i=0;i<nextpn;i++)mark(pnvec[i]); } + mark(lastname); + mark(suppressids); + mark(lastexp); + mark(nill); + mark(standardout); + mark(big_one); + mark(yyval); +/* for(vp= yyvs;vp<=yyvsp;vp++)mark(*vp); */ + mark(yylval); + mark(R); + mark(TABSTRS); + mark(SGC); + mark(ND); + mark(SBND); + mark(NT); + mark(current_id); + mark(meta_pending); + mark(newtyps); + mark(showchain); + mark(errs); + mark(tfnum); + mark(tfbool); + mark(tfbool2); + mark(tfnum2); + mark(tfstrstr); + mark(tfnumnum); + mark(ltchar); + mark(bnf_t); + mark(exec_t); + mark(read_t); + mark(filestat_t); + mark(tstep); + mark(tstepuntil); + mark(tvmap); + mark(localtvmap); + for(i=0;i<hashsize;i++)mark(SUBST[i]); } +/* if(atgc)printf("<<%d I-nodes>>\n",Icount); /* DEBUG */ +} + +void mark(x) /* a marked cell is distinguished by having a +ve "tag" */ +word x; +{ x&= ~tlptrbits; /* x may be a `reversed pointer' (see reduce.c) */ + while(isptr(x)&&negchar(tag[x])) + { /*if(hd[x]==I)Icount++; /* DEBUG */ + if((tag[x]= -tag[x])<INT)return; + if(tag[x]>STRCONS)mark(hd[x]); + x= tl[x]&~tlptrbits; } +} + +/* test added Jan 2020 - DT */ +#define wordsize (__WORDSIZE) +#if wordsize==32 +#define splitdouble +union fpdatum {double real; struct{word left;word right;} bits;}; +#elif wordsize==64 +union fpdatum {double real; word bits;}; +#else +#error "platform has unknown word size" +#endif + +double get_dbl(x) +word x; +{ union fpdatum r; +#ifdef splitdouble + r.bits.left= hd[x]; + r.bits.right= tl[x]; +#else + r.bits= hd[x]; +#endif + return(r.real); } + +/* Miranda's arithmetic model requires fp overflow trapped. On sparc this + can be done by setting a trap with ieee_handler (see steer.c) otherwise + we test for overflow with isfinite() */ + +word sto_dbl(R) +double R; +{ union fpdatum r; +#if !defined sparc /* */ + if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */ +#endif + r.real=R; +#ifdef splitdouble + return(make(DOUBLE,r.bits.left,r.bits.right)); +#else + return(make(DOUBLE,r.bits,0)); +#endif +} + +void setdbl(x,R) +word x; +double R; +{ union fpdatum r; +#if !defined sparc /* */ + if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */ +#endif + r.real=R; + tag[x]=DOUBLE; +#ifdef splitdouble + hd[x]=r.bits.left; tl[x]=r.bits.right; +#else + hd[x]=r.bits; tl[x]=0; +#endif +} + +word sto_char(c) /* assumes 0<=c<=UMAX */ +int c; +{ return c<256?c:make(UNICODE,c,0); } + +word get_char(x) +word x; +{ if(x<256)return x; + if(tag[x]==UNICODE)return hd[x]; + fprintf(stderr,"impossible event in get_char(x), tag[x]==%d\n",tag[x]); + exit(1); +} + +int is_char(x) +word x; +{ return 0<=x && x<256 || tag[x]==UNICODE; } + +word sto_id(p1) +char *p1; +{ return(make(ID,cons(strcons(p1,NIL),undef_t),UNDEF)); } + /* the hd of an ID contains cons(strcons(name,who),type) and + the tl has the value */ + /* who is NIL, hereinfo, or cons(aka,hereinfo) where aka + is of the form datapair(oldname,0) oldname being a string */ + /* hereinfo is fileinfo(script,line_no) */ + +/* hereafter is stuff for dumping and undumping compiled scripts + w means (sizeof(word)) in bytes + + (internal heap object) (external file rep - char sequence) + ---------------------- ----------------------------------- + 0..127 self + 128..383 CHAR_X (self-128) + 384..ATOMLIMIT-1 (self-256) + integer (-127..127) SHORT_X <byte> + integer INT_X <4n bytes> (-1) + double DBL_X <8 bytes> + unicode_char UNICODE_X <4 bytes> + typevar TVAR_X <byte> + ap(x,y) [x] [y] AP_X + cons(x,y) [y] [x] CONS_X + id (=occurrence) ID_X <string terminated by '\0'> + pname (=occurrence) PN_X <2 bytes> + PN1_X <4 bytes> + datapair(string,0) AKA_X <string...\0> + fileinfo(script,line_no) HERE_X <string...\0> <2 bytes> (**) + constructor(n,x) [x] CONSTRUCT_X <2 bytes> + readvals(h,t) [t] RV_X + definition [val] [type] [who] [id] DEF_X + [val] [pname] DEF_X + definition-list [definition*] DEF_X + filename <string terminated by '\0'> + mtime <w bytes> + + complete script __WORDSIZE + XVERSION + [ [filename] + [mtime] + [shareable] (=0 or 1) + [definition-list] ]+ + '\0' + [definition-list] (algshfns) + [ND] or [True] (see below) + DEF_X + [SGC] + DEF_X + [freeids] + DEF_X + [definition-list] (internals) + + type-error script __WORDSIZE + XVERSION + '\1' + <w bytes> (=errline) + ... (rest as normal script) + + syntax-error script __WORDSIZE + XVERSION + `\0' + <w bytes> (=errline) + [ [filename] + [mtime] ]+ + + Notes + ----- + first filename in dump must be that of `current_script' (ie the + main source file). All pathnames in dump are correct wrt the + directory of the main source. + (**) empty string is abbreviation for current filename in hereinfo + True in ND position indicates an otherwise correct dump whose exports + include type orphans + + Pending: + -------- + could have abbreviation for iterated ap and cons + + remaining issue - external format should be machine and version + independent - not clear how to do this +*/ + +#define XBASE ATOMLIMIT-256 +#define CHAR_X (XBASE) +#define SHORT_X (XBASE+1) +#define INT_X (XBASE+2) +#define DBL_X (XBASE+3) +#define ID_X (XBASE+4) +#define AKA_X (XBASE+5) +#define HERE_X (XBASE+6) +#define CONSTRUCT_X (XBASE+7) +#define RV_X (XBASE+8) +#define PN_X (XBASE+9) +#define PN1_X (XBASE+10) +#define DEF_X (XBASE+11) +#define AP_X (XBASE+12) +#define CONS_X (XBASE+13) +#define TVAR_X (XBASE+14) +#define UNICODE_X (XBASE+15) +#define XLIMIT (XBASE+16) +#if XLIMIT>512 +#error "coding scheme breaks down: XLIMIT>512" +#endif + +void putword(x,f) +word x; +FILE *f; +{ int i=sizeof(word); + putc(x&255,f); + while(--i)x>>=8,putc(x&255,f); +} + +word getword(f) +FILE *f; +{ int s=0, i=sizeof(word); + word x=getc(f); + while(--i)s += 8, x |= getc(f)<<s; + return x; +} + +void putint(int n,FILE *f) +{ fwrite(&n,sizeof(int),1,f); } + +int getint(FILE *f) +{ int r; + fread(&r,sizeof(int),1,f); + return r; } + +void putdbl(word x,FILE *f) +{ double d = get_dbl(x); + fwrite(&d,sizeof(double),1,f); } + +word getdbl(FILE *f) +{ double d; + fread(&d,sizeof(double),1,f); + return sto_dbl(d); +} + +static char prefix[pnlim]; +word preflen; + +void setprefix(p) /* to that of pathname p */ +char *p; +{ char *g; + (void)strcpy(prefix,p); + g=rindex(prefix,'/'); + if(g)g[1]='\0'; + else *prefix='\0'; + preflen = strlen(prefix); +} /* before calling dump_script or load_script must setprefix() to that + of current pathname of file being dumped/loaded - to get correct + translation between internal pathnames (relative to dump script) + and external pathnames */ + +char *mkrel(p) /* makes pathname p correct relative to prefix */ +char *p; /* must use when writing pathnames to dump */ +{ if(strncmp(prefix,p,preflen)==0)return(p+preflen); + if(p[0]=='/')return(p); + fprintf(stderr,"impossible event in mkrelative\n"); /* or use getwd */ + /* not possible because all relative pathnames in files were computed + wrt current script */ + return(p); /* proforma only */ +} + +#define bits_15 0177777 +char *CFN; + +void dump_script(files,f) /* write compiled script files to file f */ +word files; +FILE *f; +{ extern word ND,bereaved,errline,algshfns,internals,freeids,SGC; + putc(wordsize,f); + putc(XVERSION,f); /* identifies dump format */ + if(files==NIL){ /* source contains syntax or metatype error */ + extern word oldfiles; + word x; + putc(0,f); + putword(errline,f); + for(x=oldfiles;x!=NIL;x=tl[x]) + fprintf(f,"%s",mkrel(get_fil(hd[x]))),putc(0,f), + /*filename*/ + putword(fil_time(hd[x]),f); /* mtime */ + return; } + if(ND!=NIL)putc(1,f),putword(errline,f); + for(;files!=NIL;files=tl[files]) + { fprintf(f,"%s",mkrel(CFN=get_fil(hd[files]))); /* filename */ + putc(0,f); + putword(fil_time(hd[files]),f); + putc(fil_share(hd[files]),f); + dump_defs(fil_defs(hd[files]),f); + } + putc(0,f); /* header - not a possible filename */ + dump_defs(algshfns,f); + if(ND==NIL&&bereaved!=NIL)dump_ob(True,f); /* special flag */ + else dump_ob(ND,f); + putc(DEF_X,f); + dump_ob(SGC,f); + putc(DEF_X,f); + dump_ob(freeids,f); + putc(DEF_X,f); + dump_defs(internals,f); +} + +void dump_defs(defs,f) /* write list of defs to file f */ +word defs; +FILE *f; +{ while(defs!=NIL) + if(tag[hd[defs]]==STRCONS) /* pname */ + { word v=get_pn(hd[defs]); + dump_ob(pn_val(hd[defs]),f); + if(v>bits_15) + putc(PN1_X,f), + putint(v,f); + else + putc(PN_X,f), + putc(v&255,f), + putc(v >> 8,f); + putc(DEF_X,f); + defs=tl[defs]; } + else + { dump_ob(id_val(hd[defs]),f); + dump_ob(id_type(hd[defs]),f); + dump_ob(id_who(hd[defs]),f); + putc(ID_X,f); + fprintf(f,"%s",(char *)get_id(hd[defs])); + putc(0,f); + putc(DEF_X,f); + defs=tl[defs]; } + putc(DEF_X,f); /* delimiter */ +} + +void dump_ob(x,f) /* write combinatory expression x to file f */ +word x; +FILE *f; +{ /* printob("dumping: ",x); /* DEBUG */ + switch(tag[x]) + { case ATOM: if(x<128)putc(x,f); else + if(x>=384)putc(x-256,f); else + putc(CHAR_X,f),putc(x-128,f); + return; + case TVAR: putc(TVAR_X,f), putc(gettvar(x),f); + if(gettvar(x)>255) + fprintf(stderr,"panic, tvar too large\n"); + return; + case INT: { word d=digit(x); + if(rest(x)==0&&(d&MAXDIGIT)<=127) + { if(d&SIGNBIT)d= -(d&MAXDIGIT); + putc(SHORT_X,f); putc(d,f); return; } + putc(INT_X,f); + putint(d,f); + x=rest(x); + while(x) + putint(digit(x),f),x=rest(x); + putint(-1,f); + return; } + /* 4 bytes per digit wasteful at current value of IBASE */ + case DOUBLE: putc(DBL_X,f); + putdbl(x,f); +/* + putword(hd[x],f); +#ifdef splitdouble + putword(tl[x],f); +#endif +*/ + return; + case UNICODE: putc(UNICODE_X,f); + putint(hd[x],f); + return; + case DATAPAIR: fprintf(f,"%c%s",AKA_X,(char *)hd[x]); + putc(0,f); + return; + case FILEINFO: { word line=tl[x]; + if((char *)hd[x]==CFN)putc(HERE_X,f); + else fprintf(f,"%c%s",HERE_X,mkrel(hd[x])); + putc(0,f); + putc(line&255,f); + putc((line >>= 8)&255,f); + if(line>255)fprintf(stderr, + "impossible line number %ld in dump_ob\n",tl[x]); + return; } + case CONSTRUCTOR: dump_ob(tl[x],f); + putc(CONSTRUCT_X,f); + putc(hd[x]&255,f); + putc(hd[x]>>8,f); + return; + case STARTREADVALS: dump_ob(tl[x],f); + putc(RV_X,f); + return; + case ID: fprintf(f,"%c%s",ID_X,get_id(x)); + putc(0,f); + return; + case STRCONS: { word v=get_pn(x); /* private name */ + if(v>bits_15) + putc(PN1_X,f), + putint(v,f); + else + putc(PN_X,f), + putc(v&255,f), + putc(v >> 8,f); + return; } + case AP: dump_ob(hd[x],f); + dump_ob(tl[x],f); + putc(AP_X,f); + return; + case CONS: dump_ob(tl[x],f); + dump_ob(hd[x],f); + putc(CONS_X,f); + return; + default: fprintf(stderr,"impossible tag %d in dump_ob\n",tag[x]); + } +} + +#define ovflocheck if(dicq-dic>DICSPACE)dicovflo() +extern char *dic; extern word DICSPACE; + +word BAD_DUMP=0,CLASHES=NIL,ALIASES=NIL,PNBASE=0,SUPPRESSED=NIL, + TSUPPRESSED=NIL,TORPHANS=0; + +word load_script(f,src,aliases,params,main) + /* loads a compiled script from file f for source src */ + /* main=1 if is being loaded as main script, 0 otherwise */ +FILE *f; +char *src; +word aliases,params,main; +{ extern word nextpn,ND,errline,algshfns,internals,freeids,includees,SGC; + extern char *dicp, *dicq; + word ch,files=NIL; + TORPHANS=BAD_DUMP=0; + CLASHES=NIL; + dsetup(); + setprefix(src); + if(getc(f)!= wordsize || getc(f)!=XVERSION) + { BAD_DUMP= -1; return(NIL); } + if(aliases!=NIL) + { /* for each `old' install diversion to `new' */ + /* if alias is of form -old `new' is a pname */ + word a,hold; + ALIASES=aliases; + for(a=aliases;a!=NIL;a=tl[a]) + { word old=tl[hd[a]],new=hd[hd[a]]; + hold=cons(id_who(old),cons(id_type(old),id_val(old))); + id_type(old)=alias_t; + id_val(old)=new; + if(tag[new]==ID) + if((id_type(new)!=undef_t||id_val(new)!=UNDEF) + &&id_type(new)!=alias_t) + CLASHES=add1(new,CLASHES); + hd[hd[a]]=hold; + } + if(CLASHES!=NIL){ BAD_DUMP= -2; unscramble(aliases); return(NIL); } + for(a=aliases;a!=NIL;a=tl[a]) /* FIX1 */ + if(tag[ch=id_val(tl[hd[a]])]==ID) /* FIX1 */ + if(id_type(ch)!=alias_t) /* FIX1 */ + id_type(ch)=new_t; /* FIX1 */ + } + PNBASE=nextpn; /* base for relocation of internal names in dump */ + SUPPRESSED=NIL; /* list of `-id' aliases successfully obeyed */ + TSUPPRESSED=NIL; /* list of -typename aliases (illegal just now) */ + while((ch=getc(f))!=0&&ch!=EOF&&!BAD_DUMP) + { word s,holde=0; + dicq=dicp; + if(files==NIL&&ch==1) /* type error script */ + { holde=getword(f),ch=getc(f); + if(main)errline=holde; } + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ovflocheck; + ch=getword(f); /* mtime */ + s=getc(f); /* share bit */ + /*printf("loading: %s(%d)\n",dicp,ch); /* DEBUG */ + if(files==NIL) /* is this the right dump? */ + if(strcmp(dicp,src)) + { BAD_DUMP=1; + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + CFN=get_id(name()); /* wasteful way to share filename */ + files = cons(make_fil(CFN,ch,s,load_defs(f)), + files); + } +/* warning: load_defs side effects id's in namebuckets, cannot be undone by +unload until attached to global `files', so interrupts are disabled during +load_script - see steer.c */ /* for big dumps this may be too coarse - FIX */ + if(ch==EOF||BAD_DUMP){ if(!BAD_DUMP)BAD_DUMP=2; + if(aliases!=NIL)unscramble(aliases); + return(files); } + if(files==NIL){ /* dump of syntax error state */ + extern word oldfiles; + ch=getword(f); + if(main)errline=ch; + while((ch=getc(f))!=EOF) + { dicq=dicp; + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ovflocheck; + ch=getword(f); /* mtime */ + if(oldfiles==NIL) /* is this the right dump? */ + if(strcmp(dicp,src)) + { BAD_DUMP=1; + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + oldfiles = cons(make_fil(get_id(name()),ch,0,NIL), + oldfiles); + } + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + algshfns=append1(algshfns,load_defs(f)); + ND=load_defs(f); + if(ND==True)ND=NIL,TORPHANS=1; + SGC=append1(SGC,load_defs(f)); + if(main||includees==NIL)freeids=load_defs(f); + else bindparams(load_defs(f),hdsort(params)); + if(aliases!=NIL)unscramble(aliases); + if(main)internals=load_defs(f); + return(reverse(files)); +}/* was it necessary to unscramble aliases before error returns? + check this later */ +/* actions labelled FIX1 were inserted to deal with the pathological case + that the destination of an alias (not part of a cyclic alias) has a direct + definition in the file and the aliasee is missing from the file + - this is both nameclash and missing aliasee, but without fix the two + errors cancel each other out and are unreported */ + +word DETROP=NIL,MISSING=NIL; + +void bindparams(formal,actual) /* process bindings of free ids */ +/* formal is list of cons(id,cons(original_name,type)) */ +/* actual is list of cons(name,value) | ap(name,typevalue)) */ +/* both in alpha order of original name */ +word formal,actual; +{ extern word FBS; word badkind=NIL; + DETROP=MISSING=NIL; + FBS=cons(formal,FBS); + /* FBS is list of list of formals bound in current script */ + for(;;) + { word a; char *f; + while(formal!=NIL && (actual==NIL || + strcmp((f=(char *)hd[hd[tl[hd[formal]]]]),get_id(a=hd[hd[actual]]))<0)) + /* the_val(hd[hd[formal]])=findid((char *)hd[hd[tl[hd[formal]]]]), + above line picks up identifier of that name in current scope */ + MISSING=cons(hd[tl[hd[formal]]],MISSING), + formal=tl[formal]; + if(actual==NIL)break; + if(formal==NIL||strcmp(f,get_id(a)))DETROP=cons(a,DETROP); + else { word fa=tl[tl[hd[formal]]]==type_t?t_arity(hd[hd[formal]]):-1; + word ta=tag[hd[actual]]==AP?t_arity(hd[actual]):-1; + if(fa!=ta) + badkind=cons(cons(hd[hd[actual]],datapair(fa,ta)),badkind); + the_val(hd[hd[formal]])=tl[hd[actual]]; + formal=tl[formal]; } + actual=tl[actual]; + } +for(;badkind!=NIL;badkind=tl[badkind]) + DETROP=cons(hd[badkind],DETROP); +} + +void unscramble(aliases) /* remove old to new diversions installed above */ +word aliases; +{ word a=NIL; + for(;aliases!=NIL;aliases=tl[aliases]) + { word old=tl[hd[aliases]],hold=hd[hd[aliases]]; + word new=id_val(old); + hd[hd[aliases]]=new; /* put back for missing check, see below */ + id_who(old)=hd[hold]; hold=tl[hold]; + id_type(old)=hd[hold]; + id_val(old)=tl[hold]; } + for(;ALIASES!=NIL;ALIASES=tl[ALIASES]) + { word new=hd[hd[ALIASES]]; + word old=tl[hd[ALIASES]]; + if(tag[new]!=ID) + { if(!member(SUPPRESSED,new))a=cons(old,a); + continue; } /* aka stuff irrelevant to pnames */ + if(id_type(new)==new_t)id_type(new)=undef_t; /* FIX1 */ + if(id_type(new)==undef_t)a=cons(old,a); else + if(!member(CLASHES,new)) + /* install aka info in new */ + if(tag[id_who(new)]!=CONS) + id_who(new)=cons(datapair(get_id(old),0),id_who(new)); } + ALIASES=a; /* transmits info about missing aliasees */ +} + +char *getaka(x) /* returns original name of x (as a string) */ +word x; +{ word y=id_who(x); + return(tag[y]!=CONS?get_id(x):(char *)hd[hd[y]]); +} + +word get_here(x) /* here info for id x */ +word x; +{ word y=id_who(x); + return(tag[y]==CONS?tl[y]:y); +} + +void dsetup() +{ if(!dstack) + { dstack=(word *)malloc(1000*sizeof(word)); + if(dstack==NULL)mallocfail("dstack"); + dlim=dstack+1000; } + stackp=dstack; +} + +void dgrow() +{ word *hold=dstack; + dstack=(word *)realloc(dstack,2*(dlim-dstack)*sizeof(word)); + if(dstack==NULL)mallocfail("dstack"); + dlim=dstack+2*(dlim-hold); + stackp += dstack-hold; + /*printf("dsize=%d\n",dlim-dstack); /* DEBUG */ +} + +word load_defs(f) /* load a sequence of definitions from file f, terminated + by DEF_X, or a single object terminated by DEF_X */ +FILE *f; +{ extern char *dicp, *dicq; + extern word *pnvec,common_stdin,common_stdinb,nextpn,rv_script; + word ch, defs=NIL; + while((ch=getc(f))!=EOF) + { if(stackp==dlim)dgrow(); + switch(ch) + { case CHAR_X: *stackp++ = getc(f)+128; + continue; + case TVAR_X: *stackp++ = mktvar(getc(f)); + continue; + case SHORT_X: ch = getc(f); + if(ch&128)ch= ch|(~127); /*force a sign extension*/ + *stackp++ = stosmallint(ch); + continue; + case INT_X: { word *x; + ch = getint(f); + *stackp++ = make(INT,ch,0); + x = &rest(stackp[-1]); + ch = getint(f); + while(ch!= -1) + *x=make(INT,ch,0),ch=getint(f),x= &rest(*x); + continue; } + case DBL_X: *stackp++ = getdbl(f); +/* +#ifdef splitdouble + *stackp++ = make(DOUBLE,ch,getword(f)); +#else + *stackp++ = make(DOUBLE,ch,0); +#endif +*/ + continue; + case UNICODE_X: *stackp++ = make(UNICODE,getint(f),0); + continue; + case PN_X: ch = getc(f); + ch = PNBASE+(ch|(getc(f)<<8)); + *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch); + /* efficiency hack for *stackp++ = sto_pn(ch); */ + continue; + case PN1_X: ch=PNBASE+getint(f); + *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch); + /* efficiency hack for *stackp++ = sto_pn(ch); */ + continue; + case CONSTRUCT_X: ch = getc(f); + ch = ch|(getc(f)<<8); + stackp[-1] = constructor(ch,stackp[-1]); + continue; + case RV_X: stackp[-1] = readvals(0,stackp[-1]); + rv_script=1; + continue; + case ID_X: dicq=dicp; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + *stackp++=name(); /* see lex.c */ + if(id_type(stackp[-1])==new_t) /* FIX1 (& next 2 lines) */ + CLASHES=add1(stackp[-1],CLASHES),stackp[-1]=NIL; + else + if(id_type(stackp[-1])==alias_t) /* follow alias */ + stackp[-1]=id_val(stackp[-1]); + continue; + case AKA_X: dicq=dicp; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + *stackp++=datapair(get_id(name()),0); + /* wasteful, to share string */ + continue; + case HERE_X: dicq=dicp; + ch=getc(f); + if(!ch){ /* coding hack, 0 means current file name */ + ch = getc(f); + ch = ch|getc(f)<<8; + *stackp++ = fileinfo(CFN,ch); + continue; } + /* next line locates wrt current posn */ + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + ch = getc(f); + ch = ch|getc(f)<<8; + *stackp++ = fileinfo(get_id(name()),ch); /* wasteful */ + continue; + case DEF_X: switch(stackp-dstack){ + case 0: /* defs delimiter */ + { /*printlist("contents: ",defs); /* DEBUG */ + return(reverse(defs)); } + case 1: /* ob delimiter */ + { return(*--stackp); } + case 2: /* pname defn */ + { ch = *--stackp; + pn_val(ch)= *--stackp; + defs=cons(ch,defs); /* NB defs now includes pnames */ + continue; } + case 4: + if(tag[stackp[-1]]!=ID) + if(stackp[-1]==NIL){ stackp -= 4; continue; } /* FIX1 */ + else { /* id aliased to pname */ + word akap; + ch= *--stackp; + SUPPRESSED=cons(ch,SUPPRESSED); + stackp--; /* who */ + akap= tag[*stackp]==CONS?hd[*stackp]:NIL; + stackp--; /* lose type */ + pn_val(ch)= *--stackp; + if(stackp[1]==type_t&&t_class(ch)!=synonym_t) + /* suppressed typename */ + { word a=ALIASES; /* reverse assoc in ALIASES */ + while(a!=NIL&&id_val(tl[hd[a]])!=ch) + a=tl[a]; + if(a!=NIL) /* surely must hold ?? */ + TSUPPRESSED=cons(tl[hd[a]],TSUPPRESSED); + /*if(akap==NIL) + akap=datapair(get_id(tl[hd[a]]),0); */ + /*if(t_class(ch)==algebraic_t) + CSUPPRESS=append1(CSUPPRESS,t_info(ch)); + t_info(ch)= cons(akap,fileinfo(CFN,0)); + /* assists identifn of dangling typerefs + see privatise() in steer.c */ }else + if(pn_val(ch)==UNDEF) + { /* special kludge for undefined names */ + /* necessary only if we allow names specified + but not defined to be %included */ + if(akap==NIL) /* reverse assoc in ALIASES */ + { word a=ALIASES; + while(a!=NIL&&id_val(tl[hd[a]])!=ch) + a=tl[a]; + if(a!=NIL) + akap=datapair(get_id(tl[hd[a]]),0); } + pn_val(ch)= ap(akap,fileinfo(CFN,0)); + /* this will generate sensible error message + see reduction rule for DATAPAIR */ + } + defs=cons(ch,defs); + continue; } + if( + id_type(stackp[-1])!=new_t&& /* FIX1 */ + (id_type(stackp[-1])!=undef_t|| + id_val(stackp[-1])!=UNDEF)) /* nameclash */ + { if(id_type(stackp[-1])==alias_t) /* cyclic aliasing */ + { word a=ALIASES; + while(a!=NIL&&tl[hd[a]]!=stackp[-1])a=tl[a]; + if(a==NIL) + { fprintf(stderr, + "impossible event in cyclic alias (%s)\n", + get_id(stackp[-1])); + stackp-=4; + continue; } + defs=cons(*--stackp,defs); + hd[hd[hd[a]]]= *--stackp; /* who */ + hd[tl[hd[hd[a]]]]= *--stackp; /* type */ + tl[tl[hd[hd[a]]]]= *--stackp; /* value */ + continue; } + /*if(strcmp(CFN,hd[get_here(stackp[-1])])) + /* EXPT (ignore clash if from same original file) */ + CLASHES=add1(stackp[-1],CLASHES); + stackp-=4; } + else + defs=cons(*--stackp,defs), + /*printf("%s undumped\n",get_id(hd[defs])), /* DEBUG */ + id_who(hd[defs])= *--stackp, + id_type(hd[defs])= *--stackp, + id_val(hd[defs])= *--stackp; + continue; + default: + { /* printf("badly formed def in dump\n"); /* DEBUG */ + BAD_DUMP=3; return(defs); } /* should unsetids */ + } /* of switch */ + case AP_X: ch = *--stackp; + if(stackp[-1]==READ&&ch==0)stackp[-1] = common_stdin; else + if(stackp[-1]==READBIN&&ch==0)stackp[-1] = common_stdinb; else + stackp[-1] = ap(stackp[-1],ch); + continue; + case CONS_X: ch = *--stackp; + stackp[-1] = cons(ch,stackp[-1]); + continue; + default: *stackp++ = ch>127?ch+256:ch; + }} + BAD_DUMP=4; /* should unsetids */ + return(defs); +} + +extern char *obsuffix; + +int okdump(t) /* return 1 if script t has a non-syntax-error dump */ +char *t; +{ char obf[120]; + FILE *f; + (void)strcpy(obf,t); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + f=fopen(obf,"r"); + if(f&&getc(f)==XVERSION&&getc(f)){fclose(f); return(1); } + return(0); +} + +word geterrlin(t) /* returns errline from dump of t if relevant, 0 otherwise */ +char *t; +{ char obf[120]; + extern char *dicp,*dicq; + int ch; word el; + FILE *f; + (void)strcpy(obf,t); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + if(!(f=fopen(obf,"r")))return(0); + if(getc(f)!=XVERSION||(ch=getc(f))&&ch!=1){ fclose(f); + return(0); } + el=getword(f); + /* now check this is right dump */ + setprefix(t); + ch=getc(f); + dicq=dicp; + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ch=getword(f); /* mtime */ + if(strcmp(dicp,t)||ch!=fm_time(t))return(0); /* wrong dump */ + /* this test not foolproof, strictly should extract all files and check + their mtimes, as in undump, but this involves reading the whole dump */ + return(el); +} + +word hdsort(x) /* sorts list of name-value pairs on name */ +word x; +{ word a=NIL,b=NIL,hold=NIL; + if(x==NIL)return(NIL); + if(tl[x]==NIL)return(x); + while(x!=NIL) /* split x */ + { hold=a,a=cons(hd[x],b),b=hold; + x=tl[x]; } + a=hdsort(a),b=hdsort(b); + /* now merge two halves back together */ + while(a!=NIL&&b!=NIL) + if(strcmp(get_id(hd[hd[a]]),get_id(hd[hd[b]]))<0)x=cons(hd[a],x),a=tl[a]; + else x=cons(hd[b],x),b=tl[b]; + if(a==NIL)a=b; + while(a!=NIL)x=cons(hd[a],x),a=tl[a]; + return(reverse(x)); +} + +word append1(x,y) /* rude append */ +word x,y; +{ word x1=x; + if(x1==NIL)return(y); + while(tl[x1]!=NIL)x1=tl[x1]; + tl[x1]=y; + return(x); +} + +/* following is stuff for printing heap objects in readable form - used + for miscellaneous diagnostics etc - main function is out(FILE *,object) */ + +/* charname returns the printable name of a character, as a string (using + C conventions for control characters */ /* DAT 13/9/83 */ +/* NB we use DECIMAL (not octal) for miscellaneous unprintables */ + +/* WARNING - you should take a copy of the name if you intend to do anything + with it other than print it immediately */ + +char *charname(c) +word c; +{ static char s[5]; + switch(c) + { case '\n': return("\\n"); + case '\t': return("\\t"); + case '\b': return("\\b"); + case '\f': return("\\f"); /* form feed */ + case '\r': return("\\r"); /* carriage return */ + case '\\': return("\\\\"); + case '\'': return("\\'"); + case '"': return("\\\""); + /* we escape all quotes for safety, since the context could be either + character or string quotation */ + default: if(c<32||c>126) /* miscellaneous unprintables -- convert to decimal */ + sprintf(s,"\\%ld",c); + else s[0]=c,s[1]='\0'; + return(s); + } +} + +void out(f,x) +/* the routines "out","out1","out2" are for printing compiled expressions */ +FILE *f; +word x; +{ +#ifdef DEBUG + static pending=NIL; /* cycle trap */ + word oldpending=pending; /* cycle trap */ +#endif + if(x<0||x>TOP){ fprintf(f,"<%ld>",x); return; } +#ifdef DEBUG + if(member(pending,x)){ fprintf(f,"..."); return; } /* cycle trap */ + pending=cons(x,pending); /* cycle trap */ +#endif + if(tag[x]==LAMBDA) + { fprintf(f,"$(");out(f,hd[x]);putc(')',f); + out(f,tl[x]); } else + { while(tag[x]==CONS) + { out1(f,hd[x]); + putc(':',f); + x= tl[x]; +#ifdef DEBUG + if(member(pending,x))break; /* cycle trap */ + pending=cons(x,pending); /* cycle trap */ +#endif + } + out1(f,x); } +#ifdef DEBUG + pending=oldpending; /* cycle trap */ +#endif +} /* warning - cycle trap not interrupt safe if `out' used in compiling + process */ + +void out1(f,x) +FILE *f; +word x; +{ if(x<0||x>TOP){ fprintf(f,"<%ld>",x); return; } + if(tag[x]==AP) + { out1(f,hd[x]); + putc(' ',f); + out2(f,tl[x]); } + else out2(f,x); } + +void out2(f,x) +FILE *f; +word x; +{ extern char *yysterm[], *cmbnms[]; + if(x<0||x>TOP){ fprintf(f,"<%ld>",x); return; } + if(tag[x]==INT) + { if(rest(x)) + { x=bigtostr(x); + while(x)putc(hd[x],f),x=tl[x]; } + else fprintf(f,"%ld",getsmallint(x)); + return; } + if(tag[x]==DOUBLE){ outr(f,get_dbl(x)); return; } + if(tag[x]==ID){ fprintf(f,"%s",get_id(x)); return; } + if(x<256){ fprintf(f,"\'%s\'",charname(x)); return; } + if(tag[x]==UNICODE){ fprintf(f,"'\%lx'",hd[x]); return; } + if(tag[x]==ATOM) + { fprintf(f,"%s",x<CMBASE?yysterm[x-256]: + x==True?"True": + x==False?"False": + x==NIL?"[]": + x==NILS?"\"\"": + cmbnms[x-CMBASE]); + return; } + if(tag[x]==TCONS||tag[x]==PAIR) + { fprintf(f,"("); + while(tag[x]==TCONS) + out(f,hd[x]), putc(',',f), x=tl[x]; + out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==TRIES) + { fprintf(f,"TRIES("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==LABEL) + { fprintf(f,"LABEL("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==SHOW) + { fprintf(f,"SHOW("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==STARTREADVALS) + { fprintf(f,"READVALS("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==LET) + { fprintf(f,"(LET "); + out(f,dlhs(hd[x])),fprintf(f,"="); + out(f,dval(hd[x])),fprintf(f,";IN "); + out(f,tl[x]); + fprintf(f,")"); return; } + if(tag[x]==LETREC) + { word body=tl[x]; + fprintf(f,"(LETREC "); + x=hd[x]; + while(x!=NIL)out(f,dlhs(hd[x])),fprintf(f,"="), + out(f,dval(hd[x])),fprintf(f,";"),x=tl[x]; + fprintf(f,"IN "); + out(f,body); + fprintf(f,")"); return; } + if(tag[x]==DATAPAIR) + { fprintf(f,"DATAPAIR(%s,%ld)",(char *)hd[x],tl[x]); + return; } + if(tag[x]==FILEINFO) + { fprintf(f,"FILEINFO(%s,%ld)",(char *)hd[x],tl[x]); + return; } + if(tag[x]==CONSTRUCTOR) + { fprintf(f,"CONSTRUCTOR(%ld)",hd[x]); + return; } + if(tag[x]==STRCONS) + { fprintf(f,"<$%ld>",hd[x]); return; }/* used as private id's, inter alia*/ + if(tag[x]==SHARE) + { fprintf(f,"(SHARE:"); out(f,hd[x]); fprintf(f,")"); return; } + if(tag[x]!=CONS&&tag[x]!=AP&&tag[x]!=LAMBDA) + /* not a recognised structure */ + { fprintf(f,"<%ld|tag=%d>",x,tag[x]); return; } + putc('(',f); + out(f,x); + putc(')',f); } + +void outr(f,r) /* prints a number */ +FILE *f; +double r; +{ double p; + p= r<0?-r: r; + if(p>=1000.0||p<=.001)fprintf(f,"%e",r); + else fprintf(f,"%f",r); } + +/* end of MIRANDA DATA REPRESENTATIONS */ + @@ -0,0 +1,350 @@ +/* MISCELLANEOUS DECLARATIONS */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +typedef long word; +/* word must be an integer type wide enough to also store (char*) or (FILE*). + Defining it as "long" works on the most common platforms both 32 and + 64 bit. Be aware that word==long is reflected in printf etc formats + e.g. %ld, in many places in the code. If you define word to be other + than long these will need to be changed, the gcc/clang option -Wformat + will locate format/arg type mismatches. DT Jan 2020 */ + +#define YYSTYPE word +#define YYMAXDEPTH 1000 +extern YYSTYPE yylval; +#include "y.tab.h" /* for tokens */ +#include "combs.h" /* for combinators */ +#include "utf8.h" /* for UMAX etc */ +#include ".xversion" + /* #define for XVERSION - we increase this by one at each non upwards + compatible change to dump format */ + +/* all Miranda values are of type word + + 0..ATOMLIMIT-1 are atoms, made up as follows + 0..255 the Latin 1 character set (0..127 ascii) + 256..CMBASE-1 lexical tokens, see rules.y + CMBASE..ATOMLIMIT-1 combinators and special values eg NIL + see combs.h + + ATOMLIMIT is the first pointer value + values >= ATOMLIMIT are indexes into the heap + + the heap is held as three arrays tag[], hd[], tl[] + word *hd,*tl are offset so they are indexed from ATOMLIMIT + char *tag holds type info and is indexed from 0 + + tag[0]..tag[ATOMLIMIT-1] are all 0 meaning ATOM + see setupheap() in data.c +*/ + +#define ATOM 0 +#define DOUBLE 1 +#define DATAPAIR 2 +#define FILEINFO 3 +/* FILEINFO differs from DATAPAIR in that (char *) in hd will be made relative + to current directory on dump/undump */ +#define TVAR 4 +#define INT 5 +#define CONSTRUCTOR 6 +#define STRCONS 7 +#define ID 8 +#define AP 9 +#define LAMBDA 10 +#define CONS 11 +#define TRIES 12 +#define LABEL 13 +#define SHOW 14 +#define STARTREADVALS 15 +#define LET 16 +#define LETREC 17 +#define SHARE 18 +#define LEXER 19 +#define PAIR 20 +#define UNICODE 21 +#define TCONS 22 + /* ATOM ... TCONS are the possible values of the + "tag" field of a cell */ + +#define TOP (SPACE+ATOMLIMIT) +#define isptr(x) (ATOMLIMIT<=(x)&&(x)<TOP) + +#define BACKSTOP (1l<<(__WORDSIZE-1)) +#define tlptrbit BACKSTOP +#define tlptrbits (3l<<(__WORDSIZE-2)) + +#define datapair(x,y) make(DATAPAIR,(word)x,(word)y) +#define fileinfo(x,y) make(FILEINFO,(word)x,(word)y) +#define constructor(n,x) make(CONSTRUCTOR,(word)n,(word)x) +#define strcons(x,y) make(STRCONS,(word)x,y) +#define cons(x,y) make(CONS,x,y) +#define lambda(x,y) make(LAMBDA,x,y) +#define let(x,y) make(LET,x,y) +#define letrec(x,y) make(LETREC,x,y) +#define share(x,y) make(SHARE,x,y) +#define pair(x,y) make(PAIR,x,y) +#define tcons(x,y) make(TCONS,x,y) +#define tries(x,y) make(TRIES,x,y) +#define label(x,y) make(LABEL,x,y) +#define show(x,y) make(SHOW,x,y) +#define readvals(x,y) make(STARTREADVALS,x,y) +#define ap(x,y) make(AP,(word)(x),(word)(y)) +#define ap2(x,y,z) ap(ap(x,y),z) +#define ap3(w,x,y,z) ap(ap2(w,x,y),z) + +/* data abstractions for local definitions (as in LET, LETREC) */ +#define defn(x,t,y) cons(x,cons(t,y)) +#define dlhs(d) hd[d] +#define dtyp(d) hd[tl[d]] +#define dval(d) tl[tl[d]] + +/* data abstractions for identifiers (see also sto_id() in data.c) */ +#define get_id(x) ((char *)hd[hd[hd[x]]]) +#define id_who(x) tl[hd[hd[x]]] +#define id_type(x) tl[hd[x]] +#define id_val(x) tl[x] +#define isconstructor(x) (tag[x]==ID&&isconstrname(get_id(x))) +#define isvariable(x) (tag[x]==ID&&!isconstrname(get_id(x))) +/* the who field contains NIL (for a name that is totally undefined) +hereinfo for a name that has been defined or specified and +cons(aka,hereinfo) for a name that has been aliased, where aka +is of the form datapair(oldn,0) oldn being a string */ +char *getaka(); +/* returns true name of an identifier, even after aliasing (data.c) */ + +/* data abstractions for private names +see also reset_pns(), make_pn(), sto_pn() in lex.c */ +#define get_pn(x) hd[x] +#define pn_val(x) tl[x] + +#define the_val(x) tl[x] +/* works for both pnames and ids */ + +extern int compiling,polyshowerror; +word *hd,*tl; +char *tag; +char *getstring(); +double get_dbl(word); +void dieclean(void); +#include <unistd.h> /* execl */ +#include <stdlib.h> /* malloc, calloc, realloc, getenv */ +#include <limits.h> /* MAX_DBL */ +#include <stdio.h> +#include <signal.h> +typedef void (*sighandler)(); +#include <math.h> +#include <ctype.h> +#include <string.h> +#define index(s,c) strchr(s,c) +#define rindex(s,c) strrchr(s,c) +#if IBMRISC | sparc7 +union wait { word w_status; }; +#else +#include <sys/wait.h> +#endif +#define END 0 + /* YACC requires endmarker to be zero or -ve */ +#define GENERATOR 0 +#define GUARD 1 +#define REPEAT 2 +#define is(s) (strcmp(dicp,s)==0) +extern word idsused; + +#define BUFSIZE 1024 +/* limit on length of shell commands (for /e, !, System) */ +#define pnlim 1024 +/* limit on length of pathnames */ +word files; /* a cons list of elements, each of which is of the form + cons(cons(fileinfo(filename,mtime),share),definienda) + where share (=0,1) says if repeated instances are shareable. + Current script at the front followed by subsidiary files + due to %insert and %include -- elements due to %insert have + NIL definienda (they are attributed to the inserting script) + */ +word current_file; /*pointer to current element of `files' during compilation*/ +#define make_fil(name,time,share,defs) cons(cons(fileinfo(name,time),\ +cons(share,NIL)),defs) +#define get_fil(fil) ((char *)hd[hd[hd[fil]]]) +#define fil_time(fil) tl[hd[hd[fil]]] +#define fil_share(fil) hd[tl[hd[fil]]] +#define fil_inodev(fil) tl[tl[hd[fil]]] +/* leave a NIL as placeholder here - filled in by mkincludes */ +#define fil_defs(fil) tl[fil] + +#define addtoenv(x) fil_defs(hd[files])=cons(x,fil_defs(hd[files])) +extern word lastexp; + +/* representation of types */ +#define undef_t 0 +#define bool_t 1 +#define num_t 2 +#define char_t 3 +#define list_t 4 +#define comma_t 5 +#define arrow_t 6 +#define void_t 7 +#define wrong_t 8 +#define bind_t 9 +#define type_t 10 +#define strict_t 11 +#define alias_t 12 +#define new_t 13 +#define isarrow_t(t) (tag[t]==AP&&tag[hd[t]]==AP&&hd[hd[t]]==arrow_t) +#define iscomma_t(t) (tag[t]==AP&&tag[hd[t]]==AP&&hd[hd[t]]==comma_t) +#define islist_t(t) (tag[t]==AP&&hd[t]==list_t) +#define isvar_t(t) (tag[t]==TVAR) +#define iscompound_t(t) (tag[t]==AP) +/* NOTES: +user defined types are represented by Miranda identifiers (of type "type"), +generic types (e.g. "**") by Miranda numbers, and compound types are +built up with AP nodes, e.g. "a->b" is represented by 'ap2(arrow_t,a,b)' +Applying bind_t to a type variable, thus: ap(bind_t,tv), indicates that +it is not to be instantiated. Applying strict_t to a type represents the +'!' operator of algebraic type definitions. +*/ +#define hashsize 512 +/* size of hash table for unification algorithm in typechecker */ +#define mktvar(i) make(TVAR,0,i) +#define gettvar(x) (tl[x]) +#define eqtvar(x,y) (tl[x]==tl[y]) +#define hashval(x) (gettvar(x)%hashsize) +/* NB perhaps slightly wasteful to allocate a cell for each tvar, +could be fixed by having unboxed repn for small integers */ + +/* value field of type identifier takes one of the following forms: +cons(cons(arity,showfn),cons(algebraic_t,constructors)) +cons(cons(arity,showfn),cons(synonym_t,rhs)) +cons(cons(arity,showfn),cons(abstract_t,basis)) +cons(cons(arity,showfn),cons(placeholder_t,NIL)) +cons(cons(arity,showfn),cons(free_t,NIL)) +*/ /* suspicion - info field of typeval never used after compilation +- check this later */ +#define make_typ(a,shf,class,info) cons(cons(a,shf),cons(class,info)) +#define t_arity(x) hd[hd[the_val(x)]] +#define t_showfn(x) tl[hd[the_val(x)]] +#define t_class(x) hd[tl[the_val(x)]] +#define t_info(x) tl[tl[the_val(x)]] +#define algebraic_t 0 +#define synonym_t 1 +#define abstract_t 2 +#define placeholder_t 3 +#define free_t 4 + +/* function prototypes - data.c */ +word append1(word,word); +char *charname(word); +void dump_script(word,FILE *); +void gc(void); +void gcpatch(void); +char *getaka(word); +word get_char(word); +word geterrlin(char *); +word get_here(word); +int is_char(word); +word load_script(FILE *,char *,word,word,word); +word make(unsigned char,word,word); +void mallocfail(char *); +int okdump(char *); +void out(FILE *,word); +void out1(FILE *,word); +void out2(FILE *,word); +void outr(FILE *,double); +void resetgcstats(void); +void resetheap(void); +void setdbl(word,double); +void setprefix(char *); +void setupheap(void); +word sto_char(int); +word sto_dbl(double); +word sto_id(char *); +word trueheapsize(void); + +/* function prototypes - reduce.c */ +word head(word); +void initclock(void); +void math_error(char *); +void out_here(FILE *,word,word); +void output(word); +void outstats(void); + +/* function prototypes - trans.c */ +word block(word,word,word); +word codegen(word); +word compzf(word,word,word); +void declare(word,word); +void declconstr(word,word,word); +void decltype(word,word,word,word); +word fallible(word); +word genlhs(word); +void genshfns(void); +word get_ids(word); +word getspecloc(word); +word irrefutable(word); +word lastlink(word); +word memb(word,word); +word mkshow(word,word,word); +void nclashcheck(word,word,word); +word same(word,word); +word sortrel(word); +void specify(word,word,word); +word tclos(word); +word transtypeid(word); + +/* function prototypes - steer.c */ +void acterror(void); +word alfasort(word); +void dieclean(void); +word fixtype(word,word); +word fm_time(char *); /* assumes type word same size as time_t */ +void fpe_error(void); +word parseline(word,FILE *,word); +word process(void); +void readoption(void); +void reset(void); +word reverse(word); +word shunt(word,word); +word size(word); +void syntax(char *); +void yyerror(char *); + +/* function prototypes - types.c */ +word add1(word,word); +void checktypes(void); +word deps(word); +word genlstat_t(void); +word instantiate(word); +word intersection(word,word); +int ispoly(word); +word member(word,word); +word msc(word); +word newadd1(word,word); +void out_pattern(FILE *,word); +void out_type(word); +void printlist(char *,word); +word redtvars(word); +void report_type(word); +void sayhere(word,word); +word setdiff(word,word); +word subsumes(word,word); +void tsetup(void); +word tsort(word); +word type_of(word); +word typesfirst(word); +word UNION(word,word); + +/* function prototype - y.tab.c */ +int yyparse(); + +extern int yychar; /* defined in y.tab.c */ + +/* #include "allexterns" /* check for type consistency */ + +/* end of MISCELLANEOUS DECLARATIONS */ + @@ -0,0 +1 @@ +miralib/ex
\ No newline at end of file @@ -0,0 +1,21 @@ +/* reads a filename from stdin and prints its time-last-modified, + in format [d]d <Month-name> yyyy */ + +#include <stdio.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> +#include <time.h> + +struct stat buf; +struct tm *t; + +char *month[] = {"January","February","March","April","May","June", + "July","August","September","October","November","December"}; +int main() +{ char f[200]; + if(scanf("%s",f)==1&&stat(f,&buf)==0) + t=localtime(&buf.st_mtime), + printf("%d %s %4d\n",(*t).tm_mday,month[(*t).tm_mon],(*t).tm_year+1900); + else fprintf(stderr,"fdate: bad file \"%s\"\n",f); +} diff --git a/gencdecs b/gencdecs new file mode 100755 index 0000000..c7a9ba0 --- /dev/null +++ b/gencdecs @@ -0,0 +1,38 @@ +#! /bin/sh +#shell script for creating combs.h cmbnms.c +#needs to be run if list of combinators changes + +hdr='/* file created by gencdecs - do not edit manually */' + +echo "$hdr" > combs.h +echo "$hdr" > cmbnms.c + +echo 'char *cmbnms[] = {' >> cmbnms.c +i=0 + +for c in S K Y C B CB I HD TL BODY LAST S_p U Uf U_ Ug COND EQ NEQ \ + NEG AND OR NOT APPEND STEP STEPUNTIL GENSEQ MAP ZIP TAKE \ + DROP FLATMAP FILTER FOLDL MERGE FOLDL1 LIST_LAST FOLDR MATCH \ + MATCHINT TRY SUBSCRIPT ATLEAST P B_p C_p S1 B1 C1 ITERATE \ + ITERATE1 SEQ FORCE MINUS PLUS TIMES INTDIV FDIV MOD GR GRE \ + POWER CODE DECODE LENGTH ARCTAN_FN EXP_FN ENTIER_FN LOG_FN \ + LOG10_FN SIN_FN COS_FN SQRT_FN FILEMODE FILESTAT GETENV EXEC WAIT \ + INTEGER SHOWNUM SHOWHEX SHOWOCT SHOWSCALED SHOWFLOAT NUMVAL STARTREAD \ + STARTREADBIN NB_STARTREAD READVALS NB_READ READ READBIN GETARGS Ush Ush1 KI \ + G_ERROR G_ALT G_OPT G_STAR G_FBSTAR G_SYMB G_ANY G_SUCHTHAT \ + G_END G_STATE G_SEQ G_RULE G_UNIT G_ZERO G_CLOSE G_COUNT \ + LEX_RPT LEX_RPT1 LEX_TRY LEX_TRY_ LEX_TRY1 LEX_TRY1_ DESTREV \ + LEX_COUNT LEX_COUNT0 LEX_FAIL LEX_STRING LEX_CLASS LEX_CHAR \ + LEX_DOT LEX_SEQ LEX_OR LEX_RCONTEXT LEX_STAR LEX_OPT \ + MKSTRICT BADCASE CONFERROR ERROR FAIL False True NIL NILS UNDEF +do + echo "#define $c (CMBASE+$i)" >> combs.h + i=`expr $i + 1` + echo \"$c\"\, >> cmbnms.c +done + +echo "#define ATOMLIMIT (CMBASE+$i)" >> combs.h +echo '0};' >> cmbnms.c + +#./.nextxversion +#changing .xversion causes old .x files to be discarded as obsolete diff --git a/hostinfo b/hostinfo new file mode 100755 index 0000000..ff1c433 --- /dev/null +++ b/hostinfo @@ -0,0 +1,5 @@ +echo host: `uname -m` `uname -s` `uname -r` +fil=/tmp/hostinfo$$ +gcc -v 2> $fil +tail -1 $fil +rm $fil @@ -0,0 +1,130 @@ +.TH JUST 1 +.UC 4 +.SH NAME +just \- text justification program +.SH SYNOPSIS +.nf +just [-<width>] [-t<tolerance>] [file...] +.SH DESCRIPTION +.I Just +takes one or more files containing text and justifies them to a specified +width, sending the result to standard output. +Default <width> is 72. (The default can be changed by creating a file +in the current directory called ".justwidth" and containing a number.) +If no files are given +.I just +takes its data from standard input. Thus either of the following commands +show the simplest use of +.I just +.PP +just oldtext > newtext +.br +just < oldtext > newtext +.PP +This is a simple text formatting program, designed for situations +where the more complex facilities of +.I nroff +or +.I troff +are not required. +It formats according to the following rules: +.PP +1) blank lines remain blank. +.br +2) if a line begins with spaces, these are preserved and it is not +merged with the previous one. +.br +3) lines which begin with 8 or more spaces (equiv one tab), +or which have a '>' sign in column 1, have their layout frozen completely. +.PP +Otherwise each line is merged with the previous line and reformatted so +as to maximise the number of words in the line and then justify it to the +specified width. During reformatting the following two extra rules are +observed: +.PP +(a) Between any of the sentence +terminators '.', '?', '!', and a following word on the same line, +a minimum of +two spaces will be preserved if present in the original text. +.PP +(b) Justification (i.e. padding out to the exact width) +is not performed on a line when +it would require the insertion of more than +.I <tolerance> +extra spaces in any one place. This rule is added to make +.I just +behave sensibly when formatting to a width allowing only a small +number of words per line, eg for a newspaper column. +The default tolerance is 3. +.PP +These rules +are quite well adapted to the conventions of normal English text, and +enable +.I just +to be used to format letters, and a variety of simple documents. +Rule (3) provides two conventions whereby fragments of program, tables etc, +can be embedded in such documents and protected from reformatting. +Note that +.I just +can safely be applied to its own output, eg to reformat to different widths. +(Reapplying +.I just +with the same width will leave the text unchanged.) +.PP +.I Just +removes tabs from lines which it is reformatting, replacing them by +spaces. (But tabs in frozen lines will be left alone.) +.PP +.I Just +knows about underlining (in the style "underline-backspace-character...") +and handles underlined words and sentences correctly. +When preparing text which is to be continuously underlined across wordbreaks, +each non-final line of underlined input should have a trailing +underlined space. +.PP +Setting <tolerance> to zero, as in +`just -t0' will cause reformatting without justification. Specifying a +negative width also has this effect. That is `just --72' means +`just -72 -t0'. +.SH SEE ALSO +vi(1) +.br +fmt(1) - the advantages of just +over fmt are that it can format to different widths +(fmt is fixed at 72), that it does justification, and that it knows about +underlining. Like fmt, just +is conveniently called from inside vi, by using the `!' command. + +Examples, of using +.I just +inside +.I vi: +To reformat a paragraph, position the +cursor at, or just above, the beginning of the paragraph, and say +.br +!}just +.br +To reformat the whole document say +.br +:1,$!just +.br +These are standard applications of the vi `!' command, which pipes +pieces of text through an arbitrary UNIX command called from inside +the editor - see vi documentation for more information.) +.SH BUGS +When preparing input text, you have to remember to leave at least one +space at the front of each line which is not preceded by a blank line +and which you +.I don't +want merged with the previous line, e.g. successive lines of an address. +Note that this means that +.I just +cannot be used to reformat a paragraph all of whose lines are indented. +(This is the one respect in which +.I fmt +is superior to +.I just.) +.SH AUTHOR +Research Software Limited. +.I Just +is included in the distribution file for Miranda(tm). @@ -0,0 +1,295 @@ +/* program for text justification */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +/* usage: just [-<width>] [-t<tolerance>] [file...] + if no files given uses standard input. Default width is 72. + 1) blank lines remain blank. + 2) if a line begins with blanks, these are preserved and it is not + merged with the previous one. + 3) lines which begin with more than THRESHOLD (currently 7) spaces + or have a '>' in column 1, have their layout frozen. + otherwise each line is merged with the following lines and reformatted so + as to maximise the number of words in the line and justify it to the + specified width. Justification is not performed on a line however if + it would require the insertion of more than tolerance (default 3) + extra spaces in any one place. +*/ + +/* now handles tabs ok - if you change THRESHOLD, see warning in getln */ + +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> +#define MAXBUF 3600 +#define MAXWIDTH 2400 +#define THRESHOLD 7 +int tolerance=3; + /* the largest insert of extra spaces we are willing to tolerate + in one place */ + +main(argc,argv) +int argc; +char *argv[]; +{ int width=72; + FILE *j_in=fopen(".justwidth","r"); + if(j_in){ if(fscanf(j_in,"%d",&width)!=1)width=72; + fclose(j_in); } + while(argc>1&&argv[1][0]=='-') + if(argv[1][1]=='t'&&isdigit(argv[1][2])) + { sscanf(argv[1]+2,"%d",&tolerance); + argc--; argv++; + }else + if(isdigit(argv[1][1])||argv[1][1]=='-'&&isdigit(argv[1][2])) + { sscanf(argv[1]+1,"%d",&width); + argc--; argv++; + } + else fprintf(stderr,"just: unknown flag %s\n",argv[1]),exit(1); + if(width<0)width = -width, tolerance=0; + if(width==0)width=MAXWIDTH, tolerance=0; + if(width<6||width>MAXWIDTH) + { fprintf(stderr,"just: silly width %d\n",width); + fprintf(stderr,"(legal widths are in the range 6 to %d)\n",MAXWIDTH); + exit(1); + } + if(argc==1)justify(width,stdin,"input"); else + while(--argc>0) + { FILE *fp=fopen(*++argv,"r"); + if(fp==NULL) + { fprintf(stderr,"just: cannot open %s\n",*argv); + break; + } + else justify(width,fp,*argv); + } + exit(0); +} + +static char buf[MAXBUF+2],*bp=buf; + +#include <string.h> +#define index(s,c) strchr(s,c) + +int linerr=0; + +justify(width,fp,fn) +int width; +FILE *fp; +char *fn; +{ int c=' '; /* c initialised to anything != EOF */ + int worderr=0,w; + /*if(fp==stdin)setbuf(fp,NULL); /* to fix weird bug when "just" used in + pipeline - DT 15/1/85 */ + /* note - above has disastrous effect on system time used, for large + inputs, therefore switched off 19/2/87 - fortunately bug seems to be + fixed in 4.2 BSD */ + linerr=0; + while(c!=EOF&&(c=getc(fp))!=EOF) + /* 1st part of test needed because ungetc(EOF,fp) ineffective */ + if(c=='\f')putchar('\f');else /* formfeed counts as blank line */ + { ungetc(c,fp); + getln(fp,0); + if(bp==buf||buf[0]=='>'||indent(buf)>THRESHOLD) /* blank or frozen line */ + { puts(bp=buf); continue; } + /*otherwise perform justification up to next indented,blank or frozen line*/ + squeeze(buf); + while(bp-buf>(w=width+bs_cor(buf))||!isspace(c=peek(fp))&&c!=EOF&&c!='>') + if(bp-buf<=w/*idth+bs_cor(buf)*/) + { pad(); getln(fp,1); } + else{ /* cut off as much as you can use */ + char *rp = &buf[width]; + { char *sp=index(buf,'\b'); /* correction for backspaces */ + while(sp&&sp<=rp)rp += 2, sp=index(sp+1,'\b'); } + while(*rp!=' ' && rp>buf)rp--; /* searching for word break */ + if(rp==buf) + { worderr=1; + while(rp-buf<width-1)putchar(*rp++); /* print width-1 chars */ + putchar('-'); /* to signify forced word break */ + putchar('\n'); + } + else { while(rp[-1]==' '||rp[-1]=='\b'&&rp[-2]=='_') + rp -= rp[-1]==' '?1:2; /* find start of break */ + if(*rp=='_'&&rp[1]=='\b'&&rp[2]==' ')rp += 2; + /* leave trace of underlined gap */ + while((*rp==' ' + ||*rp=='_'&&rp[1]=='\b'&&rp[2]==' ' + ||*rp=='\b'&&rp[1]==' ') + &&rp<bp)*rp++ = '\0'; /* find end of break */ + rjust(buf,width); + } + /* shuffle down what's left */ + strcpy(buf,rp); + bp -= rp-buf; + } + puts(bp=buf); + } + if(worderr) + fprintf(stderr, + "just: warning -- %s contained words too big for line\n",fn); + if(linerr) + fprintf(stderr, + "just: warning -- %s contained disastrously long lines\n",fn); +} + +getln(fp,crush) +FILE *fp; +int crush; +{ char *lose=fgets(bp,MAXBUF-MAXWIDTH+(buf-bp),fp); + if(index(bp,'\t')&&indent(bp)<=THRESHOLD&&bp[0]!='>') + { /* line contains tabs and is not frozen */ + char *p; + while(p=index(bp,'\t'))*p=' '; /* replace each tab by one space */ + /* WARNING - if THRESHOLD:=8 or greater, will need to change this to + handle leading tabs more carefully, expanding each to right number + of spaces, to preserve indentation */ + /* at the moment, however, any line containing tabs in its indentation + will be frozen anyway */ + } + bp += strlen(bp); + if(bp[-1]=='\n')*--bp='\0'; + else + { /* amendment to cope with arbitrarily long input lines: + if no newline found, break at next beginning-of-word */ + int c; + while((c=getc(fp))!=EOF&&!isspace(c)&&bp-buf<MAXBUF)*bp++ = c; + if(c==EOF||c=='\n')*bp='\0'; else + if(bp-buf==MAXBUF) /* give up! */ + { linerr = 1; + *bp++ = '\\'; /* to signify forced break */ + *bp = '\0'; } else + { *bp++ = ' '; + while((c=getc(fp))==' '||c=='\t'); + if(c!=EOF&&c!='\n')ungetc(c,fp); + *bp = '\0'; } + } + /* remove trailing blanks */ + while(bp[-1]==' '&&!(bp[-2]=='\b'&&bp[-3]=='_'))*--bp='\0'; + /* eliminate all but one underlined trailing space */ + if(crush) + while(bp[-1]==' '&&bp[-2]=='\b'&&bp[-3]=='_'&& + bp[-4]==' '&&bp[-5]=='\b'&&bp[-6]=='_')bp -= 3,*bp='\0'; + if(crush) + squeeze(buf); +} + +indent(s) /* size of white space at front of s */ +char *s; +{ int i=0; + while(*s==' '||*s=='\t') + if(*s++ == ' ')i++; + else i = 8*(1+i/8); + return(i); +} + +#define istermch(c) ((c)=='.'||(c)=='?'||(c)=='!') + +squeeze(s) /* remove superfluous blanks between words */ +char *s; +{ char *t; + int eosen; + /* if(1){ bp=s+strlen(s); return; } /* temporary measure to isolate bugs */ + t = s = s + indent(s); + for(;;) + { while(*t&&*t!=' '&&!(*t=='_'&&t[1]=='\b'&&t[2]==' '))*s++ = *t++; + eosen= istermch(t[-1]); + *s++ = *t; + if(*t=='\0')break; + if(*t==' ') + { if(eosen&&t[1]==' ')*s++ = ' '; /* upto one extra space after + sentence terminator is preserved */ + while(*++t==' '); /* eat unnecessary spaces */ } + else + { /* deal with underlined spaces */ + *s++ = '\b'; *s++ = ' '; + if(eosen&&t[3]=='_'&&t[4]=='\b'&&t[5]==' ') + *s++ = '_', *s++ = '\b', *s++ = ' '; /* xta space after termch */ + t += 3; + while(t[0]=='_'&&t[1]=='\b'&&t[2]==' ')t += 3; } + } + bp=s-1; +} + +peek(fp) +FILE *fp; +{ int c=getc(fp); + ungetc(c,fp); + return(c); +} + +rjust(s,width) /* print s justified to width */ +char *s; +int width; +{ int gap=width-strlen(s)+bs_cor(s),wc=words(s)-1; + int i,r; + static leftist=0; /* bias for odd spaces when r>0 */ + char *printword(); + if(wc)i=gap/wc,r=gap%wc; + if(wc==0||i+(r>0)>tolerance){char *t=s+strlen(s); + fputs(s,stdout); + if(t[-1]=='\b'&&t[-2]=='_')putchar(' '); + putchar('\n'); + return;}else + if(leftist) + for(;;) + { s=printword(s); + if(!*s)break; + spaces(i+(r-- >0),s[0]=='_'&&s[1]=='\b'&&s[2]==' '); + } + else + { r = wc-r; + for(;;) + { s=printword(s); + if(!*s)break; + spaces(i+(r-- <=0),s[0]=='_'&&s[1]=='\b'&&s[2]==' '); + } + } + leftist = !leftist; + putchar('\n'); +} + +pad() /* insert space(s) if necessary when joining two lines */ +{ if(bp[-1]!=' ')*bp++ = ' '; + if(istermch(bp[-2]))*bp++ = ' '; else + if(bp[-1]==' '&&bp[-2]=='\b'&&bp[-3]=='_' + &&istermch(bp[-4]))*bp++ = '_', *bp++ = '\b', *bp++ = ' '; +} + +spaces(n,ul) +int n,ul; +{ while(n--)if(ul)printf("_\b "); + else putchar(' '); +} + +words(s) /* counts words (naively defined) in s */ +char *s; +{ int c=0; + while(*s) + if(*s++!=' '&&s[-1]!='\b'&&(*s==' '|| *s=='_'&&s[1]=='\b'&&s[2]==' '))c++; + return(c+1); +} + +char *printword(s) /* prints a word preceded by any leading spaces and + returns remainder of s */ +char *s; +{ while(s[0]=='_'&&s[1]=='\b'&&s[2]==' ') /* underlined spaces */ + putchar(*s++),putchar(*s++),putchar(*s++); + while(*s==' ')putchar(*s++); + while(*s&&*s!=' '&&!(*s=='_'&&s[1]=='\b'&&(s[2]==' '||s[2]=='\0'))) + putchar(*s++); + if(s[0]=='_'&&s[1]=='\b'&&s[2]=='\0')s++,s++,printf("_\b "); + /* restore trailing underlined space */ + return(s); +} + +bs_cor(s) /* correction to length due to backspaces in string s */ +char *s; +{ int n=0; + while(*s++)if(s[-1]=='\b')n += 2; + if(s[-1]=='\0'&&s[-2]=='\b'&&s[-3]=='_')n--; /* implied space before \0 */ + return(n); +} @@ -0,0 +1,1220 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "lex.h" +#include "big.h" +#include <errno.h> + +static int charclass(void); +static void chblank(char *); +static int collectstars(void); +static word directive(void); +static void hexnumeral(void); +static int identifier(int); +static void kollect(int(*f)()); +static void numeral(void); +static void octnumeral(void); +static int peekch(void); +static int peekdig(void); +static void string(void); + +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(); + +void 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 causes 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() + +void 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 int 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; + +void spaces(n) +word n; +{ while(n-- >0)putchar(' '); +} + +int litname(s) +char *s; +{ word n=strlen(s); + return(n>=6 && strcmp(s+n-6,".lit.m")==0); +} + +int 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); } + +int blankerr=0; + +void 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 */ + +int rawch; +/* it is often important to know, when certain characters are returned (e.g. + quotes and newlines) whether they were escaped or literal */ + +int errch; /* for reporting unrecognised \escape */ + +int getlitch() +{ extern int UTF8; + int 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)) + { int value, N=ch=='x'?4:6; /* N=7 for Haskell escape rules */ + char hold[8]; + ch = c; + int 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 steer.c */ +{ 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); } + +void 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" */ + +void unsetlmargin() +{ if(margstack==NIL)return; /* in case called after `syntax("..")' */ + lmargin= hd[margstack]; + margstack= tl[margstack]; } + +int okulid(int); +int PREL=1; + +void 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(); } + +word 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 */ + isalpha(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 ('\\%lu\')\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(isalpha(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 */ + isalpha(c)) + { int 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') + { int 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); +}} + +void 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; } +} + +int collectstars() +{ int n=2; + while(c=='*')c=getch(),n++; + yylval= mktvar(n); + return(TYPEVAR); +} + +word gvars=NIL; /* list of grammar variables - no need to reset */ + +word 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; + +word 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]); +} + +int ARGC; +char **ARGV; /* initialised in main(), see steer.c */ + +word 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); +} + +word 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 */ + +int okpath(ch) +int 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 */ + +void 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. +*/ + +int peekdig() +{ int ch = getc(s_in); + ungetc(ch,s_in); + return('0'<=ch&&ch<='9'); +} + +int peekch() +{ word ch = getc(s_in); + ungetc(ch,s_in); + return(ch); +} + +int 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); +} + +int identifier(s) /* recognises reserved words */ +int 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 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 { int 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=%ld)\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); +} + +int okid(ch) +int ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch=='\''); } + +int okulid(ch) +int ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch==''||ch=='\''); } + +void kollect(f) +/* note top of dictionary used as work space to collect current token */ +int (*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); +} + +void dic_check() /* called from REDUCE */ +{ ovflocheck; } + +void 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; } + *dicq = '\n'; + sscanf(dicp,"%lf",&r); + yylval= sto_dbl(r); } +} + +void hexnumeral() /* added 21.11.2013 */ +{ 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); +} + +void octnumeral() /* added 21.11.2013 */ +{ 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 */ + +int hash(s) /* returns a value in {0..127} */ +char *s; +{ int h = *s; + if(h)while(*++s)h ^= *s; /* guard necessary to deal with s empty */ + return(h&127); +} + +int isconstrname(s) +char *s; +{ if(s[0]=='$')s++; + return isupper(*s); /* formerly !islower */ +} + +word 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()); +} + +int isnonterminal(x) +word x; +{ char *n; + if(tag[x]!=ID)return(0); + n = get_id(x); + return(n[strlen(n)-1]==' '); +} + +word 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 */ + +int inprelude=1; + +word 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); } + +word 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 */ + +void reset_pns() /* (re)initialise private name space */ +{ nextpn=0; + if(!pnvec) + { pnvec=(word *)malloc(pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } +} + +word 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++]); +} + +word 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]); +} + +void 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; + +void 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(); } +} + +int 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); +} + +void 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 %ld 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(); +} + +void 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 */ + @@ -0,0 +1,30 @@ +char *addextn(word,char*); +void adjust_prefix(char*); +word conv_args(void); +void dic_check(void); +void dicovflo(void); +word findid(char*); +word getfname(word); +int hash(char*); +int isconstrname(char*); +char *keep(char*); +void layout(void); +word make_id(char*); +word make_pn(word); +word mkgvar(word); +word mklexvar(word); +void mkprivate(word); +word name(void); +int okid(int); +int openfile(char*); +char *rdline(void); +void reset_lex(void); +void reset_pns(void); +void reset_state(void); +void setlmargin(void); +void setupdic(void); +word sto_pn(word); +word str_conv(char*); +char *token(void); +void unsetlmargin(void); +word yylex(void); diff --git a/linkmenudriver b/linkmenudriver new file mode 100755 index 0000000..4c832be --- /dev/null +++ b/linkmenudriver @@ -0,0 +1,7 @@ +#!/bin/sh +rm -f miralib/menudriver +if test -z "`echo -n`" -o ! \( -x /bin/csh -o -x /usr/bin/csh \) +then ln -s menudriver.sh miralib/menudriver +else ln -s menudriver.csh miralib/menudriver +fi +echo `ls -l miralib/menudriver` diff --git a/menudriver.c b/menudriver.c new file mode 100644 index 0000000..0a0847b --- /dev/null +++ b/menudriver.c @@ -0,0 +1,320 @@ +/* general purpose menu driver */ +/* alternatively there is an equivalent shell script, menudriver.sh */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include <stdio.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> +#include <sys/wait.h> +#include <signal.h> +typedef void (*sighandler)(); +#define pnlim 1024 +struct stat buf; + +char *menuviewer; +char *viewer="less"; +/* +#ifdef UWIN + "more -ne"; +#else + "more -d"; +#endif */ + +#define VIEWERPAUSESATEND . +/* this modifies default behaviour of menudriver to return straight to menu + after displaying section, to avoid two layers of prompt; + choice can be overriden by environment variable RETURNTOMENU=YES/NO */ + +#ifdef VIEWERPAUSESATEND +int fastback=1; +#else +int fastback=0; +#endif + +void callshell(char[]); +void clrscr(void); +void menudrive(char*); +void pushlast(void); +void poplast(void); +void settings(void); +void singleton(char*); +int subdir(void); + +char next[40]="",cmd[80],last[40]="."; +int val, ok=0; + +#include <string.h> +#define index(s,c) strchr(s,c) + +int main(argc,argv) +int argc; +char *argv[]; +{ char *v=getenv("VIEWER"),*fb=getenv("RETURNTOMENU"); + menuviewer=getenv("MENUVIEWER"); + if(argc>2)fprintf(stderr,"menudriver: wrong number of args\n"),exit(1); +/* +#ifdef VIEWERPAUSESATEND */ + if(!menuviewer)menuviewer="cat"; +/* +#else + if(!menuviewer)menuviewer=viewer; +#endif */ + if(v)viewer=v; + if(fb)fastback=!(*fb=='N'||*fb=='n'); +#ifdef CURSES + setupterm(0,1,&ok); + if(ok!=1)fprintf(stderr,"warning: cannot find terminfo entry\n"); +#endif + menudrive(argc==1?".":argv[1]); } + +int lastval() /* checks if last is a number (and if so leaves value in val) */ +{ if(strcmp(last,".")==0&&subdir()) + /* special case, have just entered subdir */ + { poplast(); + if(sscanf(last,"%d",&val)==1) + { chdir(".."); return(1); } + pushlast(); return(0); } + return(sscanf(last,"%d",&val)==1); +} + +void menudrive(dir) +char *dir; +{ char *np;int c,bad=0; + if(chdir(dir)==-1)singleton(dir); /* apparently not a directory */ + while(stat("contents",&buf)==0) + { if(next[0]=='\0'||bad) + { clrscr(); + /* invalid selection notified here, after clearing screen */ + if(bad) + { if(strcmp(next,".")==0) + printf("no previous selection to substitute for \".\"\n"); + else printf("selection \"%s\" not valid\n",next); + bad=0; } + strcpy(cmd,menuviewer); + strcat(cmd," "); + strcat(cmd,"contents"); + system(cmd); + printf("::please type selection number (or return to exit):"); + /* read remainder of line into next, less leading white space */ + np=next; c=getchar(); + while(c==' '||c=='\t')c=getchar(); + while(c!='\n'&&c!=EOF)*np++=c,c=getchar(); + if(c==EOF)exit(0); + /* remove trailing white space */ + if(next[0]!='!')while(np[-1]==' '||np[-1]=='\t')np--; + *np='\0'; } + if(next[0]=='\0'){ chdir(".."); poplast(); continue; } + if(strcmp(next,".")==0)strcpy(next,last); /* repeat last option */ + if(strcmp(next,"+")==0&&lastval())(void)sprintf(next,"%d",val+1); + if(strcmp(next,"-")==0&&lastval())(void)sprintf(next,"%d",val-1); + if(stat(next,&buf)==0) + { if(strcmp(next,".")==0||strcmp(next,"..")==0||index(next,'/')) + { bad=1; continue; } /* no pathnames - see below */ + if(S_ISDIR(buf.st_mode)) /* directory */ + { char hold[pnlim]; + if(!getcwd(hold,pnlim)) + fprintf(stderr,"panic: cwd too long\n"),exit(1); + if(chdir(next)==-1||stat("contents",&buf)) + bad=1,chdir(hold); + else strcpy(last,next),pushlast(),next[0]='\0'; } else + if(S_ISREG(buf.st_mode)) /* regular file */ + { clrscr(); +#ifndef UWIN + if(buf.st_mode&S_IXUSR) /* executable (by owner) */ +#else + if(strcmp(next,"99")==0) +#endif + { strcpy(cmd,"./"); + strcat(cmd,next); + system(cmd); + if(fastback) + { printf("[Hit return to continue]"); + while(getchar()!='\n'); + } + } else + { strcpy(cmd,viewer); + strcat(cmd," "); + strcat(cmd,next); + system(cmd); } + if(fastback) + { strcpy(last,next); + next[0]='\0'; + } + else + { printf( + "::next selection (or return to go back to menu, or q to quit):" + ); + /* read remainder of line into next, less leading white space */ + strcpy(last,next); + np=next; c=getchar(); + while(c==' '||c=='\t')c=getchar(); + while(c!='\n'&&c!=EOF)*np++=c,c=getchar(); + if(c==EOF)exit(0); + /* remove trailing white space */ + if(next[0]!='!')while(np[-1]==' '||np[-1]=='\t')np--; + *np='\0'; + } + } } else + if(strcmp(next,"???")==0) /* ask to see menudriver settings */ + { settings(); + printf("[Hit return to continue]"); + while(getchar()!='\n'); + next[0]='\0'; + } else + if(strcmp(next,"q")==0||strcmp(next,"/q")==0)exit(0); else + if(next[0]=='!') /* shell escape - handy for editing manual! */ + { static char syscm[80]; + if(next[1]=='\0'||next[1]=='!') + if(syscm[0]) + { if(next[1]=='!')strcat(syscm,next+2); + printf("!%s\n",syscm); } + else + printf("no previous shell command to substitute for \"!\"\n"); + else strcpy(syscm,next+1); + if(syscm[0])callshell(syscm); /* `system' always gets /bin/sh */ + printf("[Hit return to continue]"); + while(getchar()!='\n'); + next[0]='\0'; } + else bad=1; + } +} +/* possibly a bug - can retreat above original dir, if parent contains a + "contents" file - difficult to detect this in a general way, however */ +/* pathnames banned because + (i) upward pathname will not return correctly if a directory (see above) + (ii) direct selection of a grandchild directory leads to + (a) returns via child, instead of directly + (b) meaning of "." is screwed up while in (a) */ +/* could fix all this by - rewrite handling of subdirectory to hold=getwd() + and exit by chdir(hold) instead of chdir("..") - will need to make this + recursive, or else have stack of holdwd's */ + +void singleton(fil) +char *fil; +{ if(stat(fil,&buf)==0 && S_ISREG(buf.st_mode)) /* regular file */ + { clrscr(); +#ifndef UWIN + if(buf.st_mode&S_IXUSR) /* executable (by owner) */ + { strcpy(cmd,"./"); + strcat(cmd,fil); + system(cmd); + fastback=0; } else +#endif + { strcpy(cmd,viewer); + strcat(cmd," "); + strcat(cmd,fil); + system(cmd); } + if(!fastback) + { printf("[Hit return to continue]"); + while(getchar()!='\n'); } + exit(0); + } + else fprintf(stderr,"menudriver: cannot access \"%s\"\n",fil), + exit(1); +} + +void callshell(v) +char v[]; +{ static char *shell=NULL; + sighandler oldsig; int 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"); + wait(0); + (void)signal(SIGINT,oldsig); } + else execl(shell,shell,"-c",v,(char *)0); +} + +void settings() +{ printf("current values of menudriver internal variables are\n\n"); + printf(" VIEWER=%s\n",viewer); + printf(" MENUVIEWER=%s\n",menuviewer); + printf(" RETURNTOMENU=%s\n",fastback?"YES":"NO"); + printf("\n\ +These can be modified by setting environment variables of the same names\n\n\ +VIEWER is the program used to display individual sections\n\n\ +MENUVIEWER is the program used to display contents pages\n\n\ +RETURNTOMENU=NO/YES causes a second prompt to be given/not given after\n\ +displaying section (ie before returning to contents page). It should be\n\ +`YES' if VIEWER is a program that pauses for input at end of file, or\n\ +`NO' if VIEWER is a program that quits silently at end of file.\n\n"); +} + +/* +Symptoms of a wrong setting are (i) bottom part of manual section\n\ +disappears from screen before you have had a chance to read it - to cure\n\ +this set RETURNTOMENU=NO; or (ii) having to quit through two layers of\n\ +prompt at bottom of a manual section before getting back to the contents\n\ +page - to cure this set RETURNTOMENU=YES;\n\n"); +*/ + +char lastvec[100],*lastp=lastvec+1; +int giveup=0; + +int subdir() +{ return(lastp>lastvec+1); } + +void pushlast() +{ int n=strlen(last); + if(last[0]=='.') + /* pathological cases */ + if(last[1]=='\0')return; else + if(last[1]=='.'&&last[2]=='\0') + { poplast(); return; } + if(lastp+n>lastvec+100) /* overflow */ + { giveup=1; return; } + /*if(strcmp(lastp,last)==0) + lastp+=n+1,strcpy(last,lastp); else /* here we were */ + /* suppressed 'cos interferes with special case in lastval() */ + strcpy(lastp,last),lastp+=n+1,strcpy(last,"."); +} + +void poplast() +{ strcpy(lastp,last); /* just in case we come back immediately */ + lastp--; + if(giveup||lastp<=lastvec)return; /* underflow */ + while(*--lastp); + strcpy(last,++lastp); +} + +#ifndef CURSES + +/* to clear screen */ +void clrscr() +{ printf("\x1b[2J\x1b[H"); fflush(stdout); +} + +#else +/* alternative method needs curses lib, compile with -DCURSES, or -DUWIN + and -lncurses */ + +#ifdef UWIN +#include <ncurses/curses.h> +#include <ncurses/term.h> +#else +#include <curses.h> +#include <term.h> +#endif + +void clrscr() +{ if(ok!=1)return; + putp(clear_screen); + fflush(stdout); +} +/* end of clrscr method using curses */ +#endif + @@ -0,0 +1,272 @@ +.TH MIRA 1 "November 2019" +.SH NAME +mira \- the Miranda(tm) functional programming system +.SH SYNOPSIS +.B mira +[options] +[file] +.fi +.SH DESCRIPTION +Miranda is a functional programming system with lazy evaluation, +polymorphic strong typing and function definition by pattern matching. +.PP +The \fBmira\fP program takes a single argument which is the name of +a file of definitions (called a "script"). If no argument is given a +default name "\fBscript.m\fP" is assumed. The names of files +containing miranda scripts must end in ".m" and \fBmira\fP will +add this if missing. The specified file need not yet exist - in this +case you will be starting a Miranda session with an empty current +script. +.PP +The basic action of the Miranda system is to evaluate expressions in +the environment established by the script, so in its simplest mode of +use it behaves like a desk calculator. Expressions are typed one per +line, terminated by ENTER. +."For example +.".nf +." Miranda \fBproduct [1..40] +." 815915283247897734345611269596115894272000000000\fP +.".fi +."There is a `standard environment' of predefined functions, such as +."product, which are always in scope. +The interpreter also accepts +certain commands (mostly beginning with a `\fB/\fP' character) - these +include \fB/help\fP or \fB/h\fP which prints a summary of the available +commands, and \fB/man\fP or \fB/m\fP which gives access to the online +manual of the Miranda system (menu driven and self explanatory). This +documents all aspects of the Miranda language and system and should be +consulted for further details. It is also possible to access the +Miranda system manual directly from a UNIX shell by the command \fBmira +-man\fP. +.SH OPTIONS +.TP +.B -lib pathname +Specifies location of the miralib directory. For default see \fBFILES\fP. +Can also be done by setting environment variable \fBMIRALIB\fP. The location +of the miralib directory can be interrogated (but not changed) from +within the miranda session by the command `/miralib'. +.TP +.B -gc +Switches on a flag causing the garbage collector to print information +each time a garbage collection takes place. This flag can also be +switched on and off from within the miranda session by the commands +`/gc', `/nogc'. +.TP +.B -count +Switches on a flag causing statistics to be printed after each +expression evaluation. This flag can also be switched on and off from +within the miranda session by the commands `/count', `/nocount'. +.TP +.B -list (-nolist) +Switches on (off) a flag causing Miranda scripts to be listed to the +screen during compilation. This flag can also be switched on and off +from within the miranda session by the commands `/list', `/nolist'. +.TP +.B -nostrictif +Enables the compiler to accept old Miranda scripts with no `\fBif\fP' +after the guard comma. +.TP +.B -hush (-nohush) +The miranda system decides whether or not to give prompts and other +feedback by testing its standard input with `isatty'. If the standard +input does not appear to be a terminal it assumes that prompts would be +inappropriate, otherwise it gives them. In either case this behaviour +can be overriden by an explicit flag ("-hush" for silence, "-nohush" for +prompts etc). This switch is also available from within a miranda +session by the commands `/hush', `/nohush'. +.TP +.B -dic SIZE +Causes the dictionary, used by the compiler to store identifiers etc., +to be SIZE bytes (default 100k). This can be interrogated (but not changed) +from within the miranda session by the command `/dic'. +.TP +.B -heap SIZE +Causes the heap to be SIZE cells (default 2500k). This can +changed within the miranda session by the command `/heap SIZE'. +A cell is 9 bytes (2 words of 32 bits, and a tag field). +.TP +.B -editor prog +Causes the resident editor (usual default `\fBvi\fP') to be \fBprog\fP +instead. This can also be done from within the miranda session by the +command \fB/editor prog\fP. Any occurrences of \fB!\fP and \fB%\fP in +\fBprog\fP will be replaced by the line number and the name of the file +to be edited, respectively. For more detailed discussion see online manual +subsection 31/5. +.TP +.B -UTF-8 (-noUTF-8) +Assume the current locale is (is not) UTF-8 overriding environment vars +(version 2.044 and later). +.TP +.B -stdenv +Run mira without loading the standard environment. Any script needing +functions from <stdenv> will then have to explicitly %include <stdenv>, +or define the required functions itself. Not recommended as normal +practise and may have unexpected consequences. +.TP +.B -object +Used for debugging the compiler. Modifies the behaviour of ?identifier(s) +to show the associated combinator code, which may or may not be comprehensible +as there is no documentation other than the source code. +.SH SPECIAL CALLS +The following special calls to \fBmira\fP do not start a Miranda session +but accomplish another purpose. +.TP +.B mira -man +Enter Miranda online manual from the UNIX shell. From within a +Miranda session this is done by the command `/man' or `/m'. +.TP +.B mira -version +Prints version information. This information can be obtained +within a Miranda session by the command `/version' or `/v'. +.TP +.B mira -V +More detailed version information. Can be obtained within a Miranda session +by the command `/V'. +.PP +The remaining special calls are discussed in more detail in the online manual +- we list them here for completeness. +.TP +.B mira -exec +Special call permitting the use of miranda script as a stand-alone +program. See online manual subsection 31/4 for details. +.TP +.B mira -exec2 +As \fB-exec\fP except that it redirects stderr to a log file. +See online manual subsection 31/4 for details. +.PP +These three relate to separate compilation and Miranda's +built in `make' facility. See online manual section 27 (\fBthe library +mechanism\fP):- +.TP +.B mira -make [files] +Checks that all the miranda source files listed have up-to-date .x +(intermediate code) files, triggering compilation processes if necessary. +.TP +.B mira -exports [files] +Sends to stdout a list of the identifiers exported from the given +miranda source files, together with their types (may force compilation +if needed). +.TP +.B mira -sources [files] +Send to stdout a list of all the Miranda source files on which the given +source files directly or indirectly depend (via \fB%include\fP or \fB%insert\fP +statements), excluding the standard environment \fB<stdenv>\fP. +.TP +.B mira -version +Gives version information. This information can also be obtained from +within a Miranda session by the command `/version'. +.TP +.B mira -V +More detailed version information. +.SH ENVIRONMENT +.TP +.B MIRALIB +Specifies the location of the miralib directory. A \fB-lib\fP flag, +if present, overrides this. For default location see \fBFILES\fP. +.TP +.B EDITOR +The first time it is called (i.e. if no .mirarc file is present +in the home directory or in miralib) the miranda system takes +the preferred editor from this environment variable - if +not set `\fBvi\fP' is assumed. Chosen editor can be changed from +within a Miranda session by the command \fB/editor prog\fP. +Any occurrences of \fB!\fP and \fB%\fP in \fBprog\fP will be replaced +by the line number and the name of the file to be edited, respectively. +For more detailed discussion see online manual subsection 31/5. +.TP +.B LC_CTYPE, LANG +At startup (version 2.044 and later) the miranda system inspects \fBLC_TYPE\fP, +or if that is empty \fBLANG\fP, to +determine if it is running in a UTF-8 locale. On Windows/Cygwin this +information is taken from the \fBuser-default ANSI code page\fP. An +explicit \fB-UTF-8\fP or \fB-noUTF-8\fP flag, if present, overrides. +.TP +.B RECHECKMIRA +If this is set to any non-empty string the Miranda system checks to see +if any relevant source file has been updated, and performs any +necessary recompilation, before each interaction with the user. This is +the appropriate behaviour if an editor window is being kept open during +the Miranda session. By default the check is performed only after `\fB/e\fP' +commands and `\fB!\fP' escapes. This can also be controlled from +within a Miranda session by the commands `/recheck', `/norecheck'. +.TP +.B SHELL +Determines what shell is used in `!' escapes. This will normally +contain the name of the user's login shell. If no \fBSHELL\fP is present in +the environment, \fB/bin/sh\fP is assumed. +.TP +.B MIRAPROMPT +Sets a string to be used as session prompt instead of the default prompt +"Miranda " (version 2.044 and later). +.TP +.B NOSTRICTIF +If this is set to any non-empty string Miranda accepts old scripts with no `\fBif\fP' +after the guard comma. Equivalent to calling mira with option +\fB-nostrictif\fP. Deprecated - you should put the `\fBif\fP's in. +.PP +The behaviour of the menudriver program that displays pages of the online +manual can be modified using three environment variables:- +.TP +.B VIEWER +The program used for displaying pages of the online manual. +If this variable is not set the default is +normally `\fBmore -d\fP' or (roughly equivalent) `\fBless -EX\fP'. +If you set \fBVIEWER\fP to something, you may also need to set an environment +variable \fBRETURNTOMENU\fP. +.TP +.B RETURNTOMENU=YES +Prevents another prompt being given after displaying each section, +causing instead an immediate return to contents page. Appropriate if +\fBVIEWER\fP is a program that pauses for input at end of file (e.g. +`\fBless\fP'). It should be `\fBNO\fP' if \fBVIEWER\fP is a program that +quits silently at end of file (e.g. `\fBmore -d\fP', `\fBless -EX\fP'). +.TP +.B MENUVIEWER +Can be used to +specify the program used to display manual contents pages (default is +usually `\fBcat\fP' or `\fBmore\fP'). +.PP +To find the current settings of the online manual enter \fB???\fP +to the "next selection" prompt of the manual system. +.SH FILES +.TP +.B /usr/lib/miralib +A directory containing files which \fBmira\fP needs - by default it +looks for this at \fB/usr/lib/miralib\fP, then \fB/usr/local/lib/miralib\fP, +and lastly at \fB./miralib\fP. If it does not find a miralib of the +same version number as itself in one of these places it exits with a panic +message. This behaviour can be overriden with the \fB-lib\fP option or +by setting the environment variable \fBMIRALIB\fP. +.TP +.B $HOME/.mirarc +Records most recent settings of heap size, dictionary size, editor +and various flags which can be toggled during a session. Written and +read by \fBmira\fP using a peculiar format, not intended to be edited by +humans. The settings can be interrogated within a Miranda session +by the command \fB/settings\fP or \fB/s\fP, and changed by various session +commands (use \fB/aux\fP or \fB/a\fP to list these). The only setting +which cannot be changed in a session is dictionary +size - this is done using the \fB-dic\fP option when mira is invoked. +This rarely needs to be changed, however. +.PP +If a \fB.mirarc\fP is +copied to \fBmiralib/.mirarc\fP the settings it records will be picked +up by new users, who will not yet have their own \fB.mirarc\fP file. This +allows an administrator to change the default settings, e.g. to +have a default editor other than \fBvi\fP. The \fB$HOME/.mirarc\fP +once created will override the global one, however, allowing users +to make individual choices. +.SH SEE ALSO +.PP +.B http://miranda.org.uk +the Miranda home page. +.PP +D.A.Turner \fBAn Overview of Miranda\fP, SIGPLAN Notices, 21(12), December 1986. +A convenient summary of the main features of Miranda. +.PP +\fBMiranda System Manual\fP. Accessed +by \fBmira -man\fP or \fB/man\fP from within a Miranda session. +.SH COPYRIGHT +The Miranda system is Copyright (c) Research Software +Limited 1985-2019. For distribution terms see the file "COPYING" included +in the distribution. diff --git a/miralib/.version b/miralib/.version new file mode 100644 index 0000000..0e21d5e --- /dev/null +++ b/miralib/.version @@ -0,0 +1 @@ +2066 diff --git a/miralib/COPYING b/miralib/COPYING new file mode 100644 index 0000000..2dd23d0 --- /dev/null +++ b/miralib/COPYING @@ -0,0 +1,27 @@ +The Miranda system is Copyright (c) Research Software Limited, +1985-2020 + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + diff --git a/miralib/auxfile b/miralib/auxfile new file mode 100644 index 0000000..f0c3b7f --- /dev/null +++ b/miralib/auxfile @@ -0,0 +1,28 @@ +LIST OF REMAINING COMMANDS: + +/aux /a print this list of auxiliary commands +/cd [dirname] change directory (defaults to home directory) +/count (/nocount) statistics following each evaluation (default off) +/dic report size of dictionary for storing names etc +/editor report name of text editor used by ?? and /e commands +/editor PROG *change resident editor to PROG (see below) +/find id(s) like `?ids' but look under original names of aliases +/gc (/nogc) enable garbage collection reports (default off) +/heap report size of heap +/heap SIZE set heap to SIZE cells +/hush (/nohush) control prompts and other feedback (default on) +/list (/nolist) *control listing of script when compiling (default off) +/miralib report absolute pathname of the directory miralib +/(no)recheck *control busy checking for script updates (default off) +/settings /s print current settings of controllable options +/version /v print version information +/V more detailed version information +||... lines beginning in `||' are ignored (comment facility) + +notes:- +commands marked (*) are sticky, i.e. remembered for subsequent sessions +if you don't like the resident editor choose another - recommended editors +include - vi, joe, pico, nano, emacs - for more info see /man section 31(5) +/recheck enables a check for update of any relevant source file before +each evaluation, instead of only after /e[dit] - appropriate if an +editor window is kept open alongside the mira session window. diff --git a/miralib/ex/README b/miralib/ex/README new file mode 100644 index 0000000..3a68794 --- /dev/null +++ b/miralib/ex/README @@ -0,0 +1,54 @@ +This directory contains a (fairly random) collection of simple scripts +written in Miranda. To try one out (eg fibs.m) say + mira fibs +as a UNIX command - or if you are already inside a Miranda session, say + /f fibs +to make (e.g.) fibs.m your current script. To get into this directory, +while in a Miranda session, say + /cd <ex> + +Each script has some explanatory comments in it. To read the current +script from within a Miranda session say + /e +which invokes the editor on the current script. The scripts are listed +in groups, with some more advanced examples towards the end. The ones +marked (*) may be useful as libraries. + +ack.m the ackermann function +divmodtest.m tests properties of div and mod +fibs.m tabulates fibonacci numbers +hanoi.m solves the problem `towers of hanoi' +powers.m prints a table of powers +primes.m infinite list of prime numbers +pyths.m generates pythagorean triangles + +hamming.m prints hamming numbers +queens.m all solutions to the eight queens problem +queens1.m finds one solution to the eight queens problem +quicksort.m Miranda definition of quicksort +selflines.m curiosity - a self describing scroll of lines +stack.m defines stack as an abstract data type +treesort.m Miranda definition of treesort + +parafs.m Enumerates isomers of alkanes in pictorial form +graphics.m Rectangular graphics package used by parafs.m +keith.m Checks that floating point overflow is trapped +barry.m Math calculations that stress the garbage collector +bigscript.m Tests gc during compilation +makebig.m Creates bigscript.m of any chosen size + +edigits.m infinite decimal expansion of the digits of `e' (literate script) +rational.m package for doing rational arithmetic (*) +refoliate.m a tree problem (literate script) +topsort.m topological sort +matrix.m matrix package (*) +set.m defines set as an abstract data type (*) +kate.lit.m a Miranda script that is also a LaTeX source file + +genmat.m parameterised version of matrix package (*) +just.m text formatting program +mrev (executable) Miranda version of the UNIX `rev' command +box.m (executable) program for reboxing Miranda comments +box symbolic link to box.m +polish.m testbed for unify.m +unify.m package for doing 1st order unification (*) diff --git a/miralib/ex/ack.m b/miralib/ex/ack.m new file mode 100644 index 0000000..8a743eb --- /dev/null +++ b/miralib/ex/ack.m @@ -0,0 +1,9 @@ +||defines ackermann's function, beloved of recursion theorists. Example +|| ack 3 3 +||should yield 61, after doing a huge amount of recursion. Can only be +||called for small arguments, because the values get so big. + +ack 0 n = n+1 +ack (m+1) 0 = ack m 1 +ack (m+1) (n+1) = ack m (ack (m+1) n) +ack m n = error "ack applied to -ve or fractional arg" diff --git a/miralib/ex/barry.m b/miralib/ex/barry.m new file mode 100644 index 0000000..f93af80 --- /dev/null +++ b/miralib/ex/barry.m @@ -0,0 +1,31 @@ +||from Barry Brown, Sierra College -- Aug 2009 +||the critical case is test5, below + +|| Given a number, return the next number in the Collatz sequence +collatz :: num -> num +collatz n = n div 2, if (n mod 2 = 0) + = 3*n+1, if (n mod 2 = 1) + +|| Given a number, return the whole Collatz sequence starting with that +|| number. Note that it does not include the '1' on the end, but that's OK +|| since we're only interested in the length. +collatzseq n = takewhile (>1) (iterate collatz n) + +|| Given a number, return a tuple with the starting number and the +|| length of the Collatz sequence. We'll find the maximum tuple using the +|| next function. The number returned will be 1 less than the actual +|| Collatz sequence length, but that's OK for our purposes. One one of them +|| will be the longest. +collatzpair n = (n, #(collatzseq n)) + +|| Given two tuples, return the greater based on the second term. +maxtuple :: (*,**)->(*,**)->(*,**) +maxtuple x y = x, if (snd x > snd y) + = y, otherwise + + +test1 = map collatzpair [1..9] +test2 = foldr maxtuple (1,0) (map collatzpair [1..9]) +test3 = foldr maxtuple (1,0) (map collatzpair [1..999]) +test4 = foldr maxtuple (1,0) (map collatzpair [1..9999]) +test5 = foldl maxtuple (1,0) (map collatzpair [1..999999]) ||segfaults, ok with foldl diff --git a/miralib/ex/box b/miralib/ex/box new file mode 120000 index 0000000..be14d99 --- /dev/null +++ b/miralib/ex/box @@ -0,0 +1 @@ +box.m
\ No newline at end of file diff --git a/miralib/ex/box.m b/miralib/ex/box.m new file mode 100755 index 0000000..87d404c --- /dev/null +++ b/miralib/ex/box.m @@ -0,0 +1,244 @@ +#! /home/dat/mira/states/src/miranda/mira -exec +|| Contributed by John Cupitt, University of Kent + +||A while ago Steve Hill (I think) appealed for useful Miranda programs +||-- well, here is the greatest productivity aid for Miranda hackers +||since ball-point pens. A 'vi' type filter to *rebox your comments*!! +||Amazing. It turns dull, unexciting notes like: + +|| Given a node in the tree, +||examine the branches and chose the exit with the +|| highest score. + +||into: + +||----------------------------------------------------------------------|| +|| Given a node in the tree, examine the branches and chose the exit || +|| with the highest score. || +||----------------------------------------------------------------------|| + +||Any comments welcome -- my Miranda is not as hot as it could be ... + +||John + +||----------------------------------------------------------------------|| +|| Box up Miranda comments. A filter from stdin to stdout +|| do_box :: [char] -> [char] || +|| - Strip ||s, reformat, rebox. || +||----------------------------------------------------------------------|| + +main = [Stdout (do_box $-)] + +||----------------------------------------------------------------------|| +|| Reboxing done in a pipeline of five stages. || +|| - Split the input into lines || +|| - Strip '||'s from input || +|| - Lex the input, breaking into tokens || +|| - Rejig tokens to produce fmted type output || +|| - Output tokens as [char] with a box drawn around them || +|| Formatting rules: || +|| - Lines starting '||-' are deleted || +|| - Leading & trailing '||' removed || +|| - Lines starting with a tab are not reformatted || +|| - Blank lines are 'new paragraph' || +||----------------------------------------------------------------------|| + +||----------------------------------------------------------------------|| +|| First a few types and useful little functions. || +||----------------------------------------------------------------------|| + +|| Useful constants +outWid = 68 || Width of the text in our boxes +boxWid = 72 || Size of the box we draw + +|| A token +tok ::= Word [char] | Newpara | Line [char] + +|| Useful character classifier +whitespace :: char -> bool +whitespace ch + = True, if ch = '\n' \/ ch = '\t' \/ ch = ' ' + = False, otherwise + +|| An edge of a box boxWid across +edge :: [char] +edge = "||" ++ (rep (boxWid-2) '-') ++ "||\n" + +|| Find the length of a line containing tabs +len :: [char] -> num +len str + = len' 0 str + where + len' n [] + = n + len' n (a:rest) + = len' (n+tab_space) rest, if a = '\t' + = len' (n+1) rest, otherwise + where + tab_space + = 8 - (n mod 8) + +|| Useful when doing output --- only attach first param if its not []. +no_blank :: [char] -> [[char]] -> [[char]] +no_blank a b + = a : b, if a ~= [] + = b, otherwise + +||----------------------------------------------------------------------|| +|| The main function. Call from a shell script in your /bin directory || +|| looking something like: || +|| #! /usr/bin/mira -exec || +|| main = [Stdout (do_box $-)] || +|| %include "../mira/box/box.m" || +||----------------------------------------------------------------------|| + +do_box :: [char] -> [char] +do_box input + = edge ++ rejig input ++ edge + where + rejig = re_box . format . lex_start . strip_start . split + +||----------------------------------------------------------------------|| +|| The first stage in processing. Split the input [char] into lines as || +|| [[char]]. || +||----------------------------------------------------------------------|| + +|| Split the text into a list of lines +split :: [char] -> [[char]] +split input + = split' [] input + where + split' sofar (a:input) + = sofar : split input, if a = '\n' + = split' (sofar ++ [a]) input, otherwise + split' sofar [] + = no_blank sofar [] || No extra blank lines! + +||----------------------------------------------------------------------|| +|| The next stage ... strip old '||'s from the input. Remove: || +|| - Lines starting '||-' || +|| - Strip leading '||'s || +|| - Strip trailing '||'s & trailing spaces || +||----------------------------------------------------------------------|| + +|| At the start of a line: +strip_start :: [[char]] -> [[char]] +strip_start ([]:input) + = [] : strip_start input || Keep blank lines +strip_start (('|':'|':line):input) + = strip_start' line + where + strip_start' ('-':rest) + = strip_start input || Strip '||---||' lines + strip_start' rest + = strip_rest rest input || Strip leading '||' +strip_start (line:input) + = strip_rest line input || Pass rest through +strip_start [] + = [] + +|| Scan along the rest of the line looking for trailing '||'s to strip. +strip_rest :: [char] -> [[char]] -> [[char]] +strip_rest line input + = strip_rest' (rev line) input + where + strip_rest' ('|':'|':rest) input + = strip_rest' rest input || Strip trailing || + strip_rest' (x:rest) input + = strip_rest' rest input, if whitespace x + strip_rest' line input + = (rev line) : strip_start input + +|| Efficient(ish) reverse +rev list + = rev' [] list + where + rev' sofar (a:x) + = rev' (a:sofar) x + rev' sofar [] + = sofar + +||----------------------------------------------------------------------|| +|| The next stage ... Break the input into Word, Newpara and Line || +|| tokens. Newpara for blank lines and line starting with space; Line || +|| for lines starting with a tab. || +||----------------------------------------------------------------------|| + +|| At the start of a line. +lex_start :: [[char]] -> [tok] +lex_start ([]:input) + = Newpara : lex_start input || Preserve blank lines +lex_start (('\t':rest):input) + = Line ('\t':rest) : lex_start input || Don't format tab lines +lex_start (line:input) + = lex_rest (strip_ws line) input || Lex to eol +lex_start [] + = [] + +|| In the middle of a line. Try to take words off the front of what we +|| have so far. +lex_rest :: [char] -> [[char]] -> [tok] +lex_rest [] input + = lex_start input +lex_rest sofar input + = Word wd : lex_rest (strip_ws rest) input + where + (wd, rest) + = break_word sofar + +|| Strip ws from the start of the line +strip_ws (a:input) + = (a:input), if ~whitespace a + = strip_ws input, otherwise +strip_ws [] + = [] + +|| Break the word from the front of a line of text. Return the remains +|| of the line along with the word. +break_word :: [char] -> ([char], [char]) +break_word (a:line) + = ([a] ++ rest, tag), if ~whitespace a + = ([], (a:line)), otherwise + where + (rest, tag) + = break_word line +break_word [] + = ([],[]) + +||----------------------------------------------------------------------|| +|| Almost the last stage ... Turn [tok] back into [[char]]. Format || +|| onto outWid character lines. || +||----------------------------------------------------------------------|| + +format :: [tok] -> [[char]] +format input + = format' [] input + where + format' sofar (Word wd:rest) + = format' (sofar ++ " " ++ wd) rest, if #sofar + #wd < outWid + = sofar : format' (" " ++ wd) rest, otherwise + format' sofar (Newpara:rest) + = no_blank sofar ([] : format rest) + format' sofar (Line line:rest) + = no_blank sofar (line : format rest) + format' sofar [] + = no_blank sofar [] + +||----------------------------------------------------------------------|| +|| The final stage. Box up a list of formatted lines. Try to be clever || +|| about using tabs on the ends of lines. || +||----------------------------------------------------------------------|| + +|| Draw a box boxWid across. +re_box :: [[char]] -> [char] +re_box (line:rest) + = "||" ++ line ++ padding ++ "||\n" ++ (re_box rest) + where + padding + = rep n_tab '\t' + n_tab + = (boxWid - line_length + 7) div 8 + line_length + = len ("||" ++ line) +re_box [] + =[] diff --git a/miralib/ex/divmodtest.m b/miralib/ex/divmodtest.m new file mode 100644 index 0000000..28b5e03 --- /dev/null +++ b/miralib/ex/divmodtest.m @@ -0,0 +1,11 @@ +||This script defines tests for three properties of div and mod, each +||checked over a small range of values including various combinations +||of signs. Each test should yield the result True, or there is +||something wrong with the arithmetic on your machine! + +test1 = and [a div b = entier (a/b) | a,b <- [-15..15]; b~=0] +test2 = and [b*(a div b) + a mod b = a | a,b <- [-15..15]; b~=0] +test3 = and [ ok a b | a,b <- [-15..15]; b~=0] + where + ok a b = 0 <= a mod b < b, if b>0 + = b < a mod b <= 0, if b<0 diff --git a/miralib/ex/edigits.m b/miralib/ex/edigits.m new file mode 100644 index 0000000..216757f --- /dev/null +++ b/miralib/ex/edigits.m @@ -0,0 +1,73 @@ +> ||note that this is a literate script + +Programming example - generating the digits of `e' + +We wish to write a program to generate the (decimal) digits of `e', as +an infinite string. Fact - the value of `e', the base of natural +logarithms, is given by the series + +e = 1 + 1/1! + 1/2! + 1/3! + ... + +where by n! we mean the factorial of n, = n*(n-1)...*2*1. Now, we can +choose to represent fractional numbers using a peculiar base system, in +which the weight of the i'th digit after the point is 1/i! (so note that +the `carry factor' by which we must multiply a unit from the i'th digit +when carrying it back to the i-1'th is i). Written to this funny base, +`e' is just + 2.1111111111............ +so the string we require may be obtained by converting fractional part +of the above numeral from the `funny base' to decimal. Thus + +> edigits = "2." ++ convert (repeat 1) + +The function `convert' takes for its argument a fraction in the funny +base (here represented as an infinite list of numbers) and returns its +value in decimal, as an infinite list of digits. The algorithm for +converting a fraction from another base to decimal, is as follows: (i) +multiply all digits by ten, and renormalise, using the appropriate carry +factors (ii) the whole number part of the result gives the first decimal +digit (iii) repeat the process on the fractional part of the result to +generate the remaining digits. Thus + +> convert x = mkdigit (hd x'):convert (tl x') +> where x' = norm 2 (0:map (10*) x) +> mkdigit n = decode(n + code '0'), if n<10 + +It remains to define the function `norm' which does renormalisation. A +naive (and almost correct) definition is + + norm c (d:x) = d + e' div c: e' mod c : x' + where + (e':x') = norm (c+1) x + +However, this is not a well-founded recursion, since it must search +arbitrarily far to the right in the fraction being normalised before +printing the first digit. If you try printing `edigits' with the above +as your definition of norm, you will get "2." followed by a long +silence. + +We need a theorem which will limit the distance from which a carry can +propagate. Fact: during the conversion of this fraction the maximum +possible carry from a digit to its leftward neighbour is 9. (The proof +of this, left as a (not very hard) exercise for the mathematically +minded reader, is by induction on the number of times the conversion +algorithm is applied.) This leads us to the following slightly more +cautious definition of `norm' + +> norm c (d:e:x) = d + e div c: e' mod c : x', if e mod c + 9 < c +> = d + e' div c : e' mod c : x', otherwise +> where +> (e':x') = norm (c+1) (e:x) + +Our solution is now complete. To see the results, enter mira with this +file as the current script and say + edigits +Hit control-C (interrupt) when you have seen enough digits. + +[Note: If nothing happens until you interrupt the evaluation, this may +be because the output from Miranda to your terminal is being +line-buffered, so the characters are not appearing on your screen as +Miranda prints them, but being saved up until there is a whole line to +print. Output from the computer to your terminal should not be line +buffered when Miranda is running - ask someone how to disable the line +buffering, if this is the case.] diff --git a/miralib/ex/fib.m b/miralib/ex/fib.m new file mode 100644 index 0000000..d84d33f --- /dev/null +++ b/miralib/ex/fib.m @@ -0,0 +1,4 @@ +||fib n computes the n'th fibonacci number +||by using /count you can estimate the asymptotic limit of (fib n/time to compute fib n) +fib n = 1, if n<=2 + = fib(n-1) + fib(n-2), otherwise diff --git a/miralib/ex/fibs.m b/miralib/ex/fibs.m new file mode 100644 index 0000000..39c805d --- /dev/null +++ b/miralib/ex/fibs.m @@ -0,0 +1,16 @@ +||This program tabulates the values of `fib i' a function for computing +||fibonacci numbers, in a list `fibs'. Because the function is memoised +||(i.e. it uses table lookup when it recurses) it runs in linear time. +||To see the fibonacci numbers say. +|| test + +fibs = map fib [0..] +fib 0 = 0 +fib 1 = 1 +fib (n+2) = fibs!(n+1) + fibs!n + +test = layn (map shownum fibs) + +||P.S. There is a more direct way of defining fibs, using a list comprehension +|| fibs = [a | (a,b) <- (0,1), (b,a+b) .. ] +||this also runs in linear time diff --git a/miralib/ex/genmat.m b/miralib/ex/genmat.m new file mode 100644 index 0000000..27c2f88 --- /dev/null +++ b/miralib/ex/genmat.m @@ -0,0 +1,84 @@ +||The matrix package again, but this time parameterised over an arbitrary +||element type, with a zero, a unit and four functions of arithmetic. +||Example - to instantiate this package with numbers as the element type, +||in another script, say:- +|| %include <ex/genmat> { elem==num; zero=0; unit=1; +|| plus=+; minus=-; times=*; divide=/; } + +||However another possibility would be to use the package to do matrix +||calculations over rationals (as defined in <ex/rat>) thus:- +|| %include <ex/genmat> +|| { elem==rational; zero=mkrat 0; unit=mkrat 1; +|| plus=rplus; minus=rminus; times=rtimes; divide=rdiv; } + +%export matrix idmat matadd matsub matmult prescalmult postscalmult + mkrow mkcol det adjoint inv + +%free { elem::type; zero,unit::elem; + plus,minus,times,divide::elem->elem->elem; + } + +matrix == [[elem]] + +idmat :: num->matrix ||identity matrix of given size +idmat n = [[delta i j|j<-[1..n]]|i<-[1..n]] + where + delta i j = unit, if i=j + = zero, otherwise + +matadd :: matrix->matrix->matrix +matadd x y = map2 vadd x y + where + vadd x y = map2 plus x y + +matsub :: matrix->matrix->matrix +matsub x y = map2 vsub x y + where + vsub = map2 minus + +matmult :: matrix->matrix->matrix +matmult x y = outer inner x (transpose y) ||* +inner x y = summate (map2 times x y) +outer f x y = [[f a b|b<-y]|a<-x] + +||*note that transpose is already defined in the standard environment + +summate = foldl plus zero + +prescalmult :: elem->matrix->matrix ||premultiply a matrix by a scalar +prescalmult n x = map (map (times n)) x + +postscalmult :: elem->matrix->matrix ||postmultiply a matrix by a scalar +postscalmult n x = map (map ($times n)) x + +||we need both the above because element multiplication may not be +||commutative + +mkrow :: [elem]->matrix ||make vector into matrix with a single row +mkrow x = [x] + +mkcol :: [elem]->matrix ||make vector into matrix with a single column +mkcol x = map (:[]) x + +det :: matrix->elem ||determinant, of square matrix +det [[a]] = a +det xs = summate [(xs!0!i) $times cofactor 0 i xs|i<-index xs], if #xs=#xs!0 + = error "det of nonsquare matrix", otherwise +cofactor i j xs = parity (i+j) $times det (minor i j xs) +minor i j xs = [omit j x | x<-omit i xs] +omit i x = take i x ++ drop (i+1) x + +parity::num->elem +parity i = unit, if i mod 2 = 0 + = zero $minus unit, otherwise + +adjoint :: matrix->matrix ||adjoint, of square matrix +adjoint xs = transpose[[cofactor i j xs | j<-index xs] | i <- index xs] + +inv :: matrix->matrix ||inverse, of non-singular square matrix +inv xs = transpose[[cofactor i j xs $divide h | j<-index xs] | i <- index xs] + where + h = det xs +||The above is a literal transcription of the mathematical definition of +||matrix inverse. A less naive version of the package would rewrite +||this to use Gaussian elimination. diff --git a/miralib/ex/graphics.m b/miralib/ex/graphics.m new file mode 100644 index 0000000..ca2f09a --- /dev/null +++ b/miralib/ex/graphics.m @@ -0,0 +1,164 @@ +||package for developing rectangular pictures composed of ascii characters +||DT Jan 84 +||all pictures are conceived as lying in an infinite plane with origin at (0,0) +||and filled with blanks except where non-blank chars have been specified +query * ::= FAIL | SUCCEED * +||generic union type, often useful -- should probably be in library +picture ::= MKPIC (num,num)! [[char]] | EMPTYPIC +||MKPIC holds a figure with its north west corner at the given coordinates +frame :: picture->(num,num,num,num) +||returns (left,right,low,high) of smallest rectangle containing the figure +frame(MKPIC (x,y) a) = (x,x+#a!0-1,y-#a+1,y) +||it is an error to apply frame to the empty picture +printpic :: picture->[char] ||prints pic with frame north west justified +printpic EMPTYPIC = [] +printpic (MKPIC (x,y) a) = concat[p ++ "\n" | p <- a] +printpic1 :: picture->[char] ||likewise, right shifted 8 +printpic1 EMPTYPIC = [] +printpic1 (MKPIC (x,y) a) = concat[" "++p ++ "\n" | p <- a] +alignpic :: num->num->picture->[char] +||prints picture as seen looking south east from the given cooordinates -- +||only parts of the figure onside from this position appear of course +alignpic x y EMPTYPIC = [] +alignpic x y (MKPIC (x1,y1) a) + = newlines (y-y1) ++ concat a1, if y>y1 + = concat(drop (y1-y) a1), if y<y1 + = concat a1, otherwise + where + a1 = [drop (x-x1) p ++ "\n" | p <- a], if x>x1 + = [spaces (x1-x) ++ p ++ "\n" | p <- a], if x<x1 + = [p ++ "\n" | p <- a], otherwise +translate :: num->num->picture->picture ||move picture x right and y up +translate x y EMPTYPIC = EMPTYPIC +translate x y (MKPIC (x1,y1) a) = MKPIC (x+x1,y+y1) a +rotate :: num->picture->picture +||rotate the picture by n*pi/2 radians anticlockwise about (0,0) +rotate n EMPTYPIC = EMPTYPIC +rotate 0 = id +rotate 1 = reflect 3.reflect 2 ||result from group theory +rotate 2 (MKPIC (x,y) a) = + MKPIC (-(x+#a!0-1),-(y-#a+1)) (reverse (map reverse a)) +rotate 3 = reflect 2.reflect 3 ||group theory +rotate n = rotate (n mod 4) ||other values of n +reflect :: num->picture->picture +||reflect about a line inclined at n*pi/4 to the x axis +reflect n EMPTYPIC = EMPTYPIC +reflect 0 (MKPIC (x,y) a) = MKPIC (x,-(y-#a+1)) (reverse a) +reflect 1 = reflect 3.rotate 2 ||group theory +reflect 2 (MKPIC (x,y) a) = MKPIC (-(x+#a!0-1),y) (map reverse a) +reflect 3 (MKPIC (x,y) a) = MKPIC (-y,-x) (transpose a') + where a' = map(map f)a + f '-' = '|' + f '|' = '-' + f etc = etc +reflect n = reflect (n mod 4) ||other values of n +composepic :: [picture]->query picture +||tries to combine the given list of pictures to yield a composite picture +|| -- fails if any parts of the figures overlap +composepic = foldr apic (SUCCEED EMPTYPIC) +compositions :: [[picture]]->[picture] +||finds all possible ways of composing a picture (with no overlaps) with +||one component from each of the given picture lists +||this will probably be more useful in practice than composepic +compositions [] = [EMPTYPIC] +compositions (xx:etc) = f[apic1 x r // x <- xx; r <- compositions etc] + where + f [] = [] + f (FAIL:x) = f x + f (SUCCEED a:x) = a: f x +overlaypic :: [picture]->picture +||similar to the above but allows pictures earlier in the given list to hide +||details of later ones, so the result is always a picture +overlaypic = foldr opic EMPTYPIC +apic :: picture->query picture->query picture ||picture addition +p $apic SUCCEED EMPTYPIC = SUCCEED p +p $apic FAIL = FAIL +EMPTYPIC $apic q = q +MKPIC (x1,y1) a $apic SUCCEED (MKPIC (x2,y2) b) + = FAIL, if xx=FAIL + = SUCCEED (MKPIC (x,y) (f xx)), otherwise + where + x = min[x1,x2] + y = max[y1,y2] + xx = pointwiseadd a1 b1 + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 + f(SUCCEED c) = c +apic1 :: picture->picture->query picture ||picture addition mark2 +p $apic1 EMPTYPIC = SUCCEED p +EMPTYPIC $apic1 q = SUCCEED q +MKPIC (x1,y1) a $apic1 MKPIC (x2,y2) b + = FAIL, if xx=FAIL + = SUCCEED (MKPIC (x,y) (f xx)), otherwise + where + x = min[x1,x2] + y = max[y1,y2] + xx = pointwiseadd a1 b1 + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 + f(SUCCEED c) = c +opic :: picture->picture->picture ||picture superposition +p $opic EMPTYPIC = p +EMPTYPIC $opic q = q +MKPIC (x1,y1) a $opic MKPIC (x2,y2) b + = MKPIC (x,y) (pointwiseoverlay a1 b1) + where + x = min[x1,x2] + y = max[y1,y2] + a1 = sidepad (x1-x) (-rjut) (toppad (y-y1) a) + b1 = sidepad (x2-x) rjut (toppad (y-y2) b) + rjut = x1+#a!0-x2-#b!0 +sidepad n r a = [spaces n ++ p ++ spaces r | p <- a] +toppad n a = f n + where + f n = a, if n<=0 + = spaces (#a!0):f (n-1), otherwise +pointwiseoverlay :: [[char]]->[[char]]->[[char]] +pointwiseoverlay a b = f a b + where + f [] b = b + f a [] = a + f (p:a) (q:b) = g p q:f a b + g [] q = q + g p [] = p + g (c1:p) (c2:q) = c2:g p q, if c1=' ' + = c1:g p q, otherwise +pointwiseadd :: [[char]]->[[char]]->query [[char]] +pointwiseadd a b = SUCCEED c, if and [~member z clashchar | z<-c] + = FAIL, otherwise + where + c = f a b + f [] b = b + f a [] = a + f (p:a) (q:b) = g p q:f a b + g [] q = q + g p [] = p + g (c1:p) (c2:q) = c2:g p q, if c1=' ' + = c1:g p q, if c2=' ' + = clashchar:g p q, otherwise +clashchar = '\0' ||assumed not to be present in any normal picture +pic :: num->num->[[char]]->picture +||takes a rectangular array of chars and turns it into a picture with its north +||west corner at the given x y position +pic x y a = EMPTYPIC, if and[p=[]|p<-a] + ||covers both a=[] and elements a all [] + = pic x (y-1) (tl a), if and[c=' ' | c<-hd a] + ||strip blank rows + = pic (x+1) y (map tl a), if and[hd p=' ' | p <- a] + ||strip blank cols + = MKPIC (x,y) a, otherwise + ||what about east and south trimming? -- fix later +||we have assumed given a rectangular and not containing control chars, we +||ought perhaps to check this when a picture is formed -- fix later + +newlines n = rep n '\n' +closure :: (*->[*])->[*]->[*]; +||takes the closure of a set under a pointwise function that returns +||increments to the set +closure f s = g s s + where + g r t = [], if t=[] + = t ++ g(r ++ t)(mkset[x|x<-concat(map f t);~member r x]), + otherwise diff --git a/miralib/ex/hamming.m b/miralib/ex/hamming.m new file mode 100644 index 0000000..3ebb6ce --- /dev/null +++ b/miralib/ex/hamming.m @@ -0,0 +1,19 @@ +||this is a problem described by Dijkstra in his book, A Discipline of +||Programming, and attributed by him to Dr Hamming, of Bell Labs. +||Print in ascending order all numbers of the form +|| 2**a.3**b.5**c a,b,c all >=0 +||the solution here is based on a method using communicating processes. +||ham is the list of numbers, to see them, say +|| ham +||hit control-C (interrupt) when you have seen enough! + +ham = 1 : foldr1 merge [mult 2 ham, mult 3 ham, mult 5 ham] + where + mult n x = [n*a|a<-x] + merge (a:x) (b:y) = a : merge x y, if a=b + = a : merge x (b:y), if a<b + = b : merge (a:x) y, if a>b + +||Note that there is a function called `merge' in the standard +||environment, but unlike the one defined above it does not remove +||duplicates from the lists being merged. diff --git a/miralib/ex/hanoi.m b/miralib/ex/hanoi.m new file mode 100644 index 0000000..b927ca3 --- /dev/null +++ b/miralib/ex/hanoi.m @@ -0,0 +1,11 @@ +||This script generates a solution to the well known `Towers of Hanoi' +||problem. To see the moves (for a game with 12 discs) say +|| soln + +soln = title++hanoi 12 "A" "B" "C" +title = "SOLUTION TO TOWERS OF HANOI WITH 8 DISCS\n\n" +hanoi 0 a b c = [] +hanoi (n+1) a b c = hanoi n a c b + ++ move a b ++ + hanoi n c b a +move a b = "move the top disc from "++a++" to "++b++"\n" diff --git a/miralib/ex/just.m b/miralib/ex/just.m new file mode 100644 index 0000000..9dca373 --- /dev/null +++ b/miralib/ex/just.m @@ -0,0 +1,98 @@ +||Text formatting program (DT) +||Reformats text to a specified width, with line-fill + +%export just + +||To try this out from within a Miranda session, say e.g. +|| just 60 (read "file") +||where "file" contains some text you want to reformat. + +||You could also make it into a UNIX filter -- see the example `mrev'. + +||----------------------------------------------------------------------|| +|| in this program we move between three different representations of || +|| text - as a flat list of characters, including spaces and newlines || +|| - as a list of lines (containing spaces but not newlines) || +|| - and as a list of list of words. || +||----------------------------------------------------------------------|| + +text == [char] +line == [char] +word == [char] + +just::num->text->text ||the main function +just n = concat.map(reformat n).paras.map words.lines + +||lines::text->[line] +||lines is defined in <stdenv> - it breaks a string into lines, +||removing the newline characters + +paras::[[word]]->[[word]] +||make each paragraph into one long line, by joining adjacent +||non-blank lines +paras (a:b:x) = paras ((a++b):x), if a~=[]~=b + = a:paras (b:x), otherwise +paras (a:[]) = a:[] +paras [] = [] + +reformat::num->[word]->text +||reformat a paragraph to width n +reformat n [] = "\n" ||the empty paragraph represents a blank line +reformat n x = lay(justify n (partition n x)) + +||lay::[line]->text +||lay is defined in <stdenv> - it is the inverse of lines + +justify::num->[[word]]->[line] +justify n para = map(fill_line n)(init para)++[unwords(last para)] + +partition::num->[word]->[[word]] +||break a paragraph into lines, with as many words as will fit in width +||n on each line (except the last) +partition n [] = [] +partition n x = x1 : partition n rest + where + (x1,rest) = grab [] x + grab y (w:x) = grab (w:y) x, if sum(map(#)y)+#y+#w <= n + = (reverse y,w:x), otherwise + grab y [] = (reverse y,[]) + +fill_line :: num->[word]->line +||make words into a line of length n exactly, by inserting enough spaces +fill_line n words + = (concat.concat) (transpose [words,mkspaces (w-1) (n-sw)]) + where + w = #words + sw = sum(map (#) words) + +mkspaces :: num->num->[[char]] +||return s spaces broken into n groups +mkspaces n s = map f [1..n], if n mod 2=0 ||see note + = map f [n,n-1..1], otherwise + where + f i = rep (s div n + delta) ' ' + where + delta = 1, if i<=s mod n + = 0, otherwise +||note: we put the extra spaces in sometimes from the left and sometimes +||from the right, depending on the parity of n. This is to avoid +||visually unbalancing the text by having all the extra spaces towards +||one margin. Using the parity of n to decide this is arbitrary. + +words :: line->[word] +||break a line into words +words = filter (~=[]) . foldr (breakon ' ') [[]] + +unwords :: [word]->line +||join words to make a line, inserting one space as separator +unwords = foldr1 (insert ' ') + +insert :: *->[*]->[*]->[*] +insert a x y = x ++ [a] ++ y + +breakon :: *->*->[[*]]->[[*]] +breakon c a x = []:x, if a=c + = (a:hd x):tl x, otherwise + +||These definitions of `words' and `unwords' are due to Richard Bird, see +||Bird and Wadler (1988), page 91. diff --git a/miralib/ex/kate.lit.m b/miralib/ex/kate.lit.m new file mode 100644 index 0000000..7deb3cc --- /dev/null +++ b/miralib/ex/kate.lit.m @@ -0,0 +1,138 @@ +\documentclass[10pt]{article} +\title{{\tt kate.lit.m} --- KaTify text} +\author{J. Cupitt} +\date{July 21st, 1989} +% turn off para indents +\setlength{\parindent}{0in} +% put some space between paras +\setlength{\parskip}{0.05in} +\begin{document} +\maketitle + +%An example of a Miranda literate script that is also a LaTeX source +%file. Note that the lines of formal program text are surrounded by +%LaTeX verbatim directives. Contributed by John Cupitt, of the +%University of Kent. + +There is a group on USENET called \verb"rec.music.gaffa", dedicated to the +singer Kate Bush. A running joke in this group is to pretend fanatical +devotion to Kate And Her Works --- this reaches an extreme form in some +posters, who capitalise all the Ks and Ts in their articles in reference both +to KaTe herself and to the Knights Templar. This Miranda\footnote{Miranda is a +trademark of Research Software Ltd.} script can be used as a {\sc +Unix}\footnote{UNIX is a trademark of AT\&T in the USA and other +countries.} filter to prepare your articles for posting to \verb"gaffa". +The main function is called \verb"kate" and is at the end. + +Do some simple maps on text. We do: + +\begin{center} +\begin{tabular}{rcl} + c,C,k & $\rightarrow $ & K \\ + t & $\rightarrow $ & T \\ + qu,Qu & $\rightarrow $ & Kw \\ + ck & $\rightarrow $ & K \\ + ch,Ch & $\rightarrow $ & Khe +\end{tabular} +\end{center} + +We also look for Kommon words that can be easily swapped for something with +more ks and ts. + +The dictionary we use to look for common words. This is very small at the +moment! I should perhaps find a thesaurus and fix this up properly. + +\begin{verbatim} + +> kateMap +> = [(["interpose", "insert"], +> "interject"), +> (["frequent", "general", "usual", "normal"], +> "common"), +> (["program", "file"], +> "script"), +> (["name"], +> "appelation"), +> (["however"], +> "though"), +> (["serve"], +> "officiate"), +> (["intersperse"], +> "punctuate") +> ] + +\end{verbatim} + +First map. Very easy! + +\begin{verbatim} + +> swapCase :: [char] -> [char] +> swapCase ('c':'k':x) = 'K':swapCase x +> swapCase ('c':'h':x) = 'K':'h':'e':swapCase x +> swapCase ('C':'h':x) = 'K':'h':'e':swapCase x +> swapCase ('c':x) = 'K':swapCase x +> swapCase ('C':x) = 'K':swapCase x +> swapCase ('k':x) = 'K':swapCase x +> swapCase ('t':x) = 'T':swapCase x +> swapCase ('q':'u':x) = 'K':'w':swapCase x +> swapCase ('Q':'u':x) = 'K':'w':swapCase x +> swapCase (a:x) = a: swapCase x +> swapCase [] = [] + +\end{verbatim} + +Second map. We loop down the input again, chopping out words. Each one gets +put through tryMap. + +\begin{verbatim} + +> swapWords :: [char] -> [char] +> swapWords [] = [] +> swapWords inp +> = punk ++ tryMap word ++ swapWords tail +> where +> punk = takewhile ((~) . letter) inp +> start = dropwhile ((~) . letter) inp +> word = takewhile letter start +> tail = dropwhile letter start + +\end{verbatim} + +Try to map a word through the KaTe thesaurus we defined earlier. We try to be +clever about what we swap. For example, we want \verb"insert" to be mapped to +\verb"interject", and \verb"inserting" to be mapped to \verb"interjecting". +This isn't always the most sensible way to do it \ldots + +\begin{verbatim} + +> tryMap :: [char] -> [char] +> tryMap word +> = word, if maps = [] +> = hd maps, otherwise +> where +> maps = [ to ++ drop (#x) word | +> (from, to) <- kateMap; x <- from; +> x $isprefix word ] + +\end{verbatim} + +Test for first argument a prefix of the second argument. + +\begin{verbatim} + +> isprefix :: [*] -> [*] -> bool +> isprefix a b = take (#a) b = a + +\end{verbatim} + +And our entry point. We just pipe stuff first through swapWords, then through +swapCase. + +\begin{verbatim} + +> kate :: [char] -> [char] +> kate = swapCase . swapWords + +\end{verbatim} +\end{document} diff --git a/miralib/ex/kate.pdf b/miralib/ex/kate.pdf Binary files differnew file mode 100644 index 0000000..606a4c8 --- /dev/null +++ b/miralib/ex/kate.pdf diff --git a/miralib/ex/kate.tex b/miralib/ex/kate.tex new file mode 120000 index 0000000..8da0f90 --- /dev/null +++ b/miralib/ex/kate.tex @@ -0,0 +1 @@ +kate.lit.m
\ No newline at end of file diff --git a/miralib/ex/keith.m b/miralib/ex/keith.m new file mode 100644 index 0000000..b743de9 --- /dev/null +++ b/miralib/ex/keith.m @@ -0,0 +1,31 @@ +> ||this tests that floating point overflow is handled correctly + +Date: Mon, 16 Apr 90 17:15:03 CST +From: mccrosky@ishmael.usask.ca + +Sorry for the delay in sending my bignum problem, I've been out of town. + +> keith n = (shownum n) ++ " " ++ (shownum ((log (sumterm n))/n)) where +> sumterm n = sum (map prodterm [0..entier (n/2)]) where +> prodterm p = prod (map term [0..p-1]) where +> term j = x*(x-1)/((p-j)^2) where +> x = n-(2*j) +> prod = foldr (*) 1 +> lim = lay (from 1) where from n = (keith n):(from (n*2)) + + +******** This is the execution: + (We believe the results up to n=256 are correct). + +Miranda lim +1 0.0 +2 0.549306144334 +4 0.736109744792 +8 0.876176116589 +16 0.966470019952 +32 1.021895160467 +64 1.054884461071 +128 1.07405223475 +256 1.084981322415 +512 +should trap floating point overflow here diff --git a/miralib/ex/makebug.m b/miralib/ex/makebug.m new file mode 100644 index 0000000..b32d4bb --- /dev/null +++ b/miralib/ex/makebug.m @@ -0,0 +1,18 @@ +> makebug size = [Tofile "/tmp/big.m" (big_def size)] +> big_def n = "big_list\n=[\n" ++ lay (rep n " \"hello\",") ++ " \"hello\"]\n" + +This tests garbage collection during compilation. First turn on gc +reports by saying + /gc + +To generate /tmp/big.m of chosen size say, e.g. + makebug 10000 +to get mira to compile the result say + /f /tmp/big +Saying this repeatedly (or /f %) will force recompilations +Or from the command line after quitting mira + rm /tmp/big.x #to force recompilation + mira -make -gc /tmp/big + +If the heap becomes corrupted you will see strange type errors or +"impossible event" messages. From Rick Morgan at Durham, May 1990. diff --git a/miralib/ex/matrix.m b/miralib/ex/matrix.m new file mode 100644 index 0000000..46abbaf --- /dev/null +++ b/miralib/ex/matrix.m @@ -0,0 +1,70 @@ +||very simple matrix package (DT) +||note that to include this in one of your own scripts, you can say +|| %include <ex/matrix> + +%export matrix idmat matadd matsub matmult scalmult mkrow mkcol det + adjoint inv + +matrix == [[num]] + +idmat :: num->matrix ||identity matrix of given size +idmat n = [[delta i j|j<-[1..n]]|i<-[1..n]] + where + delta i j = 1, if i=j + = 0, otherwise + +matadd :: matrix->matrix->matrix +matadd x y = map2 vadd x y + where + vadd x y = map2 (+) x y + +matsub :: matrix->matrix->matrix +matsub x y = map2 vsub x y + where + vsub = map2 (-) + +matmult :: matrix->matrix->matrix +matmult x y = outer inner x (transpose y) ||* +inner x y = sum (map2 (*) x y) +outer f x y = [[f a b|b<-y]|a<-x] + +||*note that transpose is already defined in the standard environment + +scalmult :: num->matrix->matrix ||multiply a matrix by a scalar +scalmult n x = map (map (*n)) x + +mkrow :: [num]->matrix ||make vector into matrix with a single row +mkrow x = [x] + +mkcol :: [num]->matrix ||make vector into matrix with a single column +mkcol x = map (:[]) x + +det :: matrix->num ||determinant, of square matrix +det [[a]] = a +det xs = sum [xs!0!i*cofactor 0 i xs|i<-index xs], if #xs=#xs!0 + = error "det of nonsquare matrix", otherwise +cofactor i j xs = (-1)^(i+j) * det (minor i j xs) +minor i j xs = [omit j x | x<-omit i xs] +omit i x = take i x ++ drop (i+1) x + +adjoint :: matrix->matrix ||adjoint, of square matrix +adjoint xs = transpose[[cofactor i j xs | j<-index xs] | i <- index xs] + +inv :: matrix->matrix ||inverse, of non-singular square matrix +inv xs = transpose[[cofactor i j xs/h | j<-index xs] | i <- index xs] + where + h = det xs +||The above is a literal transcription of the mathematical definition of +||matrix inverse. A less naive version of the package would rewrite +||this to use Gaussian elimination. + +||a few test matrices (these are not exported from the script, but will +||be in scope if this is your current script) +a = [[1,2],[3,4]] +b = [[1,1,1],[1,2,3],[2,4,8]] +c = [[0,1,2,3],[1,2,3,4],[2,3,4,0],[3,4,0,1]] +i2 = idmat 2 +i3 = idmat 3 +i4 = idmat 4 + +test = matmult b (inv b) diff --git a/miralib/ex/mrev b/miralib/ex/mrev new file mode 100755 index 0000000..85b3dc6 --- /dev/null +++ b/miralib/ex/mrev @@ -0,0 +1,22 @@ +#! /usr/bin/mira -exec +main :: [sys_message] +main = map f (tl $*), if # $* > 1 ||$* is equivalent to argv + = [Stdout (revlines $-)], otherwise ||no files, use stdin ($-) + +f :: [char]->sys_message +f fil = Stderr ("mrev: cannot open "++fil++"\n"), if badfile + = Stdout (revlines (read fil)), otherwise + where + badfile = ~ member (filemode fil) 'r' + +revlines :: [char]->[char] +revlines = lay.map reverse.lines + +||The usage of this command (from a UNIX shell) is +|| mrev [file] ... +||If no files given, takes data from stdin. This is a Miranda version +||of the UNIX command `rev' which reverses each line of its input. + +||This example is a template for turning any Miranda function of type +||[char]->[char] into a UNIX filter. Replace `revlines' in the above +||text, by your chosen function. diff --git a/miralib/ex/parafs.m b/miralib/ex/parafs.m new file mode 100644 index 0000000..be6af05 --- /dev/null +++ b/miralib/ex/parafs.m @@ -0,0 +1,33 @@ +||program for printing isomers of the alkanes -- D.A.Turner +||say `output' to run +mol ::= H | C[mol] ||new type -- alkane molecules and radicals +c p = C (sort p) ||place subcomponents in a standard order +molecules n = mkset [ mk_molecule x | x <- radicals n ] +mk_molecule(C p) = canonical_orientation (C(H:p)) +radicals 0 = [H] +radicals n = (map rads [1..])!(n-1) || make rads a memo function +rads n = mkset [ c[x,y,z] | i <- [0..(n-1)div 3]; j <- [i..(n-1-i)div 2]; + x <- radicals i; y <- radicals j; z <- radicals(n-1-i-j) ] +canonical_orientation x = min (closure reorientations [x]) +reorientations (C p) = [ invert (p--[x]) x | x <- p; x ~= H ] + where + invert p (C q) = c (c p:q) +output = concat (map out [1..]) +out n = title n ++ concat(map prettyprint (molecules n)) +title n = "isomers of " ++ prefix!(n-1) ++ "ane\n" +prefix = ["meth","eth","prop","but","pent","hex","hept","oct","non", + "dec"] ++ [show i++"-"|i<-[11..]] + +||below this line is concerned with drawing pictures of the molecules +%include "graphics.m" +prettyprint x = printpic1 (hd (molpics x)) ++ "\n" +molpics (C p) = compositions ([centre]:map f [1..# p] ) + where + f i = map (reflect (direction!(i-1))) (subpics i) + subpics i = [q1|q<-molpics (p!(i-1)); + q1<-shift(translate 1 0 q),shift q1..] +molpics H = [pic 0 0 ["H"]] +direction = [1,-1,0,2] +shift p = translate 1 0 (overlaypic[bond,p]) +bond = pic 0 0 ["-"] +centre = pic 0 0 ["C"] diff --git a/miralib/ex/polish.m b/miralib/ex/polish.m new file mode 100644 index 0000000..21e58a5 --- /dev/null +++ b/miralib/ex/polish.m @@ -0,0 +1,34 @@ +||very simple testbed for Miranda unification package, "unify.m" + +||The expressions to be unified here are strings written in (forward) +||polish notation, such as "*+12-xy" - meaning (1+2)*(x-y). The +||operators are + - * / with single letter variables, and single digit +||constants. We provide bindings for the free identifiers of "unify.m" +||corresponding to this syntax. + +%include "unify.m" + { expr==[char]; operator==char; var==char; + isvar=isvar; getvar=getvar; putvar=putvar; + rator=rator; rands=rands; construct=construct; + } + +isvar e = letter (hd e) +getvar = hd +putvar = (:[]) +rator = hd +rands (c:[]) = [], if digit c +rands (c:e) = [a,b], if member "+-*/" c & e2=[] + = error "illegal string", otherwise + where + (a,e1) = get e + (b,e2) = get e1 + get [] = error "illegal string" + get (c:x) = ([c],x), if letter c \/ digit c + = ([c]++a++b,x2), otherwise + where + (a,x1) = get x + (b,x2) = get x1 +construct c xs = c:concat xs + +test = unifyexprs "*+x3/7x" "*+1y/z1" ||the result should be "*+13/71" +test1 = unifyexprs "*+x3/7x" "*+1y/y1" ||not unifiable diff --git a/miralib/ex/powers.m b/miralib/ex/powers.m new file mode 100644 index 0000000..019a139 --- /dev/null +++ b/miralib/ex/powers.m @@ -0,0 +1,15 @@ +||prints a table of powers 2 to 5 of the numbers 1 to 20 +||to see the table, say +|| output + +output = title ++ captions ++ concat (map line [1..20]) + +title = cjustify 60 "A TABLE OF POWERS" ++ "\n\n" + +captions = format "N" ++ concat (map caption [2..5]) ++ "\n" + +caption i = format ("N^" ++ shownum i) + +format = rjustify 12 + +line n = concat [format (show(n^i)) | i<-[1..5]] ++ "\n" diff --git a/miralib/ex/primes.m b/miralib/ex/primes.m new file mode 100644 index 0000000..2a7c5df --- /dev/null +++ b/miralib/ex/primes.m @@ -0,0 +1,7 @@ +||The infinite list of all prime numbers, by the sieve of Eratosthenes. +||To see the list, just say `primes', or if you prefer +|| lay(map show primes) +||will print them one per line. Hit control-C (interrupt) to stop. + +primes = sieve[2..] +sieve (p:x) = p:sieve[n|n<-x;n mod p~=0] diff --git a/miralib/ex/pyths.m b/miralib/ex/pyths.m new file mode 100644 index 0000000..8301e47 --- /dev/null +++ b/miralib/ex/pyths.m @@ -0,0 +1,9 @@ +||Finds all pythagorean triangles (right triangles with integer sides) +||Note the use of a diagonalising list comprehension, with `//' instead +||of `|'. To see the triangles, say +|| output + +output = lay (map show pyths) +pyths = [(a, b, intsqrt (a*a+b*b)) // a <- [3..]; b<-[a+1..]; is_sq (a*a+b*b)] +intsqrt x = entier (sqrt x) +is_sq y = (intsqrt y) ^ 2 = y diff --git a/miralib/ex/queens.m b/miralib/ex/queens.m new file mode 100644 index 0000000..2ed5734 --- /dev/null +++ b/miralib/ex/queens.m @@ -0,0 +1,22 @@ +||this generates all solutions to the 8 queens problem -- say +|| solns +||and it will print the solutions one per line - all 92 of them. This +||is a good program for testing the garbage collector. Say `/gc' to +||switch on garbage collector diagnostics. + +solns = layn(map show (queens 8)) +queens 0 = [[]] +queens (n+1) = [q:b|b<-queens n;q<-[1..8];safe q b] +safe q b = and[~checks q b i|i<-index b] +checks q b i = q=b!i \/ abs(q-b!i)=i+1 + +||Note that the function `queens n' returns a list of all solutions to +||the n queens problem (placing queens in the first n columns of a chess +||board, so that no queen gives check to another). A board with n +||queens is represented as a list of n numbers, namely the positions of +||the queens in each column + +||This example exhibits a basic technique of lazy functional +||programming, which is to eliminate backtracking from a search problem +||by working at the level of a list of all solutions, rather than a +||single solution. diff --git a/miralib/ex/queens1.m b/miralib/ex/queens1.m new file mode 100644 index 0000000..79b52a8 --- /dev/null +++ b/miralib/ex/queens1.m @@ -0,0 +1,16 @@ +||This finds one solution to the eight queens problem, using a +||different method from that of the previous script, "queens.m". +||To run it, say +|| output +||This time the backtracking is programmed explicitly + +output = concat [c:shownum r++" "|(c,r)<-zip2 "rnbqkbnr" soln] +soln = until full extend emptyboard +extend board = until safe alter (addqueen board) +addqueen board = 1:board +emptyboard = [] +full board = # board=8 +alter (q:board) = q+1:board, if q<8 + = alter board, otherwise ||backtrack +safe (q:board) = and [~checks q board i|i<-index board] +checks q board i = q=board!i \/ abs(q-board!i)=i+1 diff --git a/miralib/ex/quicksort.m b/miralib/ex/quicksort.m new file mode 100644 index 0000000..2da7d55 --- /dev/null +++ b/miralib/ex/quicksort.m @@ -0,0 +1,12 @@ +||this is a functional version of quicksort, to see it work, say: +|| qsort testdata +||the reason we have to call the function `qsort' rather than `sort' is +||because there is a `sort' already defined in the standard environment + +qsort [] = [] +qsort (a:x) = qsort [b|b<-x;b<=a] ++ [a] ++ qsort[b|b<-x;b>a] + +testdata = f 10 +f n = concat(transpose [[0,2..2*n],[2*n-1,2*n-3..1]]) + +||note that the sort included in the standard environment is merge-sort diff --git a/miralib/ex/rational.m b/miralib/ex/rational.m new file mode 100644 index 0000000..8b432d1 --- /dev/null +++ b/miralib/ex/rational.m @@ -0,0 +1,56 @@ +||rational numbers as an abstract data type, say +|| %include <ex/rat> +||to include this in one of your own scripts. Quoting the filename in +||this form makes the %include directive work from any directory. + +abstype rational +with ratio :: num -> num -> rational + mkrat :: num->rational + rplus, rminus, rtimes, rdiv :: rational -> rational -> rational + rpow :: num -> rational -> rational + numerator, denominator :: rational -> num + rparts :: rational -> (num,num) + showrational :: rational -> [char] + +rational == (num,num) + +||a rational is represented as a pair of integers +||note that rationals are kept in their lowest terms, with positive +||denominator, and (0,1) is the unique representation of zero + +ratio p q = error "illegal ratio", if q=0\/~integer p\/~integer q + = ratio (-p) (-q), if q<0 + = (0,1), if p=0 + = (p div h,q div h), otherwise + where + h = hcf (abs p) q + hcf a b = hcf b a, if a>b + = b, if a=0 + = hcf (b mod a) a, otherwise + +mkrat n = ratio n 1, if integer n + = error ("mkrat "++shownum n), otherwise + +(a,b) $rplus (c,d) = ratio (a*d+c*b) (b*d) +(a,b) $rminus (c,d) = ratio (a*d-c*b) (b*d) +(a,b) $rtimes (c,d) = ratio (a*c) (b*d) +(a,b) $rdiv (c,d) = ratio (a*d) (b*c) + +rpow 0 x = (1,1) +rpow n x = thing, if n mod 2 = 0 + = x $rtimes thing, otherwise + where + thing = rpow (n div 2) (x $rtimes x) + +numerator = fst +denominator = snd +rparts = id + +showrational (a,b) = "(ratio "++shownum1 a++" "++shownum1 b++")" +shownum1 n = "("++shownum n++")", if n<0 + = shownum n, otherwise + +||Attempts to print a rational will automatically pick up the function +||called showrational - see manual section on abstract data types. Note +||that we have chosen to print rationals in such a way that Miranda can +||read them back in again at the same type. diff --git a/miralib/ex/refoliate.m b/miralib/ex/refoliate.m new file mode 100644 index 0000000..028f362 --- /dev/null +++ b/miralib/ex/refoliate.m @@ -0,0 +1,60 @@ +> tree ::= Leaf num | Fork tree tree + +PROBLEM: write down the definition of a function which takes a tree and +returns a tree of the SAME SHAPE, containing the same data, but with the +leaves moved around so that the data appears in ascending order, when +the tree is scanned from left to right. + +> reorder :: tree->tree +> reorder t = refoliate t (sort (fringe t)) + +Our idea here is that `fringe' extracts a list of all the data in the +tree, while `refoliate' takes a tree and a list of data, and replaces +the leaves of the tree with the given data, preserving the shape of the +tree. We define fringe first, as it is the easiest. + +> fringe :: tree->[num] +> fringe (Leaf n) = [n] +> fringe (Fork s t) = fringe s ++ fringe t + +Aside - there is a trivial change to the last line which alters the +behaviour of fringe so that the call to sort is no longer necessary. We +can replace `++' by a call to the library function `merge'. This would +improve the efficiency of the solution. + +We define `refoliate' in terms of an auxiliary function which takes a +subtree and the list of replacement data, and returns a pair - the +refoliated subtree, and the unused part of the list. + +> refoliate :: tree->[num]->tree +> refoliate t x = fst (refol t x) + +> refol :: tree->[num]->(tree,[num]) +> refol (Leaf n) (a:x) = (Leaf a,x) +> refol (Fork s t) x = (Fork s1 t1,x'') +> where +> (s1,x') = refol s x +> (t1,x'') = refol t x' + +Here is an example tree on which to call `reorder', to see that the +algorithm works. + +> t1 = mktree [19,0,17,2,15,4,13,6,11,8,9,10,7,12,5,14,3,16,1,18] + +mktree takes a list and builds a (well-balanced) tree from it. + +> mktree :: [num]->tree +> mktree [] = error "cannot have empty tree" +> mktree [a] = Leaf a +> mktree x = Fork (mktree (take n x)) (mktree (drop n x)) +> where n = # x div 2 + +Finally, we define a function same_shape, which can be used to confirm +that reorder holds the shape constant. + +> same_shape :: tree->tree->bool +> same_shape (Leaf a) (Leaf b) = True +> same_shape (Fork s t) (Fork s1 t1) = same_shape s s1 & same_shape t t1 +> same_shape s t = False ||all other cases + +> test = same_shape t1 (reorder t1) diff --git a/miralib/ex/selflines.m b/miralib/ex/selflines.m new file mode 100644 index 0000000..cf3d016 --- /dev/null +++ b/miralib/ex/selflines.m @@ -0,0 +1,32 @@ +||this produces an endless self describing scroll of lines, as follows +|| the 1st line is +|| "the 1st line is" +|| the 2nd line is +|| ""the 1st line is"" +|| the 3rd line is +|| "the 2nd line is" +|| etc... +||To see the result, say +|| output +||Hit control-C (interrupt) when you have seen enough. +||If you would like to send the output to a file, say +|| output &> fil +||where `fil' is the name of the file in which you want to put it +||this will create a background job + +output = concat[l++"\n"|l<-selflines] + +selflines = mklines 1 + +mklines n = ("the "++ord n++" line is:"): + ("\""++selflines!(n-1)++"\""): + mklines(n+1) + +ord n = show n++suffix n + +suffix 1 = "st" +suffix 2 = "nd" +suffix 3 = "rd" +suffix n = "th", if n=0 \/ 3<=n&n<=9 + = "th", if (n mod 100)div 10 = 1 ||because of 11,12,13 + = suffix(n mod 10), otherwise diff --git a/miralib/ex/set.m b/miralib/ex/set.m new file mode 100644 index 0000000..c6a52f9 --- /dev/null +++ b/miralib/ex/set.m @@ -0,0 +1,64 @@ +||definition of finite sets as an abstract data type, say +|| %include <ex/set> +||to include this in one of your own scripts. + +abstype set * +with makeset::[*]->set * ||converts list to set + enum::set *->[*] ||converts set to list + empty::set * ||empty set + mem::set *->*->bool ||does set contain element? + pincludes,includes::set *->set *->bool ||(proper) set inclusion + union::[set *]->set * ||union of a list of sets + intersect::[set *]->set * ||intersection of a list of sets + setdiff::set *->set *->set * ||set difference of two sets + union2::set *->set *->set * ||union of two sets + intersect2::set *->set *->set * ||intersection of two sets + add1::*->set *->set * ||add a single element to a set + sub1::*->set *->set * ||remove an element from a set (if present) + pick::set *->* ||pick some element from a set + rest::set *->set * ||remainder of set, without element got by pick + showset::(*->[char])->set *->[char] ||to make sets printable + +set * == [*] ||a set is represented as a list without duplicates +makeset = uniq.sort ||for efficiency the lists are kept sorted +enum = id +empty = [] +mem (a:x) b = a=b \/ a<b & mem x b +mem [] b = False +includes x y = (setdiff y x = []) +pincludes x y = x~=y & (setdiff y x = []) +union2 x y = uniq(merge x y) +union = foldr union2 empty +setdiff (a:x) (b:y) = a:setdiff x (b:y), if a<b + = setdiff (a:x) y, if a>b + = setdiff x y, otherwise +setdiff x y = x +intersect2 (a:x) (b:y) = intersect2 x (b:y), if a<b + = intersect2 (a:x) y, if a>b + = a : intersect2 x y, otherwise +intersect2 x y = [] +intersect = foldl1 intersect2 +add1 a (b:x) = a:b:x, if a<b + = b:x, if a=b + = b:add1 a x, otherwise +add1 a [] = [a] +sub1 a (b:x) = b:x, if a<b + = x, if a=b + = b:sub1 a x, otherwise +sub1 a [] = [] +pick (a:x) = a +pick [] = error "pick empty" +rest (a:x) = x +rest [] = error "pick empty" +showset f [] = "{}" +showset f (a:x) = "{"++f a++concat(map g x)++"}" + where + g a = ',':f a + +%export -uniq +||we have used the following auxiliary function, which removes adjacent +||duplicates from a list (this is not exported from the script) +uniq::[*]->[*] +uniq (a:b:x) = uniq (a:x), if a=b + = a:uniq (b:x), otherwise +uniq x = x diff --git a/miralib/ex/stack.m b/miralib/ex/stack.m new file mode 100644 index 0000000..d7a1af2 --- /dev/null +++ b/miralib/ex/stack.m @@ -0,0 +1,19 @@ +||This script defines stack, as an abstract data type based on lists. +||Note that there is a show function for stacks, causing them to print +||in a sensible way. + +abstype stack * +with empty::stack *; push::*->stack *->stack *; + pop::stack *->stack *; top::stack *->*; isempty::stack *->bool; + showstack::(*->[char])->stack *->[char] + +stack * == [*] +empty = [] +push a x = a:x +pop(a:x) = x +top(a:x) = a +isempty x = (x=[]) +showstack f [] = "empty" +showstack f (a:x) = "(push " ++ f a ++ " " ++ showstack f x ++ ")" + +teststack = push 1(push 2(push 3 empty)) diff --git a/miralib/ex/topsort.m b/miralib/ex/topsort.m new file mode 100644 index 0000000..88e96ee --- /dev/null +++ b/miralib/ex/topsort.m @@ -0,0 +1,32 @@ +||Miranda programming example - topological sort +topsort :: [(*,*)] -> [*] + +||topsort takes a list of pairs representing a partial order - where +||the presence of (u,v) in the list means that u precedes v in the +||ordering - and returns a total ordering consistent with the +||information given - that is if (u,v) is in the input data, then u will +||come before v in the output list. + +topsort rel = tsort (carrier rel) rel +||the carrier of a relation is the set of all the elements related by it + +tsort c r = [], if c=[] + = error "inconsistent data for tsort", if m=[] + = a : tsort (c--[a]) [(u,v)|(u,v)<-r; u~=a], otherwise + where + a = hd m + m = (c -- ran r) +||remarks on the above +|| - it is an invariant that c contains the carrier of relation r +|| - m is the set of elements of c with no predecessor in r + +||the error case will arise if the input data contains a cycle - i.e. +||if there is an element that directly or indirectly precedes itself. + +||a set is here represented as a list without duplicates +||the standard function mkset removes duplicates from a list + +dom r = mkset [u|(u,v)<-r] ||domain of a relation +ran r = mkset [v|(u,v)<-r] ||range of a relation +carrier r = union (dom r) (ran r) +union x y = mkset (x++y) diff --git a/miralib/ex/treesort.m b/miralib/ex/treesort.m new file mode 100644 index 0000000..e5b946b --- /dev/null +++ b/miralib/ex/treesort.m @@ -0,0 +1,20 @@ +|| Here is another sorting algorithm, this time treesort. +|| to try it out, say: treesort testdata + +tree * ::= NILT | NODE * (tree *) (tree *) + +treesort = flatten.build + +build::[*]->tree * +build = foldr insert NILT + +insert b NILT = NODE b NILT NILT +insert b (NODE a x y) = NODE a (insert b x) y, if b<=a + = NODE a x (insert b y), if b>a + +flatten::tree *->[*] +flatten NILT = [] +flatten (NODE a x y) = flatten x ++ [a] ++ flatten y + +testdata = [1..5]++[20,19..16]++[6..10]++[15,14..11] + diff --git a/miralib/ex/unify.m b/miralib/ex/unify.m new file mode 100644 index 0000000..1ce4034 --- /dev/null +++ b/miralib/ex/unify.m @@ -0,0 +1,79 @@ +||Package for doing (first order) unification, parameterised on an +||abstract theory of expressions. (DT) + +||see the file <ex/polish> for an example of the use of this package. + +%free { expr,operator,var::type; + isvar::expr->bool; getvar::expr->var; putvar::var->expr; + rator::expr->operator; rands::expr->[expr]; + construct::operator->[expr]->expr; + } + +||Our theory of expressions is as follows - an expression is either a +||variable, or else it consists of a rator together with a list of +||rands. So for example a constant will be viewed as a rator which has +||an empty list of rands. The nature of variables, and the collection +||of possible rators and their arities, is determined at %include time. +||This enables us to use the same code for performing unification in +||quite different object languages. + +||for each e::expr, one of the following propositions will be true +||either isvar e & e = putvar(getvar e) +||or ~isvar e & e = construct(rator e)(rands e) + +%export unifyexprs unify ult q + +q * ::= FAIL | SUCCEED * ||useful type operator + +unifyexprs :: expr->expr->q expr ||convenient for testing + +unify :: subst->expr->expr->q subst + +||this implements the unification algorithm - it takes a substition +||(mapping from variables to expressions) and a pair of expressions, and +||returns the least extension of the substitution under which the +||expressions become the same - or FAIL if there is none. + +ult :: subst->expr->expr + +||computes the result of applying a substitution to an expression. + +unifyexprs x y = f(unify [] x y) + where + f FAIL = FAIL + f (SUCCEED s) = SUCCEED (ult s x) + ||note that (ult s y) = (ult s y) + ||if the unification succeeds + +subst == [(var,expr)] + +||We represent a substitution as a list of variable-expression pairs. +||The representation is lazy, in the sense that the expressions may +||contain occurrences of the variables in the domain of the substitution +||- this is taken care of in the definition of ult. + +unify s x y + = unifier s (ult s x) (ult s y) + where + unifier s x y = SUCCEED s, if x=y + = SUCCEED((getvar x,y):s), if isvar x & ~occurs x y + = SUCCEED((getvar y,x):s), if isvar y & ~occurs y x + = unifylist (SUCCEED s) (rands x) (rands y), + if ~isvar x & ~isvar y & conforms x y + = FAIL, otherwise + unifylist qs [] [] = qs + unifylist (SUCCEED s) (a:x) (b:y) = unifylist (unify s a b) x y + unifylist FAIL x y = FAIL + +ult s x = lookup s (getvar x), if isvar x + = construct(rator x)(map (ult s) (rands x)), otherwise + where + lookup [] a = putvar a + lookup ((a,y):t) a = ult s y ||note recursive call of ult + lookup ((b,y):t) a = lookup t a + +occurs y x || does subexpression y occur in formula x ? + = x=y, if isvar x + = or (map (occurs y) (rands x)), otherwise + +conforms x y = rator x = rator y & #rands x = #rands y diff --git a/miralib/helpfile b/miralib/helpfile new file mode 100644 index 0000000..9d28360 --- /dev/null +++ b/miralib/helpfile @@ -0,0 +1,25 @@ +SUMMARY OF MAIN AVAILABLE COMMANDS: + +exp evaluate a Miranda expression +exp &> file send value of expression to file (background process) +exp &>> file append value of expression to file (background process) +exp :: print type of exp +? list all identifiers in scope (grouped by source file) +?identifier(s) give more information about identifier(s) +??identifier open source file at definition of identifier +!command execute any UNIX shell command +!! repeat last shell command +/edit /e edit current script (default editor = vi or joe) +/edit filename edit filename +/file /f display filename of current script +/file filename change to new current script +/help /h display this command summary +/man /m ENTER ONLINE REFERENCE MANUAL (menu driven) +/quit /q quit the Miranda system +/aux /a display list of auxiliary commands + +Notes:- +each "/" command can be abbreviated to its first letter - /e /f /h /m /q +% is shorthand for the name of the current script (in commands) +Special case - note that `/f %' forces recompilation of current script +$$ is shorthand for the last expression evaluated (in expressions) diff --git a/miralib/manual/.epoch b/miralib/manual/.epoch new file mode 100644 index 0000000..01eee68 --- /dev/null +++ b/miralib/manual/.epoch @@ -0,0 +1 @@ +manual pages last revised 31 January 2020 diff --git a/miralib/manual/1 b/miralib/manual/1 new file mode 100644 index 0000000..d3eff94 --- /dev/null +++ b/miralib/manual/1 @@ -0,0 +1,76 @@ +_H_o_w_ _t_o_ _u_s_e_ _t_h_e_ _M_i_r_a_n_d_a_ _o_n_-_l_i_n_e_ _r_e_f_e_r_e_n_c_e_ _m_a_n_u_a_l: + +The manual is menu driven, and is a separate subsystem that can be +invoked from the Miranda command interpreter. To access the manual from +Miranda, type + /man +followed by return. To access the manual directly from the command +line, without entering Miranda first, type the line + mira -man +as a shell command. + +On entering the manual system a contents page is displayed listing +numbered sections. In response to the question at the bottom of the +page you should enter the number of the section you wish to see and +press return (i.e. ENTER). The contents of that section are then +displayed to you. When you are ready to leave the manual, press return, +without giving ay section number, in response to the question at the +foot of the contents page - typing q (for "quit") has the same effect. + +If the section is more than one page long, you should press the space +bar when you have finished reading a page, in order to see the next page +(or press return to see one more line). At the end of the section, you +may press return to go back to the contents page. + +The manual is organised in short sections, each at most two or three +screenfulls long. Where a section would otherwise be too long to fit in +with this philosophy, the manual is organised recursively and will +display a subsidiary contents page, with a list of numbered subsections, +which you may read, as before, by typing the appropriate number. To +return to the main menu from a submenu, press return with no section +number, in response to the question at the bottom of the page. + +The manual is intended to provide online documentation of the Miranda +programming language and the command system in which it is embedded. It +is not intended to be a tutorial on functional programming. It does not +provide information about the operating system, for which separate +documentation is available (but there is a section on the Miranda/UNIX +interface). + +------------------------------------------------------------------------ +_S_u_m_m_a_r_y_ _o_f_ _m_a_n_u_a_l_ _b_e_h_a_v_i_o_u_r_: + +Whenever the manual system prompts the user for input - by asking for +"next selection" - the complete repertoire of possible responses is: + +q quit the manual +<return> exit one level of menu structure + (i.e. if at foot of section, return to menu + if at submenu, return to master menu + if at main menu, quit the manual) +<number> display section from current contents page +. (dot) same again, i.e. redisplay last requested section ++ display next section in numerical order +- display previous section +!command temporary escape to O/S, executes shell command + +------------------------------------------------------------------------ +_S_u_m_m_a_r_y_ _o_f_ _t_h_e_ _b_e_h_a_v_i_o_u_r_ _o_f_ _`_m_o_r_e_'_: + +Individual sections of the manual are displayed to you using the UNIX +program `more' or an equivalent such as `less' (you can change this by +setting an environment variable VIEWER (*)). These programs have their +own UNIX manual page describing their features. The responses you can +give generally include + +[SPACE] display next screenful +[return] display one more line +q (quit) cease showing me this file +b (back) scroll backwards by one screenful +/context search for context (eg a word) +?context search backwards for context +h help + +(*) See the section on Environment Variables under UNIX/Miranda system +interface. + diff --git a/miralib/manual/10 b/miralib/manual/10 new file mode 100644 index 0000000..d4d48b9 --- /dev/null +++ b/miralib/manual/10 @@ -0,0 +1,60 @@ +_I_d_e_n_t_i_f_i_e_r_s + +An identifier consists of a letter followed by zero or more additional +characters which may be letters digits or occurrences of _ or ' +(underscore and single quote) Examples: + x yellow p11d y' GROSS_INCOME +Note that both upper and lower case letters are allowed, and they are +treated as different, so x and X are not the same identifier. There is +no restriction on the length of identifiers, and all the characters are +significant in deciding whether two identifiers are the same. +Identifiers fall into two different classes (called in the formal syntax +`identifier' and `IDENTIFIER') depending on whether their initial letter +is upper or lower case. + +Identifiers are used for three different purposes in Miranda - (i) as +variables, i.e. names for values (note that the names of functions are +also considered to be variables), (ii) as typenames, such as `bool' and +`char', and (iii) as constructors (see section on algebraic types). The +names of constructors must begin with an upper case letter, while +variables and typenames must begin with a lower case letter. + +Reserved words - the following are special symbols of the Miranda +language. + +_a_b_s_t_y_p_e _d_i_v _i_f _m_o_d _o_t_h_e_r_w_i_s_e _r_e_a_d_v_a_l_s _s_h_o_w _t_y_p_e _w_h_e_r_e _w_i_t_h + (10) + +These are often shown as underlined (or bold) in published documents, +but in programs they are typed as ordinary lower case words (which means +that these words cannot be used as identifiers). + +_P_r_e_d_e_f_i_n_e_d_ _i_d_e_n_t_i_f_i_e_r_s + +The following identifiers are normally* predefined and always in scope. +They constitute the `standard environment'. They are defined in the +script "stdenv.m", contained in the directory /usr/lib/miralib. + +(a) predefined typenames + bool char num sys_message + +(b) predefined constructors + False True :: bool + Appendfile Closefile Exit Stderr Stdout System Tofile :: sys_message + +(c) predefined variables + abs and arctan cjustify code concat const converse cos decode digit + drop dropwhile e entier error exp filemode filter foldl foldl1 foldr + foldr1 force fst getenv hd hugenum id index init integer iterate + last lay layn letter limit lines ljustify log log10 map map2 max + max2 member merge min min2 mkset neg numval or pi postfix product + read readb rep repeat reverse rjustify scan seq showfloat showhex + shownum showoct showscaled sin snd sort spaces sqrt subtract sum + system take takewhile tinynum tl transpose undef until zip zip2 zip3 + zip4 zip5 zip6 (91) + +See manual entry `Standard environment' for a listing of its contents. + +[*You can suppress automatic inclusion of <stdenv> by calling mira with + flag "-stdenv". See manual section 31/7 "Options, setup files etc"] + diff --git a/miralib/manual/100 b/miralib/manual/100 new file mode 100644 index 0000000..83fbe5b --- /dev/null +++ b/miralib/manual/100 @@ -0,0 +1,578 @@ +FROM SIGPLAN NOTICES, 21(12):158-166, December 1986. (C) D.A.Turner + + + _A_n_ _O_v_e_r_v_i_e_w_ _o_f_ _M_i_r_a_n_d_a + + David Turner + Computing Laboratory + University of Kent + Canterbury CT2 7NF + ENGLAND + + +Miranda is an advanced functional programming system which runs under +the UNIX operating system (*). The aim of the Miranda system is to +provide a modern functional language, embedded in a convenient +programming environment, suitable both for teaching and as a general +purpose programming tool. The purpose of this short article is to give +a brief overview of the main features of Miranda. The topics we shall +discuss, in order, are: + + Basic ideas + The Miranda programming environment + Guarded equations and block structure + Pattern matching + Currying and higher order functions + List comprehensions + Lazy evaluation and infinite lists + Polymorphic strong typing + User defined types + Type synonyms + Abstract data types + Separate compilation and linking + Current implementation status + +(*) _N_o_t_e: UNIX is a trademark of AT&T Bell Laboratories, Miranda is a + trademark of Research Software Ltd. + +_B_a_s_i_c_ _i_d_e_a_s + The Miranda programming language is purely functional - there are no +side effects or imperative features of any kind. A program (actually we +don't call it a program, we call it a "script") is a collection of +equations defining various functions and data structures which we are +interested in computing. The order in which the equations are given is +not in general significant. There is for example no obligation for the +definition of an entity to precede its first use. Here is a very simple +example of a Miranda script: + z = sq x / sq y + sq n = n * n + x = a + b + y = a - b + a = 10 + b = 5 +Notice the absence of syntactic baggage - Miranda is, by design, rather +terse. There are no mandatory type declarations, although (see later) +the language is strongly typed. There are no semicolons at the end of +definitions - the parsing algorithm makes intelligent use of layout. +Note that the notation for function application is simply juxtaposition, +as in "sq x". In the definition of the sq function, "n" is a formal +parameter - its scope is limited to the equation in which it occurs +(whereas the other names introduced above have the whole script for +their scope). + +The most commonly used data structure is the list, which in Miranda is +written with square brackets and commas, eg: + week_days = ["Mon","Tue","Wed","Thur","Fri"] + days = week_days ++ ["Sat","Sun"] +Lists may be appended by the "++" operator. Other useful operations on +lists include infix ":" which prefixes an element to the front of a +list, "#" which takes the length of a list, and infix "!" which does +subscripting. So for example 0:[1,2,3] has the value [0,1,2,3], #days +is 7, and days!0 is "Mon". + +There is also an operator "--" which does list subtraction. For example +[1,2,3,4,5] -- [2,4] is [1,3,5]. + +There is a shorthand notation using ".." for lists whose elements form +an arithmetic series. Here for example are definitions of the factorial +function, and of a number "result" which is the sum of the odd numbers +between 1 and 100 (sum and product are library functions): + fac n = product [1..n] + result = sum [1,3..100] + +The elements of a list must all be of the same type. A sequence of +elements of mixed type is called a tuple, and is written using +parentheses instead of square brackets. Example + employee = ("Jones",True,False,39) +Tuples are analogous to records in Pascal (whereas lists are analogous +to arrays). Tuples cannot be subscripted - their elements are extracted +by pattern matching (see later). + +_T_h_e_ _p_r_o_g_r_a_m_m_i_n_g_ _e_n_v_i_r_o_n_m_e_n_t + The Miranda system is interactive and runs under UNIX as a self +contained subsystem. The basic action is to evaluate expressions, +supplied by the user at the terminal, in the environment established by +the current script. For example evaluating "z" in the context of the +first script given above would produce the result "9.0". + +The Miranda compiler works in conjunction with an editor (by default +this is "vi" but it can be set to any editor of the user's choice). +Scripts are automatically recompiled after edits, and any syntax or type +errors signalled immediately. The polymorphic type system permits a +high proportion of logical errors to be detected at compile time. + +There is quite a large library of standard functions. There is also an +online reference manual. The interface to UNIX permits Miranda programs +to take data from, and send data to, UNIX files and it is also possible +to invoke Miranda programs directly from the UNIX shell and to combine +them, via UNIX pipes, with processes written in other languages. + +_G_u_a_r_d_e_d_ _e_q_u_a_t_i_o_n_s_ _a_n_d_ _b_l_o_c_k_ _s_t_r_u_c_t_u_r_e + An equation can have several alternative right hand sides distinguished +by "guards" - the guard is written on the right following a comma. For +example the greatest common divisor function can be written: + gcd a b = gcd (a-b) b, _i_f a>b + = gcd a (b-a), _i_f a<b + = a, _i_f a=b + +The last guard in such a series of alternatives can be written +"_o_t_h_e_r_w_i_s_e", instead of "_i_f condition", to indicate a default case(*). + +It is also permitted to introduce local definitions on the right hand +side of a definition, by means of a "where" clause. Consider for +example the following definition of a function for solving quadratic +equations (it either fails or returns a list of one or two real roots): + + quadsolve a b c = error "complex roots", _i_f delta<0 + = [-b/(2*a)], _i_f delta=0 + = [-b/(2*a) + radix/(2*a), + -b/(2*a) - radix/(2*a)], _i_f delta>0 + _w_h_e_r_e + delta = b*b - 4*a*c + radix = sqrt delta + +Where clauses may occur nested, to arbitrary depth, allowing Miranda +programs to be organised with a nested block structure. Indentation of +inner blocks is compulsory, as layout information is used by the parser. + +(*) _N_o_t_e: In early versions of Miranda the keyword _i_f was not required. + +_P_a_t_t_e_r_n_ _m_a_t_c_h_i_n_g + It is permitted to define a function by giving several alternative +equations, distinguished by the use of different patterns in the formal +parameters. This provides another method of doing case analysis which +is often more elegant than the use of guards. We here give some simple +examples of pattern matching on natural numbers, lists and tuples. +Here is (another) definition of the factorial function, and a definition +of Ackermann's function: + fac 0 = 1 + fac (n+1) = (n+1) * fac n + + ack 0 n = n+1 + ack (m+1) 0 = ack m 1 + ack (m+1) (n+1) = ack m (ack (m+1) n) + +Here is a (naive) definition of a function for computing the n'th +Fibonacci number: + fib 0 = 0 + fib 1 = 1 + fib (n+2) = fib (n+1) + fib n + +Here are some simple examples of functions defined by pattern matching +on lists: + sum [] = 0 + sum (a:x) = a + sum x + + product [] = 1 + product (a:x) = a * product x + + reverse [] = [] + reverse (a:x) = reverse x ++ [a] + +Accessing the elements of a tuple is also done by pattern matching. For +example the selection functions on 2-tuples can be defined thus + fst (a,b) = a + snd (a,b) = b + +As final examples we give the definitions of two Miranda library +functions, take and drop, which return the first n members of a list, +and the rest of the list without the first n members, respectively + take 0 x = [] + take (n+1) [] = [] + take (n+1) (a:x) = a : take n x + + drop 0 x = x + drop (n+1) [] = [] + drop (n+1) (a:x) = drop n x + +Notice that the two functions are defined in such a way that that the +following identity always holds - "take n x ++ drop n x = x" - including +in the pathological case that the length of x is less than n. + +_C_u_r_r_y_i_n_g_ _a_n_d_ _h_i_g_h_e_r_ _o_r_d_e_r_ _f_u_n_c_t_i_o_n_s + Miranda is a fully higher order language - functions are first class +citizens and can be both passed as parameters and returned as results. +Function application is left associative, so when we write "f x y" it is +parsed as "(f x) y", meaning that the result of applying f to x is a +function, which is then applied to y. The reader may test out his +understanding of higher order functions by working out what is the value +of "answer" in the following script: + answer = twice twice twice suc 0 + twice f x = f (f x) + suc x = x + 1 + +Note that in Miranda every function of two or more arguments is actually +a higher order function. This is very useful as it permits partial +application. For example "member" is a library function such that +"member x a" tests if the list x contains the element a (returning True +or False as appropriate). By partially applying member we can derive +many useful predicates, such as + vowel = member ['a','e','i','o','u'] + digit = member ['0','1','2','3','4','5','6','7','8','9'] + month = member ["Jan","Feb","Mar","Apr","Jun","Jul","Aug","Sep", + "Oct","Nov","Dec"] + As another example of higher order programming consider the function +foldr, defined + foldr op k [] = k + foldr op k (a:x) = op a (foldr op k x) + +All the standard list processing functions can be obtained by partially +applying foldr. Examples + sum = foldr (+) 0 + product = foldr (*) 1 + reverse = foldr postfix [] + _w_h_e_r_e postfix a x = x ++ [a] + +_L_i_s_t_ _c_o_m_p_r_e_h_e_n_s_i_o_n_s + List comprehensions give a concise syntax for a rather general class of +iterations over lists. The syntax is adapted from an analogous notation +used in set theory (called "set comprehension"). A simple example of a +list comprehension is: + [ n*n | n <- [1..100] ] +This is a list containing (in order) the squares of all the numbers from +1 to 100. The above expression can be read as "list of all n*n such +that n is drawn from the list 1 to 100". Note that "n" is a local +variable of the above expression. The variable-binding construct to the +right of the bar is called a "generator" - the "<-" sign denotes that +the variable introduced on its left ranges over all the elements of the +list on its right. The general form of a list comprehension in Miranda +is: + [ body | qualifiers ] +Each qualifier is either a generator, of the form var<-exp, or else a +filter, which is a boolean expression used to restrict the ranges of the +variables introduced by the generators. When two or more qualifiers are +present they are separated by semicolons. An example of a list +comprehension with two generators is given by the following definition +of a function for returning a list of all the permutations of a given +list, + perms [] = [[]] + perms x = [ a:y | a <- x; y <- perms (x--[a]) ] + +The use of a filter is shown by the following definition of a function +which takes a number and returns a list of all its factors, + factors n = [ i | i <- [1..n _d_i_v 2]; n _m_o_d i = 0 ] + +List comprehensions often allow remarkable conciseness of expression. +We give two examples. Here is a Miranda statement of Hoare's +"Quicksort" algorithm, as a method of sorting a list, + sort [] = [] + sort (a:x) = sort [ b | b <- x; b<=a ] + ++ [a] ++ + sort [ b | b <- x; b>a ] + +Next is a Miranda solution to the eight queens problem. We have to +place eight queens on chess board so that no queen gives check to any +other. Since any solution must have exactly one queen in each column, a +suitable representation for a board is a list of integers giving the row +number of the queen in each successive column. In the following script +the function "queens n" returns all safe ways to place queens on the +first n columns. A list of all solutions to the eight queens problem is +therefore obtained by printing the value of (queens 8) + queens 0 = [[]] + queens (n+1) = [ q:b | b <- queens n; q <- [0..7]; safe q b ] + safe q b = and [ ~checks q b i | i <- [0..#b-1] ] + checks q b i = q=b!i \/ abs(q - b!i)=i+1 + +_L_a_z_y_ _e_v_a_l_u_a_t_i_o_n_ _a_n_d_ _i_n_f_i_n_i_t_e_ _l_i_s_t_s + Miranda's evaluation mechanism is "lazy", in the sense that no +subexpression is evaluated until its value is known to be required. One +consequence of this is that is possible to define functions which are +non-strict (meaning that they are capable of returning an answer even if +one of their arguments is undefined). For example we can define a +conditional function as follows, + cond True x y = x + cond False x y = y +and then use it in such situations as "cond (x=0) 0 (1/x)". + +The other main consequence of lazy evaluation is that it makes it +possible to write down definitions of infinite data structures. Here +are some examples of Miranda definitions of infinite lists (note that +there is a modified form of the ".." notation for endless arithmetic +progressions) + ones = 1 : ones + repeat a = x + _w_h_e_r_e x = a : x + nats = [0..] + odds = [1,3..] + squares = [ n*n | n <- [0..] ] + perfects = [ n | n <- [1..]; sum(factors n) = n ] + primes = sieve [ 2.. ] + _w_h_e_r_e + sieve (p:x) = p : sieve [ n | n <- x; n _m_o_d p > 0 ] + +One interesting application of infinite lists is to act as lookup tables +for caching the values of a function. For example our earlier naive +definition of "fib" can be improved from exponential to linear +complexity by changing the recursion to use a lookup table, thus + fib 0 = 1 + fib 1 = 1 + fib (n+2) = flist!(n+1) + flist!n + _w_h_e_r_e + flist = map fib [ 0.. ] + +Another important use of infinite lists is that they enable us to write +functional programs representing networks of communicating processes. +Consider for example the Hamming numbers problem - we have to print in +ascending order all numbers of the form 2^a*3^b*5^c, for a,b,c>=0. +There is a nice solution to this problem in terms of communicating +processes, which can be expressed in Miranda as follows + hamming = 1 : merge (f 2) (merge (f 3) (f 5)) + _w_h_e_r_e + f a = [ n*a | n <- hamming ] + merge (a:x) (b:y) = a : merge x (b:y), _i_f a<b + = b : merge (a:x) y, _i_f a>b + = a : merge x y, _o_t_h_e_r_w_i_s_e + +_P_o_l_y_m_o_r_p_h_i_c_ _s_t_r_o_n_g_ _t_y_p_i_n_g + Miranda is strongly typed. That is, every expression and every +subexpression has a type, which can be deduced at compile time, and any +inconsistency in the type structure of a script results in a compile +time error message. We here briefly summarise Miranda's notation for +its types. + +There are three primitive types, called num, bool, and char. The type +num comprises integer and floating point numbers (the distinction +between integers and floating point numbers is handled at run time - +this is not regarded as being a type distinction). There are two values +of type bool, called True and False. The type char comprises the +Latin-1 character set - character constants are written in single +quotes, using C escape conventions, e.g. 'a', '$', '\n' etc. + +If T is type, then [T] is the type of lists whose elements are of type +T. For example [[1,2],[2,3],[4,5]] is of type [[num]], that is list of +lists of numbers. String constants are of type [char], in fact a string +such as "hello" is simply a shorthand way of writing +['h','e','l','l','o']. + +If T1 to Tn are types, then (T1, ... ,Tn) is the type of tuples with +objects of these types as components. For example (True,"hello",36) is +of type (bool,[char],num). + +If T1 and T2 are types, then T1->T2 is the type of a function with +arguments in T1 and results in T2. For example the function sum is of +type [num]->num. The function quadsolve, given earlier, is of type +num->num->num->[num]. Note that "->" is right associative. + +Miranda scripts can include type declarations. These are written using +"::" to mean is of type. Example + sq :: num -> num + sq n = n * n +The type declaration is not necessary, however. The compiler is always +able to deduce the type of an identifier from its defining equation. +Miranda scripts often contain type declarations as these are useful for +documentation (and they provide an extra check, since the typechecker +will complain if the declared type is inconsistent with the inferred +one). + +Types can be polymorphic, in the sense of [Milner 1978]. This is +indicated by using the symbols * ** *** etc. as an alphabet of generic +type variables. For example, the identity function, defined in the +Miranda library as + id x = x +has the following type + id :: * -> * +this means that the identity function has many types. Namely all those +which can be obtained by substituting an arbitrary type for the generic +type variable, eg "num->num", "bool->bool", "(*->**) -> (*->**)" and so +on. + +We illustrate the Miranda type system by giving types for some of the +functions so far defined in this article + fac :: num -> num + ack :: num -> num -> num + sum :: [num] -> num + month :: [char] -> bool + reverse :: [*] -> [*] + fst :: (*,**) -> * + snd :: (*,**) -> ** + foldr :: (*->**->**) -> ** -> [*] -> ** + perms :: [*] -> [[*]] + +_U_s_e_r_ _d_e_f_i_n_e_d_ _t_y_p_e_s + The user may introduce new types. This is done by an equation in +"::=". For example a type of labelled binary trees (with numeric +labels) would be introduced as follows, + tree ::= Nilt | Node num tree tree + +This introduces three new identifiers - "tree" which is the name of the +type, and "Nilt" and "Node" which are the constructors for trees - note +that constructors must begin with an upper case letter. Nilt is an +atomic constructor, while Node takes three arguments, of the types +shown. Here is an example of a tree built using these constructors + t1 = Node 7 (Node 3 Nilt Nilt) (Node 4 Nilt Nilt) + +To analyse an object of user defined type, we use pattern matching. For +example here is a definition of a function for taking the mirror image +of a tree + mirror Nilt = Nilt + mirror (Node a x y) = Node a (mirror y) (mirror x) + +User defined types can be polymorphic - this is shown by introducing one +or more generic type variables as parameters of the "::=" equation. For +example we can generalise the definition of tree to allow arbitrary +labels, thus + tree * ::= Nilt | Node * (tree *) (tree *) +this introduces a family of tree types, including tree num, tree bool, +tree (char->char), and so on. + +The types introduced by "::=" definitions are called "algebraic types". +Algebraic types are a very general idea. They include scalar +enumeration types, eg + color ::= Red | Orange | Yellow | Green | Blue | Indigo | Violet + +and also give us a way to do union types, for example + bool_or_num ::= Left bool | Right num + +It is interesting to note that all the basic data types of Miranda could +be defined from first principles, using "::=" equations. For example +here are type definitions for bool, (natural) numbers and lists, + bool ::= True | False + nat ::= Zero | Suc nat + list * ::= Nil | Cons * (list *) +Having types such as "num" built in is done for reasons of efficiency - +it isn't logically necessary. + +_N_o_t_e: In versions of Miranda before release two (1989) it was possible +to associate "laws" with the constructors of an algebraic type, which +are applied whenever an object of the type is built. For details see +[Turner 1985, Thompson 1986]. This feature was little used and since +has been removed from the language. + +_T_y_p_e_ _s_y_n_o_n_y_m_s + The Miranda programmer can introduce a new name for an already existing +type. We use "==" for these definitions, to distinguish them from +ordinary value definitions. Examples + string == [char] + matrix == [[num]] + +Type synonyms are entirely transparent to the typechecker - it is best +to think of them as macros. It is also possible to introduce synonyms +for families of types. This is done by using generic type symbols as +formal parameters, as in + array * == [[*]] +so now eg `array num' is the same type as `matrix'. + +_A_b_s_t_r_a_c_t_ _d_a_t_a_ _t_y_p_e_s + In addition to concrete types, introduced by "::=" or "==" equations, +Miranda permits the definition of abstract types, whose implementation +is "hidden" from the rest of the program. To show how this works we +give the standard example of defining stack as an abstract data type +(here based on lists): + + _a_b_s_t_y_p_e stack * + _w_i_t_h empty :: stack * + isempty :: stack * -> bool + push :: * -> stack * -> stack * + pop :: stack * -> stack * + top :: stack * -> * + + stack * == [*] + empty = [] + isempty x = (x=[]) + push a x = (a:x) + pop (a:x) = x + top (a:x) = a + +We see that the definition of an abstract data type consists of two +parts. First a declaration of the form "abstype ... with ...", where +the names following the "with" are called the _s_i_g_n_a_t_u_r_e of the abstract +data type. These names are the interface between the abstract data type +and the rest of the program. Then a set of equations giving bindings +for the names introduced in the abstype declaration. These are called +the _i_m_p_l_e_m_e_n_t_a_t_i_o_n _e_q_u_a_t_i_o_n_s. + +The type abstraction is enforced by the typechecker. The mechanism +works as follows. When typechecking the implementation equations the +abstract type and its representation are treated as being the same type. +In the whole of the rest of the script the abstract type and its +representation are treated as two separate and completely unrelated +types. This is somewhat different from the usual mechanism for +implementing abstract data types, but has a number of advantages. It is +discussed at somewhat greater length in [Turner 85]. + +_S_e_p_a_r_a_t_e_ _c_o_m_p_i_l_a_t_i_o_n_ _a_n_d_ _l_i_n_k_i_n_g + The basic mechanisms for separate compilation and linking are extremely +simple. Any Miranda script can contain one or more directives of the +form + %include "pathname" +where "pathname" is the name of another Miranda script file (which might +itself contain include directives, and so on recursively - cycles in the +include structure are not permitted however). The visibility of names +to an including script is controlled by a directive in the included +script, of the form + %export names +It is permitted to export types as well as values. It is not permitted +to export a value to a place where its type is unknown, so if you export +an object of a locally defined type, the typename must be exported also. +Exporting the name of a "::=" type automatically exports all its +constructors. If a script does not contain an export directive, then +the default is that all the names (and typenames) it defines will be +exported (but not those which it acquired by %include statements). + +It is also permitted to write a _p_a_r_a_m_e_t_r_i_s_e_d script, in which certain +names and/or typenames are declared as "free". An example is that we +might wish to write a package for doing matrix algebra without knowing +what the type of the matrix elements are going to be. A header for such +a package could look like this: + %free { element :: type + zero, unit :: element + mult, add, subtract, divide :: element->element->element + } + + %export matmult determinant eigenvalues eigenvectors ... + || here would follow definitions of matmult, determinant, + || eigenvalues, etc. in terms of the free identifiers zero, + || unit, mult, add, subtract, divide + +In the using script, the corresponding %include statement must give a +set of bindings for the free variables of the included script. For +example here is an instantiation of the matrix package sketched above, +with real numbers as the chosen element type: + %include "matrix_pack" + { element == num; zero = 0; unit = 1 + mult = *; add = +; subtract = -; divide = / + } + +The three directives %include, %export and %free provide the Miranda +programmer with a flexible and type secure mechanism for structuring +larger pieces of software from libraries of smaller components. + +Separate compilation is administered without user intervention. Each +file containing a Miranda script is shadowed by an object code file +created by the system and object code files are automatically recreated +and relinked if they become out of date with respect to any relevant +source. (This behaviour is similar to that achieved by the +UNIX program "make", except that here the user is not required to write +a makefile - the necessary dependency information is inferred from the +%include directives in the Miranda source.) + +_C_u_r_r_e_n_t_ _i_m_p_l_e_m_e_n_t_a_t_i_o_n_ _s_t_a_t_u_s + An implementation of Miranda is available for a range of UNIX machines +including SUN-4/Sparc, DEC Alpha, MIPS, Apollo, Sequent Symmetry, +Sequent Balance, Silicon Graphics, IBM RS/6000, HP9000, PC/Linux. This +is an interpretive implementation which works by compiling Miranda +scripts to an intermediate code based on combinators. It is currently +running at 550 sites (as of August 1996). + +Licensing information can be obtained from the world wide web at + http://miranda.org.uk + + +REFERENCES + +Milner, R. "A Theory of Type Polymorphism in Programming" Journal of +Computer and System Sciences, vol 17, 1978. + +Thompson, S.J. "Laws in Miranda" Proceedings 4th ACM International +Conference on LISP and Functional Programming, Boston Mass, August 1986. + +Turner, D.A. "Miranda: A non-strict functional language with +polymorphic types" Proceedings IFIP International Conference on +Functional Programming Languages and Computer Architecture, Nancy +France, September 1985 (Springer Lecture Notes in Computer Science, vol +201). + +[Note - this overview of Miranda first appeared in SIGPLAN Notices, +December 1986. It has here been revised slightly to bring it up to +date.] + diff --git a/miralib/manual/11 b/miralib/manual/11 new file mode 100644 index 0000000..5830c60 --- /dev/null +++ b/miralib/manual/11 @@ -0,0 +1,86 @@ +_L_i_t_e_r_a_l_s + +Miranda has three types of literal constant - numerals, character +constants and string constants. + +Numerals are written in the following style + 12 5237563 24.6 4.5e13 0.63e-6 +A numeral containing decimal point and/or scale factor (`.' or `e') is +held internally as double precision (=64 bit) floating point, accuracy +approximately 17 significant figures. Integers are held in a different +internal representation, and have unbounded precision. + +The two kinds of number, integer and floating point, are both of type +`num', as far as the type-checker is concerned, and can be freely mixed +in calculations. There is automatic conversion from integer to float +when required, but not in the opposite direction. To convert from +floating point to integer, use `entier' (see standard environment). + +Negative numbers are denoted by applying the prefix `-' operator to a +numeral, thus: + -12 -4.5e13 +but note that the notation -12 is an expression, not a literal, so if +you wish to apply a function to it, you must write f (-12), not f -12, +which would be read as an attempt to subtract 12 from f. + +Integers can be written in hexadecimal (base 16) or octal (base 8) +notation starting with 0x or 0o, e.g. 4095 can also be written as 0xfff +or 0o7777. Floating point numbers can be expressed in hexadecimal +notation, optionally scaled by `p' followed by a power of 2. For +example 0x1.0p-2 means 0.25. + +Character constants are written using single quotes, thus + 'a' '0' '\n' +The type `char' includes all Unicode* characters, those outside ascii +and Latin-1 can be expressed by numeric escape codes, see below. + +Note that the functions code::char->num, decode::num->char convert +characters to and from their numeric codes. + +String constants are written using double quotes, thus + "hello dolly" "" "\n\n\n" + +Escape conventions in character and string constants are as in `C', +using the backslash character. + \' single quote + \" double quote + \\ the \ character itself + \a alarm + \b backspace + \f formfeed + \n newline + \r carriage return + \t tab + \v vertical tab +plus these numeric escapes which specify characters by code number. + \ddd up to 3 decimal digits [0-9] + \xffff up to 4 hex digits [0-9a-f] + \Xffffff up to 6 hex digits + +For escape codes to \999 you can use either decimal or hex, for example +the DELETE character can be written as \127 or \x7f. The \x and \X +forms cover the whole range of Unicode values. For example '\x3b3' is +the Greek letter lower case gamma and '\x20ac' is the euro sign. The \X +form is unlikely to be needed but is provided for completeness. + +Specifying a character by numeric code in a string or char constant has +the same effect as including it literally, so for example "£" and +"\163" are exactly the same string. + +Where a numeric escape code in a string is followed by a literal digit +(or hex digit for \x \X) the numeral can be padded with leading 0s to +force the correct parse. For example "\0078" is the alarm character \7 +followed by a literal '8', while "\78" is "N". + +Literal newlines are allowed inside string quotes if escaped by a +preceding backslash, in which case the newline is ignored (as in C). +Thus the string "hello dolly" can equally be written + "hello \ +dolly" + +A literal newline is not allowed inside character quotes. + +[* Unicode is an international standard providing numeric codes for the + symbols of practically all known human writing systems. Unicode + points 0-127 coincide with ascii and 128-255 with Latin-1.] + diff --git a/miralib/manual/12 b/miralib/manual/12 new file mode 100644 index 0000000..a464473 --- /dev/null +++ b/miralib/manual/12 @@ -0,0 +1,86 @@ +_T_o_k_e_n_i_s_a_t_i_o_n_ _a_n_d_ _l_a_y_o_u_t + +A Miranda script or expression is regarded as being composed of _t_o_k_e_n_s, +separated by _l_a_y_o_u_t. + +A token is one of the following - an identifier, a literal, a type +variable, or a delimiter. Identifiers and literals each have their own +manual section. A type variable is a sequence of one or more stars, +thus * ** *** etc. (see basic type structure). Delimiters are the +miscellaneous symbols, such as operators, parentheses, and keywords. A +formal definition of the syntax of tokens, including a list of all the +delimiters in given under `Miranda lexical syntax'. + +_R_U_L_E_S_ _A_B_O_U_T_ _L_A_Y_O_U_T + +Layout consists of white space characters (spaces, tabs, newlines and +formfeeds), and comments. A comment consists of a pair of adjacent +vertical bars, together with all the text to the right of the bars on +the same line. Thus + || this is a comment +Layout is not permitted inside tokens (except in char and string +constants, where it is significant) but may be inserted freely between +tokens to make scripts more readable. Layout is ignored by the compiler +except in two respects: + +1) At least one space (or other layout characters) must be present +between two tokens that would otherwise form an instance of a single +larger token. For example in + f 19 'b' +we have a function, f, applied to a number and a character, but if we +were to omit the two intervening spaces, the compiler would read this as +a single six-character identifier, because both digits and single-quotes +are legal characters in an identifier. (Where it is not required to +force the correct tokenisation, or because of the offside rule, see +below, the presence of layout between tokens is optional.) + +2) Certain syntactic objects (roughly, the right hand sides of +declarations -- for an exact account see those entities followed by a +`(;)' in the formal syntax) obey Landin's _o_f_f_s_i_d_e _r_u_l_e [Landin 1966]. +This requires that every token of the object lie either directly below +or to the right of its first token. A token which breaks this rule is +said to be `offside' with respect to that object and terminates its +parse. For example in + x = 2 < a + y = f q +the 'y' is offside with respect to the right hand side of the definition +of 'x' (because it is to the left of the initial '2'). In such a case +the trailing semicolon may be omitted from the right hand side of the +equation for x. + +It is because of the offside rule that Miranda scripts do not normally +contain explicit semicolons as terminators for definitions. The same +rule enables the compiler to determine the scopes of nested _w_h_e_r_e's by +looking at their indentation levels. For example in + f x = g y z + _w_h_e_r_e + y = (x+1)*(x-1) + z = p x (q y) + g r = groo (r+1) + +it is the offside rule which makes it clear that the definition of 'g' +is not local to the right hand side of the definition of 'f', but those +of 'y' and 'z' are. + +It is always possible to terminate a right hand side by an EXPLICIT +semicolon, instead of relying on the offside rule. For example the +above script could be written all in one line, as + f x = g y z _w_h_e_r_e y = (x+1)*(x-1); z = p x (q y);; g r = groo (r+1); + +Notice that we need TWO semicolons after the definition of z - the first +terminates the rhs of the definition of `z', and the second terminates +the larger rhs of which it is a part, namely that of the definition of +`f'. If we put only one semicolon at this point, the definition of `g' +would be local to that of `f'. + +This example should convince the reader that code using layout +information to show the block structure is much more readable, and this +is the normal practise. + +[_R_e_f_e_r_e_n_c_e P.J. Landin "The Next 700 Programming Languages", CACM vol 9 +pp157-165 (March 1966).] + +Note that an additional comment convention applies in scripts whose +first character is a `>'. See separate manual entry on `literate +scripts'. + diff --git a/miralib/manual/13/1 b/miralib/manual/13/1 new file mode 100644 index 0000000..c5e9198 --- /dev/null +++ b/miralib/manual/13/1 @@ -0,0 +1,22 @@ +_D_o_t_d_o_t_ _n_o_t_a_t_i_o_n + +The following abbreviations are provided for denoting lists, of type +[num], whose members form a finite or infinite arithmetic series. Let +`a', `b', `c' stand for arbitrary numeric expressions. + + [a..b] list of numbers from a to b inclusive, interval = 1 + [a..] infinite list starting at a and increasing by 1 + [a,b..c] arithmetic series, first member a, second member b, + last member not greater than c (if b-a non-negative) + or not less than c (if b-a negative). + [a,b..] infinite series starting at a, interval = (b-a) + +So the notation [1..10] has as value the list [1,2,3,4,5,6,7,8,9,10]. +Here are some more examples + + nats = [0..] + evens = [0,2..] + odds_less_than_100 = [1,3..99] + neg_odds = [-1,-3..] + tenths = [1.0,1.1 .. 2.0] + diff --git a/miralib/manual/13/2 b/miralib/manual/13/2 new file mode 100644 index 0000000..2e86d88 --- /dev/null +++ b/miralib/manual/13/2 @@ -0,0 +1,68 @@ +_L_i_s_t_ _c_o_m_p_r_e_h_e_n_s_i_o_n_s + + [exp | qualifiers] + +List of all `exp' such that `qualifiers'. If there are two or more +qualifiers they are separated by semicolons. Each qualifier is either a +generator, of which the allowed forms are + + pattern-list <- exp (first form) + + pattern <- exp, exp .. (second form) + +or else a filter, which is a boolean expression restricting the range of +the variables introduced by preceding generators. The variables +introduced on the left of each `<-' are local to the list comprehension. + +Some examples + + sqs = [ n*n | n<-[1..] ] + + factors n = [ r | r<-[1..n div 2]; n mod r = 0 ] + + knights_moves [i,j] = [ [i+a,j+b] | a,b<-[-2..2]; a^2+b^2=5 ] + +Notice that a list of variables on the lhs of a `<-' is shorthand for +multiple generators, e.g. `i,j<-thing' expands to `i<-thing; j<-thing'. + +The variables introduced by the generators come into scope from left to +right, so later generators can make use of variables introduced by +earlier ones. An example of this is shown by the following definition +of a function for generating all the permutations of a given list. + + perms [] = [[]] + perms x = [ a:p | a<-x; p<-perms(x--[a]) ] + +The second form of generator allows the construction of lists from +arbitrary recurrence relations, thus + x <- a, f x .. +causes x to assume in turn the values `a', `f a', `f(f a)', etc. + +An example of its use is in the following definition of the fibonacci +series + + fibs = [ a | (a,b) <- (1,1), (b,a+b) .. ] + +Another example is given by the following expression which lists the +powers of two + + [ n | n <- 1, 2*n .. ] + +The order of enumeration of a list comprehension with multiple +generators is like that of nested for-loops, with the rightmost +generator as the innermost loop. For example the value of the +comprehension [ f x y | x<-[1..4]; y<-[1..4] ] is + + [ f 1 1, f 1 2, f 1 3, f 1 4, f 2 1, f 2 2, f 2 3, f 2 4, + f 3 1, f 3 2, f 3 3, f 3 4, f 4 1, f 4 2, f 4 3, f 4 4 ] + +As a consequence of this order of enumeration of multiple generators, if +any generator other than the first (leftmost) is infinite, some +combinations of values will never be reached in the enumeration. To +overcome this a second, _d_i_a_g_o_n_a_l_i_s_i_n_g, form of list comprehension is +provided (see separate manual section). + +Note that list comprehensions do NOT remove duplicates from the result +list. To remove duplicates from a list, apply the standard function +`mkset'. + diff --git a/miralib/manual/13/3 b/miralib/manual/13/3 new file mode 100644 index 0000000..9cfbf11 --- /dev/null +++ b/miralib/manual/13/3 @@ -0,0 +1,33 @@ +_D_i_a_g_o_n_a_l_i_s_i_n_g_ _l_i_s_t_ _c_o_m_p_r_e_h_e_n_s_i_o_n_s + + [ exp // qualifiers ] + +Syntax and scope rules exactly as for standard list comprehensions, the +only difference being the use of `//' in place of the vertical bar. The +order of enumeration of the generators is such that it is guaranteed +that every possible combination of values will be reached eventually. +The diagonalisation algorithm used is "fair" in the sense that it gives +equal priority to all of the generators. + +For example the value of [f x y//x<-[1..4]; y<-[1..4]] is + + [ f 1 1, f 1 2, f 2 1, f 1 3, f 2 2, f 3 1, f 1 4, f 2 3, + f 3 2, f 4 1, f 2 4, f 3 3, f 4 2, f 3 4, f 4 3, f 4 4 ] + +The algorithm used used is "Cantorian diagonalisation" - imagine the +possible combinations of values from the two generators laid out in a +(perhaps infinite) rectangular array, and traverse each diagonal in turn +starting from the origin. The appropriate higher-dimensional analogue +of this algorithm is used for the case of a list comprehension with +three or more generators. + +As an example of an enumeration that could not be defined at all using a +standard list comprehension, because of the presence of several infinite +generators, here is a definition of the list of all pythagorean +triangles (right-angled triangles with integer sides) + + pyths = [(a,b,c)//a,b,c<-[1..];a^2+b^2=c^2] + +In the case that there is only one generator, the use of `//' instead of +`|' makes no difference to the meaning of the list comprehension. + diff --git a/miralib/manual/13/contents b/miralib/manual/13/contents new file mode 100644 index 0000000..543af82 --- /dev/null +++ b/miralib/manual/13/contents @@ -0,0 +1,6 @@ +_I_t_e_r_a_t_i_v_e_ _e_x_p_r_e_s_s_i_o_n_s + + 1. Dotdot expression + 2. List comprehensions + 3. Diagonalising list comprehensions + diff --git a/miralib/manual/14 b/miralib/manual/14 new file mode 100644 index 0000000..87d56f5 --- /dev/null +++ b/miralib/manual/14 @@ -0,0 +1,66 @@ +_S_c_r_i_p_t_s + +In Miranda the script is the persistent entity that is saved from +session to session (i.e. it plays the role of what is called a program +in conventional languages). Associated with a Miranda session at any +given time is a single current script, identified by a UNIX pathname +ending in `.m'. + +A script is a collection of declarations, establishing an environment in +which you wish to evaluate expressions. The order of the declarations +in a script is not significant - for example there is no requirement +that an identifier be defined before it is used. + +An identifier may not have more than one top-level binding in a given +script. + +Here are the kinds of declaration that can occur in a script: + +1) a definition (of a function, data structure etc. - see manual entry +`definitions' for more details). Example + fac n = product[1..n] + +2) a specification of the type of one or more identifiers, of the form + var-list :: <type> +Example + fac :: num->num +See 'Basic type structure' for an account of possible types. Note that +these type specifications are normally optional, since the compiler is +able to deduce them from the definitions of the corresponding +identifiers. It is however possible to introduce an identifier by means +of a type specification only, without giving it a defining equation +(such identifiers are said to be `specified but not defined' and are +useful in program development). A special case of this is the +introduction of an otherwise undefined typename - see separate manual +entry on `placeholder types'. + +3) the definition of a user defined type - these are of three kinds, +synonyms, algebraic types, and abstract types (see separate manual entry +on each). + +4) a library directive (%export, %include or %free) these are used +specify the interfaces between separately compiled scripts - see +separate manual entry on the library mechanism. + +There is a manual entry giving the formal syntax of Miranda scripts. + +_N_o_t_e + A directory called `ex' (meaning `examples') containing a collection of +example scripts is supplied with the Miranda system, and will be found +under the `miralib' directory (usually kept at /usr/lib/miralib - the +Miranda session command `/miralib' will tell you where it is on your +system). + +A convention which the Miranda system consistently understands in +Miranda session commands, library directives etc. is that a pathname +enclosed in <angle_brackets>, instead of "string_quotes" is relative to +the miralib directory. In particular note that the Miranda session +command + /cd <ex> +will change your current directory to be "..../miralib/ex". You can +then say, e.g. + !ls +to see what's in there. In fact there is a README file, so a good thing +to say next would be + !vi README + diff --git a/miralib/manual/15 b/miralib/manual/15 new file mode 100644 index 0000000..e299ae3 --- /dev/null +++ b/miralib/manual/15 @@ -0,0 +1,92 @@ +_D_e_f_i_n_i_t_i_o_n_s + +The purpose of a definition is to give a value to one or more variables. +There are two kinds of definition, `scalar' and `conformal'. A scalar +definition gives a value to a single variable, and consists of one or +more consecutive equations of the form + fnform = rhs + +where a `fnform' consists of the name being defined followed by zero or +more formal parameters. Here are three examples of scalar definitions, +of `answer', `sqdiff' and `equal' respectively + answer = 42 + + sqdiff a b = a^2 - b^2 + + equal a a = True + equal a b = False + +When a scalar definition consists of more than one equation, the order +of the equations can be significant, as the last example shows. (Notice +that `equals' as defined here is a function of two arguments with the +same action as the built in `=' operator of boolean expressions.) + +A conformal definition gives values to several variables simultaneously +and is an equation of the form + pattern = rhs + +An example of this kind of definition is + (x,y,z) = ploggle + +For this to make sense, the value of `ploggle' must of course be a +3-tuple. More information about the _p_a_t_t_e_r_n _m_a_t_c_h_i_n_g aspect of +definitions is given in the manual section of that name. + +Both fnform and pattern equations share a common notion of `right hand +side' + +_R_i_g_h_t_ _h_a_n_d_ _s_i_d_e_s + +The simplest form of rhs is just an expression (as in all the equations +above). It is also possible to give several alternative expressions, +distinguished by guards. A guard consists of the word `if' followed by +a boolean expression. An example of a right hand side with several +alternatives is given by the following definition of the greatest common +divisor function, using Euclid's algorithm + gcd a b = gcd (a-b) b, _i_f a>b + = gcd a (b-a), _i_f a<b + = a, _i_f a=b + +Note that the guards are written on the right, following a comma. The +layout is significant (because the offside rule is used to resolve any +ambiguities in the parse). + +The last guard can be written `otherwise', to indicate that this is the +case which applies if all the other guards are false. For example the +correct rule for recognising a leap year can be written: + leap y = y _d_i_v 400 = 0, _i_f y _m_o_d 100 = 0 + = y _d_i_v 4 = 0, _o_t_h_e_r_w_i_s_e + +The _o_t_h_e_r_w_i_s_e may here be regarded as standing for _i_f y _m_o_d 100 ~= 0. +In the general case it abbreviates the conjunction of the negation of +all the previous guards, and may be used to avoid writing out a long +boolean expression. + +Although it is better style to write guards that are mutually exclusive, +this is not something the compiler can enforce - in the general case the +alternative selected is the first (in the order they are written) whose +guard evaluates to True. + +[In older versions of Miranda the presence of the keyword `if' after the +guard comma was optional.] + +_B_l_o_c_k_ _s_t_r_u_c_t_u_r_e + +A right hand side can be qualified by a _w_h_e_r_e clause. This is written +after the last alternative. The bindings introduced by the _w_h_e_r_e govern +the whole rhs, including the guards. Example + foo x = p + q, _i_f p<q + = p - q, _i_f p>=q + _w_h_e_r_e + p = x^2 + 1 + q = 3*x^3 - 5 + +Notice that the whole _w_h_e_r_e clause must be indented, to show that it is +part of the rhs. Following a _w_h_e_r_e can be any number of definitions, +and the syntax of such local definitions is exactly the same as that for +top level definitions (including therefore, recursively, the possibility +that they may contain nested _w_h_e_r_e's). + +It is not permitted to have locally defined types, however. New +typenames can be introduced only at top level. + diff --git a/miralib/manual/16 b/miralib/manual/16 new file mode 100644 index 0000000..143a27d --- /dev/null +++ b/miralib/manual/16 @@ -0,0 +1,174 @@ +_P_a_t_t_e_r_n_ _M_a_t_c_h_i_n_g + +The notion of `pattern' plays an important role in Miranda. There are +three contexts in which patterns can be used - in function definitions, +in conformal definitions, and on the left of the `<-' in list +comprehensions. We first explain the general rules for pattern +formation, which are the same in all three contexts. + +Patterns are built from variables and constants, using constructors. +Here are some simple examples. + x + 3 + (x,y,3) +The first pattern is just the variable x, the second is the constant 3, +the last example is built from two variables and a constant, using the +(,,) constructor for 3-tuples. The components of a structured pattern +can themselves be arbitrary patterns, permitting nested structures of +any depth. + +A pattern can also contain repeated variables, e.g. `(x,1,x)'. A +pattern containing repeated variables matches a value only when the +parts of the value corresponding to occurrences of the same variable are +equal. + +The constructors which can be used in a pattern include those of tuple +formation `(..,..)', list formation `[..,..]', and the constructors of +any user defined Algebraic Type (see separate manual section). In +addition there are special facilities for matching on lists and natural +numbers, as follows. + +(Lists) The `:' operator can be used in patterns, so for example the +following three patterns are all equivalent (and will match any 2-list). + a:b:[] + a:[b] + [a,b] +Note that `:' is right associative (see manual section on Operators). + +(Natural numbers) It is permitted to write patterns of the form `p+k' +where p is a pattern and k is a literal integer constant. This +construction will succeed in matching a value n, if and only if n is an +integer >=k, and in this case p is bound to (n-k). Example, `y+1' +matches any positive integer, and `y' gets bound to the +integer-minus-one. + +Note that the automatic coercion from integer to floating point, which +takes place in expression evaluation, does not occur in pattern +matching. An integer pattern such as `3' or `n+1' will not match any +floating point number. It is not permitted to write patterns containing +floating point constants. + +_C_a_s_e_ _a_n_a_l_y_s_i_s + +The main use of pattern matching in Miranda is in the left hand side of +function definitions. In the simplest case a pattern is used simply to +provide the right hand side of the function definition with names for +subcomponents of a data structure. For example, functions for accessing +the elements of a 2-tuple may be defined, + fst_of_two (a,b) = a + snd_of_two (a,b) = b + +More generally a function can be defined by giving a series of +equations, in which the use of different patterns on the left expresses +case analysis on the argument(s). Some simple examples + factorial 0 = 1 + factorial(n+1) = (n+1)*factorial n + + reverse [] = [] + reverse (a:x) = reverse x ++ [a] + + last [a] = a + last (a:x) = last x, if x~=[] + last [] = error "last of empty list" + +Many more examples can be found in the definition of the standard +environment (see separate manual section). Note that pattern matching +can be combined with the use of guards (see last example above). +Patterns in a case analysis do not have to be mutually exclusive +(although as a matter of programming style that is good practice) - the +rule is that cases are tried in order from top to bottom, and the first +equation which `matches' is used. + +_C_o_n_f_o_r_m_a_l_ _d_e_f_i_n_i_t_i_o_n_s + +Apart from the simple case where the pattern is a single variable, the +construction + pattern = rhs + +is called a `conformal definition'. If the value of the right hand hand +side matches the structure of the given pattern, the variables on the +left are bound to the corresponding components of the value. Example + [a,b,3] = [1,2,3] + +defines a and b to have the values 1 and 2 respectively. If the match +fails anywhere, all the variables on the left are _u_n_d_e_f_i_n_e_d. For +example, within the scope of the definition + (x,x) = (1,2) + +the value of x is neither 1 nor 2, but _u_n_d_e_f_i_n_e_d (i.e. an error message +will result if you try to access the value of x in any way). + +As a constraint to prevent "nonsense" definitions, it is a rule that the +pattern on the left hand side of a conformal definition must contain at +least one variable. So e.g. `1 = 2' is not a syntactically valid +definition. + +_P_a_t_t_e_r_n_s_ _o_n_ _t_h_e_ _l_e_f_t_ _o_f_ _g_e_n_e_r_a_t_o_r_s + +In a list comprehension (see separate manual entry) the bound entity on +the left hand side of an `<-' symbol can be any pattern. We give two +simple examples - in both examples we assume x is a list of 2-tuples. + +To denote a similar list but with the elements of each tuple swapped +over we can write + [(b,a)|(a,b)<-x] + +To extract from x all second elements of a 2-tuple whose first member is +17, we can write + [ b |(17,b)<-x] + +_I_r_r_e_f_u_t_a_b_l_e_ _p_a_t_t_e_r_n_s (*) + (Technical note, for people interested in denotational semantics) + +DEFINITION:- an algebraic type having only one constructor and for which +that constructor is non-nullary (ie has at least one field) is called a +_p_r_o_d_u_c_t _t_y_p_e. The constructor of a product type is called a `product +constructor'. + +Each type of n-tuple (n~=0) is also defined to be a product type. In +fact it should be clear that any user defined product type is isomorphic +to a tuple type. Example, if we define + wibney ::= WIB num bool +then the type wibney is isomorphic to the tuple type (num,bool). + +A pattern composed only of product-constructors and identifiers, and +containing no repeated identifiers, is said to be "irrefutable". For +example `WIB p q', `(x,y,z)' and `(a,(b,c))' are irrefutable patterns. +We show what this means by an example. Suppose we define f, by + + f :: (num,num,bool) -> [char] + f (x,y,z) = "bingo" + +As a result of the constraints of strong typing, f can only be applied +to objects of type (num,num,bool) and given any actual parameter of that +type, the above equation for f MUST match. + +Interestingly, this works even if the actual parameter is an expression +which does not terminate, or contains an error. (For example try typing + f undef +and you will get "bingo", not an error message.) + +This is because of a decision about the denotational semantics of +algebraic types in Miranda - namely that product types (as defined +above) correspond to the domain construction DIRECT PRODUCT (as opposed +to lifted product). This means that the bottom element of a type such +as (num,num,bool) behaves indistinguishably from (bottom,bottom,bottom). + +Note that singleton types such as the empty tuple type `()', or say, + it ::= IT +are not product types under the above definition, and therefore patterns +containing sui-generis constants such as () or IT are not irrefutable. +This corresponds to a semantic decision that we do NOT wish to identify +objects such as () or IT with the bottom element of their type. + +For a more detailed discussion of the semantics of Miranda see the +formal language definition (in preparation). + +------------------------------------------------------------------------ +(*) A useful discussion of the semantics of pattern-matching, including +the issue of irrefutable patterns, can be found in (chapter 4 of) the +following + S. L. Peyton-Jones ``The Implementation of Functional Programming + Languages'', Prentice Hall International, March 1987. + ISBN 0-13-453333-X + diff --git a/miralib/manual/17 b/miralib/manual/17 new file mode 100644 index 0000000..defbe49 --- /dev/null +++ b/miralib/manual/17 @@ -0,0 +1,66 @@ +_C_o_m_p_i_l_e_r_ _d_i_r_e_c_t_i_v_e_s + +Certain keywords, beginning with `%', modify the action of the compiler +when present in a script. These are called `compiler directives'. The +directives currently available are as follows. + +%list %nolist + If the `/list' feature is enabled (switched on and off by /list, +/nolist at command level) the compiler echos the source to the user's +terminal during compilation of a Miranda script. The directives %list, +%nolist may be placed in a file to give more detailed control over this +behaviour. If the compiler is in an echoing state then encountering +`%nolist' causes it to cease echoing from that point onwards in the +source, until the next occurrence of '%list' or the end of the source +file in which the directive occurs, whichever is the sooner. These +directives may occur anywhere in a script and have no effect on the +semantics (i.e. they are just like comments, apart from having a +side-effect on the lex analyser). + +If the `/list' feature of the compiler is not enabled these directives +are ignored. Since the default state of the compiler is now `/nolist' +these directives are of marginal value and retained only for historical +reasons. + +%insert + A directive of the form + %insert "pathname" +may occur anywhere in a Miranda script, and is textually replaced by the +contents of the file "pathname" during lexical analysis. The pathname +must be given as a literal string, enclosed in double quotes. (Most +uses of this directive are now better handled by %include, see below). + +If the %insert directive is textually indented in the file in which it +occurs, the whole of the inserted text will be treated as being indented +by the same amount as the initial `%' of the directive. + +Insert directives may be invoked recursively, to a depth limit imposed +by the operating system, typically about 16, which should be enough for +any reasonable purpose. Note that the pathnames are resolved +statically, not dynamically, so that the meaning of an _%_i_n_s_e_r_t directive +is computed relative to the file in which it occurs, NOT relative to the +directory from which the compiler was invoked. + +The use of static rather than dynamic pathname resolution is a departure +from normal UNIX conventions (both the `C' compiler and the UNIX shell +resolve pathnames dynamically) but is much more convenient in practice. + +Note that if the subject of an %insert directive is a complete Miranda +script it is always better to use %include (see manual section on the +library mechanism), since this avoids needless recompilation of the +definitions of the subsidiary script. The use of %include also imposes +a hierarchical scope discipline, and is more likely to lead to well +structured code. + +A point to beware of when using %insert is that unlike %include, it does +NOT add a missing `.m' extension to its pathname argument automatically. +This is because the argument file may contain an arbitrary piece of text +(e.g. an expression or a signature) and need not be a complete Miranda +script, so it would be inappropriate to insist that it's pathname end in +`.m' in all cases. + +%include %export %free + These directives control the identifier bindings between separately +compiled scripts. See separate manual entry on `the library mechanism' +for details. + diff --git a/miralib/manual/18 b/miralib/manual/18 new file mode 100644 index 0000000..d5cd0a4 --- /dev/null +++ b/miralib/manual/18 @@ -0,0 +1,114 @@ +_B_a_s_i_c_ _t_y_p_e_ _s_t_r_u_c_t_u_r_e_ _a_n_d_ _n_o_t_a_t_i_o_n_ _f_o_r_ _t_y_p_e_s + +The Miranda programming language is _s_t_r_o_n_g_l_y _t_y_p_e_d - that is each +expression and each variable has a type that can be deduced by a static +analysis of the program text. + +_P_r_i_m_i_t_i_v_e_ _t_y_p_e_s + num bool char + +Values of type `num' include both integer and floating point numbers, +e.g. + 23 0 -17 1.26e11 +They are stored using different internal representations, but can be +freely mixed in calculations, and are both of type `num' for type +checking purposes. There is automatic conversion from integer to +floating point when required (but not in the opposite direction - use +`entier', see standard environment). Floating point numbers are held to +double precision, integers to unbounded precision. + +The values of type `bool' are the two truth values: + True False + +The values of type `char' are characters in the Latin-1 character set, +e.g. + 'a' '%' '\t' + +_L_i_s_t_ _t_y_p_e_s + [t] is the type of lists whose elements are of type `t' + +Thus [num] is the type of lists of numbers such as [1,2,3,4,5] + +[[num]] is the type of lists of lists of numbers, such as [[1,2],[3,4]] + +[char] are lists of characters - this is also the type of string +constants, so e.g. ['h','e','l','l','o'] and "hello" are interchangeable +objects of this type. + +_T_u_p_l_e_ _t_y_p_e_s + (t1,...,tn) is the type of a tuple with elements of type `t1' to `tn' + +Example - the value (1,True,"red") is of type (num,bool,[char]) + +The type of the empty tuple, `()', is also written `()'. + +Notice that tuples are distinguished from lists by being enclosed in +parentheses, instead of square brackets. + +There is no concept of a 1-tuple, in Miranda, so the use of parentheses +to enclose subexpressions, as in say a*(b+c), does not conflict with +their use for tuple formation. + +_F_u_n_c_t_i_o_n_ _t_y_p_e_s + t1->t2 is the type of a function with argument type `t1' and result +type `t2' + +The '->' is right associative, so e.g. `num->num->num' is the type of a +curried function of two numeric arguments. + +In addition to the built-in types described above, user defined types +may be introduced - these are of three kinds, synonym types, algebraic +types and abstract types - see separate manual entry for each. + +_I_m_p_l_i_c_i_t_ _t_y_p_i_n_g + In Miranda the types of identifiers do NOT normally need to be declared +explicitly - the compiler is able to infer the type of identifiers from +their defining equations. For example if you write + plural x = x ++ "s" + +the compiler will DEDUCE that `plural' is of type [char]->[char]. It is +however permitted to include explicit type declarations in the script if +desired, e.g. you could write (anywhere in the same script) + plural :: [char]->[char] + +and the compiler will check this for consistency with the defining +equation (the symbol `::' means `is of type'). More generally the type +declared may be an _i_n_s_t_a_n_c_e (see below) of the type implied by the +definition - in this case the effect of the declaration is to restrict +the type of the identifier to be less general than it would otherwise +have been. + +Note that only top-level identifiers may be the subject of type +declarations, and that the type of an identifier may be declared at most +once in a given script. + + +_P_o_l_y_m_o_r_p_h_i_s_m + The final feature of the type system is that it permits polymorphic +types. There is an alphabet of generic type variables, written + * ** *** etc. + +each of which stands for an arbitrary type. We give a simple example - +the identity function, which may be defined + id x = x + +is attributed the type `*->*'. This means that `id' has many types - +`num->num', `char->char', `[[bool]]->[[bool]]' and so on - each of these +is an instance of its most general type, `*->*'. + +Another simple example of polymorphism is the function `map' (see +standard environment) which applies a function to every element of a +list. For example `map integer [1,1.5,2]' is [True,False,True]. The +type of map is + map :: (*->**) -> [*] -> [**] + +The most polymorphic possible object is `undef', the identifier which +stands for the undefined, or error value (undef is defined in the +standard environment). Since every type has an undefined value, the +correct type specification for undef is + undef :: * + +Many of the functions in the standard environment have polymorphic types +- the text of the standard environment (see separate manual entry) is +therefore a useful source of examples. + diff --git a/miralib/manual/19 b/miralib/manual/19 new file mode 100644 index 0000000..b3cb620 --- /dev/null +++ b/miralib/manual/19 @@ -0,0 +1,18 @@ +_T_y_p_e_ _s_y_n_o_n_y_m_ _d_e_c_l_a_r_a_t_i_o_n_s + +These permit the user to introduce a new name for an already existing +type, e.g. + string == [char] +type synonyms are entirely transparent to the typechecker (it best to +think of them as being just macros). For obvious reasons, recursive type +synonyms are not permitted. + +It is also possible to introduce a synonym for a type forming operator, +by introducing generic type variable as parameters of the definition, +e.g. + invt * ** == (*->**)->(**->*) + +So within a script containing the above two `==' definitions, the type +`invt num string' will be shorthand for + (num->[char])->([char]->num) + diff --git a/miralib/manual/2 b/miralib/manual/2 new file mode 100644 index 0000000..3cba655 --- /dev/null +++ b/miralib/manual/2 @@ -0,0 +1,23 @@ +_A_b_o_u_t_ _t_h_e_ _n_a_m_e_ _`_M_i_r_a_n_d_a_' + +The word `Miranda' is not an acronym. It is a proper name (like `ADA'). + +"Miranda (f). From the Latin meaning `to be admired'. This name was +first used by Shakespeare for the heroine of `The Tempest', a young girl +blessed with many admirable qualities. Like other unusual Shakespearean +names it has been used quite frequently in the 20th century." + + - Collins Dictionary of First Names, + William Collins and Son Ltd, London, 1967 + +"O wonder! How many goodly creatures are there here! O brave new world." + + - `The Tempest' by William Shakespeare + (from a speech by Miranda, Act 5, Scene 1) + +_I_m_p_o_r_t_a_n_t_ _N_o_t_e_. When used as the name of a functional programming +system, `Miranda' is a trademark (tm) of Research Software Ltd. + +Note that only the first letter of Miranda is upper case - it should +never be written all in capitals. + diff --git a/miralib/manual/20 b/miralib/manual/20 new file mode 100644 index 0000000..2ca09d5 --- /dev/null +++ b/miralib/manual/20 @@ -0,0 +1,126 @@ +_A_l_g_e_b_r_a_i_c_ _t_y_p_e_ _d_e_f_i_n_i_t_i_o_n_s + +The simplest method of introducing a new data type into a Miranda script +is by means of an algebraic type definition. This enables the user to +introduce a new concrete data type with specified constructors. A +simple example would be + tree ::= Nilt | Node num tree tree + +The `::=' sign is used to introduce an algebraic data type. This +definition introduces three new identifiers + `tree' a typename + `Nilt' a nullary constructor (i.e. an atom), of type tree + `Node' a constructor, of type num->tree->tree->tree + +Now we can define trees using constructors Nilt & Node, for example + t = Node 3 Nilt Nilt + +It is not necessary to have names for selector functions because the +constructors can be used in pattern matching. For example a function +for counting the number of nodes in a tree could be written + size Nilt = 0 + size (Node a x y) = 1 + size x + size y + +Note that the names of constructors _m_u_s_t_ _b_e_g_i_n_ _w_i_t_h_ _a_n_ _u_p_p_e_r_ _c_a_s_e_ _l_e_t_t_e_r +(and conversely, any identifier beginning with an upper case letter is +assumed to be a constructor). + +An algebraic type can have any number (>=1) of constructors and each +constructor can have any number (>=0) fields, of specified types. The +number of fields taken by a constructor is called its `arity'. A +constructor of arity zero is said to be atomic. Algebraic types are a +very general idea and include a number of special cases that in other +languages require separate constructions. + +One interesting case that all of the constructors can be atomic, giving +us what is called in PASCAL a `scalar enumeration type'. Example + day ::= Mon|Tue|Wed|Thu|Fri|Sat|Sun + +The union of two types can also be represented as an algebraic data type +- for example here is a union of num and bool. + boolnum ::= Left bool | Right num + +Notice that this is a `labelled union type' (the other kind of union +type, in which the parts of the union are not distinguished by tagging +information, is not permitted in Miranda). + +An algebraic typename can take parameters, thus introducing a family of +types. This is done be using generic type variables as formal +parameters of the `::=' definition. To modify our definition of `tree' +to allow trees with different types of labels at the nodes (instead of +all `num' as above) we would write + tree * ::= Nilt | Node * (tree *) (tree *) + +Now we have many different tree types - `tree num', `tree bool', +`tree([char]->[char])', and so on. The constructors `Node' and `Nilt' +are both polymorphic, with types `tree *' and `*->tree *->tree *->tree +*' respectively. + +Notice that in Miranda objects of a recursive user defined type are not +restricted to being finite. For example we can define the following +infinite tree of type `tree num' + bigtree = Node 1 bigtree bigtree + +_C_o_n_t_r_o_l_l_i_n_g_ _t_h_e_ _s_t_r_i_c_t_n_e_s_s_ _o_f_ _c_o_n_s_t_r_u_c_t_o_r_s + +Definition - a function f is strict iff + f _| = _| +where _| is the value attributed to expressions which fail to terminate +or terminate with an error. To support non-strict functions the calling +mechanism must not evaluate the arguments before passing them to the +function - this is what is meant by "lazy evaluation". + +In Miranda constructors are, by default, non-strict in all their fields. +Example + + pair ::= PAIR num num + fst (PAIR a b) = a + snd (PAIR a b) = b + +First note that there is a predefined identifier "undef" which denotes +undefined - evaluating "undef" in a Miranda session gives an error +message. Consider the following Miranda expressions: + + fst (PAIR 1 undef) + snd (PAIR undef 1) + +Both evaluate to `1', that is `PAIR' is non-strict in both arguments. + +The primary reason for making constructors non-strict in Miranda is that +it is necessary to support equational reasoning on Miranda scripts. (In +the example given, elementary equational reasoning from the definition +of `fst' implies that `fst(PAIR 1 anything)' should always have the +value `1'.) It is also as a consequence of constructors being non-strict +that Miranda scripts are able to define infinite data structures. + +It is, however, possible to specify that a given constructor of an +algebraic data type is strict in one or more fields by putting `!' after +the field in the `::=' definition of the type. For example we can +change the above script to make PAIR strict in both fields, thus + + pair ::= PAIR num! num! + fst (PAIR a b) = a + snd (PAIR a b) = b + +Now `fst (PAIR 1 undef)' and `snd (PAIR undef 1)' both evaluate to +undefined. It is a consequence of the `!' annotations that `PAIR a b' +is undefined when either a or b is undefined. It is also possible to +make PAIR strict in just one of its fields by having only one `!' in the +type definition. + +In the case of a recursively defined algebraic type, if all the +constructors having recursive fields are made strict in those fields it +ceases to be possible to construct infinite objects of that type. It is +also possible to deny the possibility of certain infinite structures +while permitting others. For example if we modify the definition of the +tree type first given above as follows + tree ::= Nilt | Node num tree! tree + +then it is still possible to construct trees which are infinite in their +right branch but not "left-infinite" ones. + +The main reason for allowing `!' annotations on Miranda data type +definitions is that one of the intended uses of Miranda is as a SEMANTIC +METALANGUAGE, in which to express the denotational semantics of other +programming languages. + diff --git a/miralib/manual/21 b/miralib/manual/21 new file mode 100644 index 0000000..57f1a4e --- /dev/null +++ b/miralib/manual/21 @@ -0,0 +1,133 @@ +_A_b_s_t_r_a_c_t_ _t_y_p_e_ _d_e_f_i_n_i_t_i_o_n_s + +These enable a new data type to be defined by data type abstraction from +an existing type. We give the classic example, that of defining `stack' +as an abstract data type (here based on lists) + _a_b_s_t_y_p_e stack * + _w_i_t_h empty::stack * + push::*->stack *->stack * + isempty::stack *->bool + top::stack *->* + pop::stack *->stack * + + stack * == [*] + empty = [] + push a x = a:x + isempty x = x=[] + top (a:x) = a + pop (a:x) = x + +The information given after `_w_i_t_h' is called the _s_i_g_n_a_t_u_r_e of the +abstract type - the definitions of the identifiers in the signature are +called the `implementation equations' (these are the six equations given +above). Outside of the implementation equations the information that +stacks are implemented as lists is not available - [] and empty for +example are incomparable objects of two different and unrelated types ( +[*] and stack * respectively). Only inside the implementation equations +are the abstract objects treated as being equivalent to their +representations. + +The implementation equations do not have to appear immediately after the +corresponding _a_b_s_t_y_p_e declaration - they can occur anywhere in the +script. For readability, however, it is strongly recommended that the +implementation equations appear immediately after the _a_b_s_t_y_p_e +declaration. + +Note that in Miranda there is no runtime cost associated with +administering an abstract data type. The responsibility for enforcing +the distinction between stacks and lists, for example, is discharged +entirely at compile time (by the type checker). The runtime +representation of a stack does not require any extra bits to distinguish +it from a list. As a result the Miranda programmer can freely use +abstract data types to structure his programs without incurring any loss +of efficiency by doing so. + +Notice that the mechanism used to introduce abstract data types in +Miranda does not depend on the hiding of identifiers, and in this +respect differs from the traditional approach. A fuller discussion of +the Miranda _a_b_s_t_y_p_e mechanism can be found in [*Turner 85]. + +------------------------------------------------------------------------ +(*) D. A. Turner ``Miranda: A Non-Strict Functional Language with +Polymorphic Types'', Proceedings IFIP Conference on Functional +Programming Languages and Computer Architecture, Nancy, France, +September 1985 (Springer Lecture Notes in Computer Science, vol. 201, pp +1-16). +------------------------------------------------------------------------ + +_T_h_e_ _p_r_i_n_t_ _r_e_p_r_e_s_e_n_t_a_t_i_o_n_ _o_f_ _a_b_s_t_r_a_c_t_ _o_b_j_e_c_t_s + ("advanced feature" - omit on first reading) + +Values belonging to an abstract type are not in general printable. If +the value of a command-level expression is of such a type it will +normally print simply as + +<abstract ob> + +This is because the special function _s_h_o_w (which is actually a family of +functions, see elsewhere) has no general method for converting such +objects to a printable form. It is possible to extend the definition of +_s_h_o_w to include the ability to print members of an abstract type, using +some appropriate format. The convention for doing this is to include in +the definition of the abstract type a function with the name `showfoo' +(where `foo' is the name of the abstract type involved). + +We illustrate how this is done taking `stack' as the example. Suppose +we decide we wish stacks to print - using a syntax such that the output +could be read back in (e.g. by readvals - see elsewhere) to generate the +same stack. + + empty is to print as "empty" + push 1 empty is to print as "(push 1 empty)" + and so on. + +Note that we decide to fully parenthesise the output for safety - since +we do not know the larger context in which our stack output may be +embedded. + +Because `stack' is a polymorphic abstraction, showstack will need to +take as a parameter the appropriate show function for the element type +(which is num in the above examples, but could have been any type). We +add to the signature of stack the following function. + + showstack::(*->[char])->stack *->[char] + +To obtain the output format illustrated above, an appropriate definition +of showstack would be, + + showstack f [] = "empty" + showstack f (a:x) = "(push " ++ f a ++ " " ++ showstack f x ++ ")" + +If this definition is included in the script, stacks become printable, +using the specified format. The effect is to extend the behaviour of +the special built-in function _s_h_o_w to handle stacks, and all data +structures built using stacks (such as list of tree of stacks, stack of +stacks and so on). + +The general rule is as follows. Let `foo' be an abstract type name. To +make foo's printable, we need to define a `showfoo' thus: + + if foo is a simple type (not polymorphic) + showfoo :: foo -> [char] + + if foo is polymorphic in one type variable (foo *) + showfoo :: (*->[char]) -> foo * -> [char] + + if foo is polymorphic in two type variables (foo * **) + showfoo :: (*->[char]) -> (**->[char]) -> foo * ** -> [char] + +and so on. Note that the show function must be declared in the +signature of the abstract type, and that the name of the function is +significant - if we change its name from `showfoo' to `gobbledegook', +its definition will cease to have any effect on the behaviour of _s_h_o_w. +It also needs to have the right type, and if it does not, again its +presence will have no effect on the behaviour of _s_h_o_w (in this case the +compiler prints a warning message). + +[Note on library directives: If you %export an abstract type, foo say, +to another file, it is not necessary to %export the showfoo function +explicitly to preserve the correct printing behaviour - if an abstract +type comes into existence with a show function in its signature the +compiler will `remember' how to print objects of the type even in scopes +where the show function has no name.] + diff --git a/miralib/manual/22 b/miralib/manual/22 new file mode 100644 index 0000000..b967d27 --- /dev/null +++ b/miralib/manual/22 @@ -0,0 +1,35 @@ +_E_m_p_t_y_ _t_y_p_e_s (also called _P_l_a_c_e_h_o_l_d_e_r_ _t_y_p_e_s) + +An empty type has no values belonging to it (apart from the undefined +value, undef, which is a member of every type). Empty types are +declared as follows: + + widget :: _t_y_p_e + +this declares `widget' to be a type but gives it no values. + +Empty types can be used during program development as placeholders for +types whose representation is not yet decided. For example given the +above declaration we can give type specifications involving widget, e.g. + + foo :: num->widget->widget + gronk :: [widget]->widget + +and write code using `foo' and `gronk' which can be checked for type +correctness. At a later stage the specification of widget as an empty +type can be replaced by a non-empty type definition, using ==, ::=, or +_a_b_s_t_y_p_e, allowing foo, gronk, to be defined. + +Typenames declared as empty can have any arity, eg + table * ** :: _t_y_p_e +This creates a family of empty types, such as `table num bool' and so +on. They are all devoid of values (apart from undef). The general form +of this kind of specification is + tform-list :: _t_y_p_e +where `tform' consists of a typename followed by zero or more generic +type variables (and it is permitted to declare several such types +simultaneously, separated by commas, whence `tform-list'). + +An empty type may be considered equivalent to an algebraic type with no +constructors. + diff --git a/miralib/manual/23 b/miralib/manual/23 new file mode 100644 index 0000000..6c627a9 --- /dev/null +++ b/miralib/manual/23 @@ -0,0 +1,55 @@ +_T_h_e_ _u_s_e_ _o_f_ _`_s_h_o_w_'_ _f_o_r_ _c_o_n_v_e_r_t_i_n_g_ _o_b_j_e_c_t_s_ _t_o_ _t_h_e_i_r_ _p_r_i_n_t_ _r_e_p_r_e_s_e_n_t_a_t_i_o_n_s + +The need often arises to convert an arbitrary Miranda value to its +printable representation as a string. For numbers the function +`shownum' (of type num->[char]) can be used for this purpose. To be +able to do this conversion for any type of object would seemingly +require an infinite number of functions, one for each type. As a +solution to this problem Miranda provides a special keyword, `_s_h_o_w'. + +For any object x + _s_h_o_w x +is a string containing the printable representation of x. For example, +if x is a number the above expression is equivalent to `shownum x'. In +the general case, however, x could be a structured object of arbitrary +complexity. Note that _s_h_o_w is a reserved word, not an identifier. + +In fact `_s_h_o_w' behaves under most circumstances as though it was the +name of a function, of type *->[char]. For example it can be passed as +a parameter, so that say, + map _s_h_o_w [a,b,c,d,e] +is a legal expression of type [[char]]. + +There are three important restrictions on the universality of _s_h_o_w. + +(i) You cannot `show' functions in any useful sense. (That would be a +violation of referential transparency.) The result of applying _s_h_o_w to +any kind of function is just the string "<function>". + +(ii) You cannot `show' an abstract object unless an appropriate +show-function was included when the type was defined (see manual section +on Abstract types). The result of applying _s_h_o_w to such an object is by +default just the string "<abstract ob>". + +(iii) When it occurs in a script the context in which _s_h_o_w is used must +be such as to determine its type _m_o_n_o_m_o_r_p_h_i_c_a_l_l_y. An example: + my_show x = "hello\n"++_s_h_o_w x++"goodbye\n" +In the absence of any other type information, the compiler will infer +that my_show has type *->[char], and that x is of type `*'. The use of +_s_h_o_w is therefore polymorphic, and will be rejected as illegal. + +If however we intend that my_show will be used only on objects of type +`tree', say, and we add to the script the declaration +`my_show::tree->[char]', then the above use of _s_h_o_w becomes monomorphic, +and will be accepted. + +The essence of restriction (iii) is that _s_h_o_w is not a true polymorphic +function of type *->[char], but rather a family of monomorphic functions +with the types T->[char] for each possible monotype T. The context must +be sufficient for the compiler to determine which member of the family +is required. + +(For technical reasons this restriction applies only in scripts. In +command-level expressions _s_h_o_w behaves as if it were a genuine +polymorphic function.) + diff --git a/miralib/manual/24 b/miralib/manual/24 new file mode 100644 index 0000000..b30a892 --- /dev/null +++ b/miralib/manual/24 @@ -0,0 +1,58 @@ +_S_y_n_t_a_x_ _o_f_ _M_i_r_a_n_d_a_ _s_c_r_i_p_t_s_ _a_n_d_ _e_x_p_r_e_s_s_i_o_n_s + +script:= decl* rhs:= simple_rhs(;) + cases +decl:= def + tdef simple_rhs:= exp whdefs? + spec + libdir cases:= alt(;) = cases + lastcase(;) +def:= fnform = rhs + pat = rhs alt:= exp , _i_f exp + +tdef:= tform == type(;) lastcase:= lastalt whdefs? + tform ::= constructs(;) + _a_b_s_t_y_p_e tform-list _w_i_t_h sig(;) lastalt:= exp , _i_f exp + exp , _o_t_h_e_r_w_i_s_e +spec:= var-list :: type(;) + tform-list :: _t_y_p_e(;) whdefs:= _w_h_e_r_e def def* + +sig:= spec spec* exp:= e1 + prefix1 +constructs:= construct | constructs infix + construct + e1:= simple simple* +construct:= constructor argtype* prefix e1 + type $constructor type e1 infix e1 + ( construct ) argtype* + simple:= var +type:= argtype constructor + typename argtype* literal + type -> type _r_e_a_d_v_a_l_s + type $typename type _s_h_o_w + ( infix1 e1 ) +argtype:= typename ( e1 infix ) + typevar ( exp-list? ) + ( type-list? ) [ exp-list? ] + [ type-list ] [ exp .. exp? ] + [ exp , exp .. exp? ] +tform:= typename typevar* [ exp | qualifs ] + typevar $typename typevar [ exp // qualifs ] + +fnform:= var formal* qualifs:= qualifier ; qualifs + pat $var pat qualifier + ( fnform ) formal* + qualifier:= exp +pat:= formal generator + -numeral + constructor formal* generator:= pat-list <- exp + pat : pat pat <- exp , exp .. + pat + nat + pat $constructor pat var:= identifier + ( pat ) formal* + constructor:= IDENTIFIER +formal:= var + constructor typename:= identifier + literal1 + ( pat-list? ) + [ pat-list? ] diff --git a/miralib/manual/25 b/miralib/manual/25 new file mode 100644 index 0000000..6e0cef9 --- /dev/null +++ b/miralib/manual/25 @@ -0,0 +1,80 @@ +_C_o_m_m_e_n_t_s_ _o_n_ _t_h_e_ _s_y_n_t_a_x_ _f_o_r_ _M_i_r_a_n_d_a_ _s_c_r_i_p_t_s + +The syntax equations given express the syntax of Miranda scripts insofar +as this can be done by a context free grammar. It therefore does not +attempt to express the scope rules, nor the requirement that a script be +well-typed, both of which are context sensitive restrictions on the +syntax given here. The formal definition of Miranda [in preparation] +will deal with these matters and also give a denotational semantics for +the language. + +Nevertheless, if the syntax is read in conjunction with the informal +description of the language (see other manual sections and referenced +papers) it should be found fairly informative, especially if the reader +has some previous exposure to this style of language. + +Key to abbreviations in syntax:- +> alt=alternative decl=declaration def=definition +> e1=operator_expression exp=expression fnform=function_form +> libdir=library_directive pat=pattern qualifs=qualifiers +> rhs=right_hand_side sig=signature spec=specification +> tdef=type_definition tform=typeform var=variable +> whdefs=where_defs + +_C_o_n_v_e_n_t_i_o_n_s + We use a variant of BNF, in which non-terminals are represented by +lower case words, `:=' is used as the production symbol, and alternative +productions are written on successive lines. (These departures from +convention are adopted because `::=' and `|' are concrete symbols of the +language.) + +For any non-terminal x, + x* means zero or more occurrences of x + x? means the presence of x is optional + x-list means one or more x's (separated by commas if >1) + x(;) means that x is followed by an optional semicolon and +is subject to the _o_f_f_s_i_d_e _r_u_l_e (see section on Layout), so that every +token of x must lie below or to the right of the first. Provided the +layout makes it clear where x terminates, the trailing semicolon may be +omitted. + +_N_o_t_e_s + +The syntax of the library directives (denoted by the non-terminal +`libdir') is given in a separate manual entry. + +Ambiguities in the syntax for `type' and `construct' are resolved by +noting that `->' is less binding than `$typename' or `$constructor' and +that all three are right associative. + +In connection with the productions for argtype, note that type such as +`[num,bool]' is an abbreviation for `[(num,bool)]' and represents the +type of a list of tuples - the Miranda system itself never uses this +abbreviation when printing a type, but accepts it in user scripts. (Use +of this abbreviation is not recommended - it will probably be removed +from the syntax at the next release.) + +Ambiguities in the syntax for `fnform' and `pat' are resolved by taking +into account the relative binding powers of the infix operators +involved. Specifically that `:' is right associative and less binding +than `+', which is left associative, and that $constructor, $var have a +higher binding power than either of these, and are right associative. + +The productions given for `cases' correctly describe the concrete syntax +of these entities, including the way the offside rule is applied to +them. This concrete syntax is in one sense misleading, however. Namely +in that if a `lastcase' with a trailing `wheredefs' is preceded by a +series of alternatives, the scope of the names introduced by the _w_h_e_r_e +IS THE WHOLE `cases' IN WHICH IT OCCURS, AND NOT JUST THE `lastcase'. + +Note that for compatibility with earlier versions of Miranda the use of +the keyword `if' is optional. + +The ambiguities in the syntax given for `e1' are resolved by taking into +account the relative binding powers of the operators (see manual section +on Operators). + +The syntax of identifier, IDENTIFIER, literal, literal1, numeral, nat, +infix, infix1, prefix, prefix1, and typevar are given under Lexical +Syntax (see next manual section). + diff --git a/miralib/manual/26 b/miralib/manual/26 new file mode 100644 index 0000000..af0fbcc --- /dev/null +++ b/miralib/manual/26 @@ -0,0 +1,72 @@ +_M_i_r_a_n_d_a_ _l_e_x_i_c_a_l_ _s_y_n_t_a_x + In this section square brackets are used to enclose a set of literal +characters, using lex-style conventions, so eg [a-z] means a lower case +letter. As usual * and ? are used to mean zero-or-more, and +zero-or-one, occurrences of the preceding entity. Parentheses are used +for grouping, and subtraction of one syntactic entity from another means +set difference. We also revert to using `|' for alternatives, as in +standard BNF. + +script:= (token | layout)* + +layout:= nl | tab | formfeed | space | comment + +comment:= vertical_bar vertical_bar (any - nl)* nl + +token:= identifier | IDENTIFIER | literal | typevar | delimiter + +identifier:= ([a-z] [a-zA-Z0-9_']* ) - delimiter + +IDENTIFIER:= [A-Z] [a-zA-Z0-9_']* + +literal:= numeral | charconst | stringconst + +literal1:= literal - float + +numeral:= nat | float + +nat:= [0-9] [0-9]* | 0x [0-9a-f] [0-9a-f]* | 0o [0-7] [0-7]* + +float:= [0-9]* [.] nat epart? | nat epart + +epart:= [e] [+|-]? nat + +charconst:= ['] (visible-[\]|escape) ['] + +stringconst:= ["] (visible-[\"]|escape)* ["] + +escape:= [\] ([ntfrb\'"]|nl|decimal_code) + +typevar:= [*][*]* + +delimiter:= - | prefix1 | infix1 | other + +infix1:= ++ | -- | : | \/ | & | > | >= | = | ~= | <= | < | + | * | + / | div | mod | ^ | . | ! | $identifier | $IDENTIFIER + +infix:= infix1 | - + +prefix1:= ~ | # + +prefix:= prefix1 | - + +other:= abstype | if | otherwise | readvals | show | type | where | + with | %export | %free | %include | %insert | %list | %nolist | + = | == | ::= | :: | => | vertical_bar | // | -> | ; | , | ( | + ) | [ | ] | { | } | <- | .. | $$ | $- | $:- | $+ | $* + +vertical_bar:= | + +_N_o_t_e_s + visible means any non-control character, including space (but not +including eg newline), nl means literal newline, and decimal_code is a +nat in the range 0..255 (maximum length 3 digits). + +Notice that the syntax of `numeral' does not include negative numbers. +Negative constants, such as -3 or -5.05e-17 are parsed by Miranda as +applications of the prefix operator `-' to a positive numeral. This has +no semantic significance. + +Omission - the definition of `layout' does not include the additional +comment rules for LITERATE SCRIPTS (see separate manual section). + diff --git a/miralib/manual/27/1 b/miralib/manual/27/1 new file mode 100644 index 0000000..0b785fc --- /dev/null +++ b/miralib/manual/27/1 @@ -0,0 +1,19 @@ +_S_y_n_t_a_x_ _o_f_ _l_i_b_r_a_r_y_ _d_i_r_e_c_t_i_v_e_s + +libdir:= %_i_n_c_l_u_d_e env(;) parts:= part part* + %_e_x_p_o_r_t parts(;) + %_f_r_e_e { sig } part:= identifier + fileid +env:= fileid binder? aliases? + + -identifier +binder:= { binding binding* } + fileid:= "pathname" +binding:= var = exp(;) <pathname> + tform == type(;) + _N_o_t_e_s For the definition of `sig' +aliases:= alias alias* (=signature), `var', `exp', `tform' + and `type' see the main manual page +alias:= identifier/identifier on formal syntax of Miranda. For + IDENTIFIER/IDENTIFIER the definition of `identifier' and + -identifier `IDENTIFIER' see lexical syntax. + diff --git a/miralib/manual/27/2 b/miralib/manual/27/2 new file mode 100644 index 0000000..c53c3f0 --- /dev/null +++ b/miralib/manual/27/2 @@ -0,0 +1,44 @@ +_T_h_e_ _%_i_n_c_l_u_d_e_ _d_i_r_e_c_t_i_v_e_ _(_b_a_s_i_c_ _i_n_f_o_r_m_a_t_i_o_n_) + +Suppose the file "mylib.m" contains some Miranda declarations (which +could be any kind of legal Miranda declaration, eg function definitions, +type definitions etc). To make these in scope in another script, the +latter will contain the directive + %_i_n_c_l_u_d_e "mylib" + +This can come anywhere in the script (there is for example no +requirement that %_i_n_c_l_u_d_e directives come at the front) but must be at +top level - you may not place a %_i_n_c_l_u_d_e directive inside a _w_h_e_r_e +clause. The subject of a %_i_n_c_l_u_d_e directive may itself contain %_i_n_c_l_u_d_e +directives, and so on (to any reasonable depth). + +By default, the names `exported' from an included script are all those +defined in it at top level, but not those of subsidiary %_i_n_c_l_u_d_e's. +This can be modified by placing a `%_e_x_p_o_r_t' directive in the included +script. For a discussion of this and other ways of modifying the effect +of %_i_n_c_l_u_d_e see the manual section giving a detailed account of the +library directives. + +If the filename in a _%_i_n_c_l_u_d_e directive is enclosed in angle brackets +instead of string quotes, this is understood to be a pathname relative +to the miralib directory. So for example putting in your script + %_i_n_c_l_u_d_e <ex/matrix> +brings into scope the definitions exported from the matrix package in +the Miranda examples directory `ex'. (*See note below.) + +Finally, note that that the relationship between includor and includee +is unsymmetrical. If file A %_i_n_c_l_u_d_e's file B, then the declarations of +B are visible to A, but not vice versa. + +There is a simpler (purely textual) directive + %_i_n_s_e_r_t "file" +which causes the contents of "file" to be substituted for the %_i_n_s_e_r_t +directive during lexical analysis. This can occur anywhere in a Miranda +script. See manual section on compiler directives. + +------------------------------------------------------------------------ +(*) Note to system administrators: an empty directory `local' is +provided under the miralib directory, in which you can place additional +libraries which you wish to make available to all Miranda users at your +site. + diff --git a/miralib/manual/27/3 b/miralib/manual/27/3 new file mode 100644 index 0000000..5891ed2 --- /dev/null +++ b/miralib/manual/27/3 @@ -0,0 +1,286 @@ +_E_x_p_l_a_n_a_t_i_o_n_ _o_f_ _l_i_b_r_a_r_y_ _d_i_r_e_c_t_i_v_e_s + +The three directives %_i_n_c_l_u_d_e %_e_x_p_o_r_t %_f_r_e_e constitute the Miranda +library mechanism, which controls the sharing of identifiers between +separately compiled scripts. The %_f_r_e_e directive is covered in a +separate manual entry and will not be discussed further here. +------------------------------------------------------------------------ + +%_i_n_c_l_u_d_e "file" + +The presence of this directive, anywhere in a Miranda script, causes all +the identifiers exported from the Miranda script "file" to be in scope +in the containing script. Note that "file" should be the name of a +Miranda source file (by convention these all have names ending in `.m'). + +The following conventions apply to all filenames in library directives: + 1) A fileid can be an arbitrary UNIX pathname + 2) If the fileid given does not end in `.m' this is added. + 3) If the fileid is surrounded by angle brackets instead of string +quotes it is assumed to be a pathname relative to the `miralib' +directory, otherwise it is taken to be relative to the directory of the +script in which the directive occurs. (Examples, "pig" means "pig.m", +<stdenv> means "/usr/lib/miralib/stdenv.m") + +In addition (if you are using Berkeley UNIX or a derivative) the `~' +convention of the cshell may be used to abbreviate home directories. +That is `~' abbreviates your own home directory, and ~jack abbreviates +jack's home directory, at the front of any pathname. + +The file mentioned in a %_i_n_c_l_u_d_e directive must contain a CORRECT, +CLOSED Miranda script. (That is it must have no syntax or type errors, +and no undefined names.) An attempt to %_i_n_c_l_u_d_e a file which violates +these conditions will be rejected by the compiler as a syntax error in +the script containing the %_i_n_c_l_u_d_e statement. + +It is also illegal to %_i_n_c_l_u_d_e a script which causes nameclashes, either +against top-level identifiers of the including script or those of other +%_i_n_c_l_u_d_e directives in the script. + +The effect of an %_i_n_c_l_u_d_e directive can be modified by following it with +one or more aliases (which are used to remove nameclashes between +identifiers exported from the included script and those of the current +script or of other %_i_n_c_l_u_d_e files). There are two forms of alias, +`new/old' which renames and `-old' which suppresses an identifier +altogether. + +For example suppose we wish to include the file "mike" but it contains +two identifiers, f and g say, which clash with top-level bindings of +these identifiers in the current script. We wish to use the "mike" +definition of `f', but his `g' is of no interest. The following +directive could be used. + +%_i_n_c_l_u_d_e "mike" -g mike_f/f + +Any other identifiers exported from "mike", not specifically mentioned +in the aliases, will be accepted unchanged. + +It is permitted to alias typenames, and constructors (say `NEW/OLD') but +typenames and constructors cannot be suppressed by a `-name' alias. +Note that if you alias one or more of the constructors of an algebraic +data type the behaviour of `_s_h_o_w' on objects of that type will be +modified in the appropriate way. + +A file which has been %included may itself contain %_i_n_c_l_u_d_e directives, +and so on, to any reasonable depth. A (directly or indirectly) cyclic +%_i_n_c_l_u_d_e is not permitted, however. + +The `?identifier' command can be used to find the ultimate place of +definition of an imported identifier. When aliasing has taken place the +`?identifier' command will give both the current and the original name +of an aliased identifier. If your installed editor is `vi' the +`??identifier' command will open the appropriate source file at the +definition of the identifier. (There is also a command `/find +identifier' which is like `?identifier' but will recognise an alias +under its original name.) + +Every script behaves as though it contained the directive + %_i_n_c_l_u_d_e <stdenv> + +It is therefore illegal to %_i_n_c_l_u_d_e the standard environment explicitly, +as this will lead to huge number of name clashes (because it is now +present twice). As a consequence there is currently no way of aliasing +or suppressing the names in the standard environment. (This will be +fixed in the future by providing a directive for suppressing the +implicit inclusion of <stdenv>.) +------------------------------------------------------------------------ + +%_e_x_p_o_r_t parts + +Any (correct, closed) Miranda script can be %included in another script +(there is no notion of a "module" as something with a different syntax +from an ordinary script). By default the names exported from a script +are all those defined in it, at top level, but none of those acquired by +a %_i_n_c_l_u_d_e of another file. This behaviour can be modified (either to +export more or to export less than the default) by placing a %_e_x_p_o_r_t +directive in the script, specifying a list of `parts' to be exported to +an including file. + +The presence of a %_e_x_p_o_r_t directive in a script has no effect on its +behaviour when it is the current script of a Miranda session - it is +effective only when the script is %included in another. A script may +contain at most one %_e_x_p_o_r_t directive. This can be anywhere in the +script, but to avoid nasty surprises it is advisable to place it near +the top. + +Each `part' listed in the export directive must be one of the following: + identifier (variable or typename) + fileid (in quotes, conventions as described above) + the symbol `+' + -identifier + +Notice that constructors need not (and cannot) be listed explicitly in +an %_e_x_p_o_r_t directive - if you export an algebraic typename, its +constructors are AUTOMATICALLY exported along with it. The consequence +of this is that you cannot use %_e_x_p_o_r_t to create an abstract data type, +by "hiding information" about how an algebraic type was formed. If you +want to create an abstract data type you must use the _a_b_s_t_y_p_e mechanism +- see separate manual entry. + +If a fileid is present in the export list, this must be the name of a +file which is %included in the exporting script, and the effect is that +all the bindings acquired by that %_i_n_c_l_u_d_e statement (as modified by +aliases if present) are re-exported. Allowing fileid's in the export +list is merely a piece of shorthand, which can be used to avoid writing +out long lists of names. + +The symbol `+' is allowed in an export list as an abbreviation for all +the top-level identifiers defined in the current script. + +The default %_e_x_p_o_r_t directive (i.e. that which is assumed if no %_e_x_p_o_r_t +statement is present) is therefore + %_e_x_p_o_r_t + +This will export all the top-level identifiers of the current script, +but not those acquired by %_i_n_c_l_u_d_e directives. + +Finally, the notation `-identifier' is allowed in an export list to +indicate that this identifier NOT to be exported. This is useful if you +have used a fileid or the symbol `+' to abbreviate a list of names, and +wish to subtract some of these names from the final export list. + +An example - the following export statement exports all the top-level +identifiers of the current script, except `flooby'. + %_e_x_p_o_r_t + -flooby + +The order of appearance of the items in an export list is of no +significance, and repetitions are ignored. A negative occurrence of an +identifier overrides any number of positive occurrences. + +It is possible to find out what names are exported from a given Miranda +script (or scripts) by calling, from UNIX, the command + `mira -exports files' (the extension `.m' will be added to each file +name if missing). This will list (to stdout) for each file the exported +names together with their types. +------------------------------------------------------------------------ + +_S_o_m_e_ _e_x_a_m_p_l_e_s + +(i) There are two scripts, called "liba.m" and "libb.m" say, containing +useful definitions. For convenience we wish to combine them into a +single larger library called say, "libc.m". The following text inside +the file "libc.m" will accomplish this. + + %_e_x_p_o_r_t "liba" "libb" + %_i_n_c_l_u_d_e "liba" + %_i_n_c_l_u_d_e "libb" + +You will notice that when "libc.m" is compiled, this does NOT cause +recompilation of "liba.m" and "libb.m" (see section on separate +compilation - the compiler is able to create an object code file for +"libc.m", called "libc.x", by combining "liba.x" and "libb.x" in an +appropriate way). This economy in recompilation effort is one reason +why %_i_n_c_l_u_d_e is a better mechanism than the simpler textual directive +%_i_n_s_e_r_t (see section on compiler directives). + +We could if we wished add some definitions to "libc.m" - if the +corresponding names are added to the %_e_x_p_o_r_t statement these bindings +will then be exported along with those of the two sublibraries. Of +course if we don't add the names of the locally defined objects to the +%_e_x_p_o_r_t directive they will be `private definitions' of "libc.m", not +visible to includors. + +Recall that if no %_e_x_p_o_r_t is directive is present, then ONLY the +immediate definitions (if any) of "libc.m" will be exported. So a +script which contains only %_i_n_c_l_u_d_e directives and no %_e_x_p_o_r_t cannot be +usefully %included in another script (it is however perfectly acceptable +as a current script). + +(ii) [More technical - omit on first reading] + Our second group of examples is chosen to bring out some issues which +arise when exporting types between scripts. Suppose we have the +following script, called "trees.m" + + tree * ::= NILT | NODE * (tree *) (tree *) + reflect :: tree *->tree * + reflect NILT = NILT + reflect (NODE a x y) = NODE a(reflect y)(reflect x) + +(a) If in another script we write `%_i_n_c_l_u_d_e "trees"', the following +bindings will be imported - tree NILT NODE reflect. Now suppose we +modify the "trees.m" by placing in it the following directive - `%_e_x_p_o_r_t +reflect'. When the modified "trees.m" script is included in another, we +will get the following error message from the compilation of the +including script: + + MISSING TYPENAME + the following type is needed but has no name in this scope: + 'tree' of file "trees.m", needed by: reflect; + typecheck cannot proceed - compilation abandoned + +Explanation - it is illegal to export an identifier to a place where its +type, or any part of its type, is unknown. In this situation we call +reflect a `type-orphan' - it has lost one of its parents! + +(b) Readoption of a type-orphan (a more subtle example). Assuming the +"trees.m" script in its original form as above, we construct the +following file "treelib.m" + + %_e_x_p_o_r_t size + %_i_n_c_l_u_d_e "trees" + size :: tree *->num + size NILT = 0 + size (NODE a x y) = 1+size x+size y + +If we %_i_n_c_l_u_d_e the above script in another as it stands, we will of +course get a missing typename diagnostic for `size' - consider however +the following script + + %_i_n_c_l_u_d_e "treelib" + %_i_n_c_l_u_d_e "trees" + ... (etc) + +Everything is now ok, because a name for size's missing parent is +imported through another route (the second %_i_n_c_l_u_d_e statement). The +Miranda compiler recognises the `tree' type imported by the second +%_i_n_c_l_u_d_e as being the same one as that referred to inside "treelib.m", +because it originates (albeit via different routes) from the SAME +SOURCEFILE. A `tree' type imported from a different original +sourcefile, even if it had the same constructor names with the same +field types, would be recognised as a different type. + +[Note: the Miranda compiler is always able to recognise when the same +source file is inherited via different routes, including in cases +involving files with multiple pathnames due to the presence of (hard or +symblic) links.] + +[Further note: the lexical directive %_i_n_s_e_r_t (see compiler directives) +should be regarded as making a _t_e_x_t_u_a_l_ _c_o_p_y of the material from the +inserted file into the file containing the %_i_n_s_e_r_t directive - if the +text of a type definition (in ::= or abstype) is copied in this way, the +compiler will regard the %_i_n_s_e_r_t as having created a new type in each +such case, not identical with that in the inserted file.] + +(c) Last example (typeclash). Finally note that that it is illegal for +the same original type to be imported twice into the same scope even +under different names. Consider the following script + + %_i_n_c_l_u_d_e "trees" shrub/tree Leaf/NILT Fork/NODE -reflect + %_i_n_c_l_u_d_e "trees" + ... (etc) + +The first %_i_n_c_l_u_d_e taken on its own is perfectly ok - we have imported +the `tree' type, and renamed everything in it by using aliases. However +we have also inherited the `tree' type under its original name, via the +second %_i_n_c_l_u_d_e. The compiler will reject the script with the following +message: + + TYPECLASH - the following type is multiply named: + 'tree' of file "trees.m", as: shrub,tree; + typecheck cannot proceed - compilation abandoned + +The rule that a type can have at most one name in a given scope applies +to both algebraic types and abstract types (it does not apply to synonym +types, because these are not `real' types but mere macro's - you can +have any number of synonyms for `tree' in scope at the same time - as +long as the underlying `real' type has a unique name). + +Typeclashes are illegal in Miranda in order to preserve the following +two principles. (i) In any given scope, each possible type must have a +unique canonical form (obtained by expanding out synonyms, and renaming +generic type variables in a standard way). (ii) Each object of a +`printable type' must have, in any given scope, a unique external +representation (ruling out multiply named constructors). The first +principle is necessary to the functioning of the typechecker, the second +is demanded by the requirement that the function `_s_h_o_w' be referentially +transparent. + diff --git a/miralib/manual/27/4 b/miralib/manual/27/4 new file mode 100644 index 0000000..f34bc3d --- /dev/null +++ b/miralib/manual/27/4 @@ -0,0 +1,116 @@ +_T_h_e_ _%_f_r_e_e_ _d_i_r_e_c_t_i_v_e_ _a_n_d_ _p_a_r_a_m_e_t_r_i_s_e_d_ _s_c_r_i_p_t_s + +It is permitted to construct a script containing definitions which are +dependent on information which will be supplied only when the script is +made the subject of a %_i_n_c_l_u_d_e directive. Such a script is said to be +_p_a_r_a_m_e_t_r_i_s_e_d. This is indicated by the presence in the script of a +directive of the form + + %_f_r_e_e { signature } + +where `signature' is a list of specifications of the identifiers for +which bindings will be provided at %_i_n_c_l_u_d_e time. A script may contain +at most one %_f_r_e_e directive, which must therefore give all the +identifiers on which the script is parametrised. The %_f_r_e_e directive +may appear anywhere in the script, but for clarity it is recommended +that you place it at or near the top. + +For example a script (called "matrices" say) defining the notion of +matrix sum and matrix product, for matrices of as-yet-unspecified +element type, could be written as follows:- + + %_e_x_p_o_r_t matmult matadd + + %_f_r_e_e { elem :: _t_y_p_e + zero :: elem + mult, add :: elem->elem->elem + } + + matrix == [[elem]] + + matadd :: matrix->matrix->matrix + matadd xx yy = [[add a b|(a,b)<-zip2 x y]|(x,y)<-zip2 xx yy] + + matmult :: matrix->matrix->matrix + matmult xx yy = outerprod innerprod xx (transpose yy) + innerprod x y = sum [mult a b|(a,b)<-zip2 x y] + _w_h_e_r_e + sum = foldr add zero + outerprod f xx yy = [[f x y|y<-yy]|x<-xx] + +Note that the identifiers declared under %_f_r_e_e may denote types as well +as values. When we write a %_i_n_c_l_u_d_e directive for the above script we +must provide bindings for all of its free identifiers. The bindings are +given in braces following the pathname (and before the aliases, if any). +Thus:- + + %_i_n_c_l_u_d_e "matrices" {elem==num; zero=0; mult=*; add=+; } + +In the scope of the script containing the above directive the +identifiers `matmult' and `addmult' will be available at type +[[num]]->[[num]]->[[num]] and will behave as if their definitions had +been written using 0, (+), (*) in place of the identifiers zero, add, +mult. + +The order in which the bindings are given is immaterial (it need not be +the order in which the identifiers occurred in the %_f_r_e_e directive) but +a binding must be given for each free identifier of the %included +script. Note that the binding for a type is given using `==' and for a +value using `='. If the types of all the bindings (taken together) are +not consistent with the information given in the free directive of the +%included script, or if any required binding is missing, the compiler +will reject the %_i_n_c_l_u_d_e directive as incorrect. + +The main advantage of a parametrised script is that different bindings +may be given for its free identifiers on different occasions. For +example the same script "matrices" may be invoked with different +bindings to provide a definition of matrix addition and multiplication +over matrices with elements of type bool. Thus:- + + %_i_n_c_l_u_d_e "matrices" {elem==bool; zero=False; mult=&; add=\/; } + +It is even possible to %_i_n_c_l_u_d_e the same parametrised script twice in +the same scope (presumably with different bindings for the free +identifiers) but in this case it will be be necessary to alias apart the +two sets of exported identifiers to avoid a nameclash. So we might add +`b_matadd/matadd b_matmult/matmult' to the above directive if it were +being used in the same script as the previous one. + +_M_i_s_c_e_l_l_a_n_e_o_u_s_ _p_o_i_n_t_s + +By default the identifiers declared %_f_r_e_e in a parametrised script are +not exported from the script. As always this can be overridden by +explicitly listing them in an %_e_x_p_o_r_t directive. + +Free typenames of non-zero arity are declared in the following style. + + %_f_r_e_e { stack * :: _t_y_p_e + table * ** :: _t_y_p_e + ... + } + +The corresponding bindings could be as follows + + %_i_n_c_l_u_d_e ... {stack * == [*]; table * ** == [(*,**)]; ... } + +When a parametrised script exports a locally created typename (other +than a synonym type), each instantiation of the script by a %_i_n_c_l_u_d_e is +deemed to create a NEW type (this is relevant to deciding whether or not +two types are the same for the purpose of readopting a type orphan, see +previous manual section). This is because the compiler assumes that an +abstract or algebraic type defined in a parametrised script will in +general have an internal structure that depends on the free identifiers. + +Finally note that the bindings for the free identifiers of a +parametrised script must always be given EXPLICITLY. For example +suppose we wish to %_i_n_c_l_u_d_e the file "matrices" in a script already +containing a type called `elem' over which we intend to do matrix +multiplication. We must write + + %_i_n_c_l_u_d_e "matrices" {elem==elem; etc. } + +The binding `elem==elem' is not redundant, nor is it cyclic, because the +two `elem's involved refer to two different scopes (on the left of the +binding, that of the includee, and on the right that of the script +containing the directive). + diff --git a/miralib/manual/27/5 b/miralib/manual/27/5 new file mode 100644 index 0000000..22e4753 --- /dev/null +++ b/miralib/manual/27/5 @@ -0,0 +1,132 @@ +_S_e_p_a_r_a_t_e_ _c_o_m_p_i_l_a_t_i_o_n_ _a_n_d_ _`_._x_'_ _f_i_l_e_s + +The Miranda compiler compiles to an intermediate code, based on +combinators. When a Miranda expressions are evaluated in the course of +a session this code is executed by an interpreter. + +Since compilation is a complex process (involving lexical analysis, +parsing, type checking and code-generation, as well as a number of other +minor steps) it is undesirable that the results of compiling a script +should just be "thrown away" at the end of a session. To avoid +unnecessary acts of recompilation the Miranda system maintains an +object-code file in association with each source file containing a +Miranda script. + +For each source file, called say `script.m', the Miranda system will +create an object code file, called `script.x'. No action is required by +the user to keep these files up-to-date, since this is taken care of +automatically by the Miranda system. The .x files are never referred to +directly by the Miranda user, and you should not try to edit them (they +contain binary data). + +You may however safely remove any .x file (if for example you don't wish +it to use up filespace) since this will at worst cause the Miranda +compiler to do some extra work later to recreate it. + +If you select a script as the current script of a Miranda session, and +it has an up-to-date .x file, this will be loaded instead, avoiding +recompilation. If the .x file does not exist, or _a_n_y_ _ _r_e_l_e_v_a_n_t_ _ _s_o_u_r_c_e_ +_f_i_l_e_ _h_a_s_ _b_e_e_n_ _m_o_d_i_f_i_e_d since the .x file was created, the script will be +recompiled (and a side effect of your having selected this source file +as the current script will be to bring into existence an up-to-date .x +file for it). + +[Inductive definition - source file B is `relevant' to source file A iff +file A %inserts or %includes B or any file to which B is relevant. For +a discussion of `%include' and the other library directives see manual +sections on `The Library Mechanism'.] + +Note that compiling a script containing %include statements will have +the side effect of triggering subsidiary compilation processes for any +relevant source files which have been modified since their corresponding +.x file was created. Users familiar with the UNIX program `make' will +recognise this process as essentially the same as that which happens +when a `makefile' is obeyed. In the case of Miranda however, the `make' +process is fully automated by being built into the compiler. + +_M_o_r_e_ _a_d_v_a_n_c_e_d_ _i_n_f_o_r_m_a_t_i_o_n + +If you want to check that a given Miranda script has an up-to-date +object code file _w_i_t_h_o_u_t entering a Miranda session, this can be +accomplished from UNIX by calling mira with a special flag, thus + mira -make script.m + +will force the existence of an up-to-date `script.x', performing all +(and only) those compilations which are necessary. Any number of source +files can be given after the -make flag (and as usual if a `.m' +extension is omitted it will be added automatically). + +Example:- to make sure every Miranda source file in your current +directory has an up-to-date object code file, say `mira -make *.m'. + +Applying mira -make to a `.x' file is equivalent to applying it to the +corresponding `.m' file. So another way to make sure everything in your +current directory is up-to-date is to say `mira -make *.x'. This has +the advantage that it will also remove any `.x' files whose `.m' files +no longer exist. + +In the best UNIX tradition mira -make does its work silently unless +something is wrong. If the source files are all correct closed scripts +with up-to-date `.x' files, mira -make says nothing at all. If +recompilations are necessary it informs you which source files are being +compiled, and, as a last step, the names of any scripts which contain +errors or undefined names are listed, to stdout. + +The exit status of a `mira -make' (relevant if you are a shell +programmer, or wish to include a `mira -make' command in a makefile for +a larger setup) is as follows. If (AFTER any necessary recompilations +have been performed) all the source files have up-to-date `.x' files, +and do not contain any syntax errors, type errors, or undefined names +(these facts are recorded in .x files) the exit status will be zero +(=ok), otherwise it will be 1. + +It is possible to find out what names are exported from one or more +Miranda scripts without entering a Miranda session by using the command + mira -exports files +(as always the `.m' extension is added automatically to each filename, +if missing). This command first calls `mira -make' on each file, to +make sure everything is uptodate, and then lists to standard output the +exported names together with their types (one per line). If more than +one file is specified each group of names will be preceded by the name +of the file to which they appertain. + +Note that the export profile of a script includes information about its +free identifiers (if any). + +It is also possible to find out the names of all files on which a given +set of Miranda scripts depend, via %include and %insert statements, by +using the command + mira -sources files +This lists to standard output, one per line, the names of all relevant +source files. The standard environment, <stdenv>, is always omitted +from the list. + +_E_f_f_e_c_t_ _o_f_ _`_m_v_'_ _a_n_d_ _`_r_m_' + Finally we note a couple of points about the behaviour of Miranda .x +files under applications of mv and rm to their corresponding sources. + +A `.x' file records (inter alia) the names of all relevant source files +relative to the directory in which it is stored, together with their +`date and time last modified'. Note that the UNIX command `mv' does not +alter the time-last-modified of the file being moved. So it is possible +when moving a miranda source file (or a group of interdependant source +files) from one directory to another to save mira the bother of +recompiling them, simply by moving all the relevant `.x' files into the +new directory along with the sources. (This doesn't work however if you +change the name of any of the source files during the move.) + +[Note that `tar' has the same property, so the up-to-date-ness of +Miranda .x files is preserved across a tape dump.] + +If you use `rm' to remove a Miranda source file, the next time you +invoke mira with the (now non-existent) file as its current script, it +will promptly remove the corresponding `.x' file. The logic of this is +as follows:- `.x' files must be kept up-to-date with their sources, and +the way to make a `.x' file up-to-date with a non-existent source is to +make it too non-existent. As a consequence it is not possible to send +someone a Miranda object code file without the corresponding source +(mira will delete it as soon as they try to use it!). + +From some points of view this last feature might be regarded as a bug - +a way round it may be provided in a later release of the Miranda system. + diff --git a/miralib/manual/27/contents b/miralib/manual/27/contents new file mode 100644 index 0000000..f9db2c8 --- /dev/null +++ b/miralib/manual/27/contents @@ -0,0 +1,8 @@ +_T_h_e_ _M_i_r_a_n_d_a_ _L_i_b_r_a_r_y_ _M_e_c_h_a_n_i_s_m + + 1. Syntax of library directives + 2. The %include directive (basic information) + 3. About library directives (more detailed information) + 4. The %free directive and parametrised scripts + 5. Separate compilation and `.x' files + diff --git a/miralib/manual/28 b/miralib/manual/28 new file mode 120000 index 0000000..d0e6aa8 --- /dev/null +++ b/miralib/manual/28 @@ -0,0 +1 @@ +../stdenv.m
\ No newline at end of file diff --git a/miralib/manual/29 b/miralib/manual/29 new file mode 120000 index 0000000..2475c35 --- /dev/null +++ b/miralib/manual/29 @@ -0,0 +1 @@ +29.m
\ No newline at end of file diff --git a/miralib/manual/29.m b/miralib/manual/29.m new file mode 100644 index 0000000..9479de6 --- /dev/null +++ b/miralib/manual/29.m @@ -0,0 +1,88 @@ +> || _L_i_t_e_r_a_t_e_ _s_c_r_i_p_t_s_ _(_a_n_ _a_l_t_e_r_n_a_t_i_v_e_ _c_o_m_m_e_n_t_ _c_o_n_v_e_n_t_i_o_n_) + +The standard comment convention for Miranda scripts is that anything +rightwards from a pair of vertical bars to the end of a line is taken to +be comment and ignored by the compiler, thus + ||This is a comment + +Everything else in the script is taken to be formal program text. An +inverted style of commenting is also available in Miranda, permitting +the construction of a "literate script" (the name is taken from +Professor Donald Knuth's idea of "literate programming"). In a literate +script EVERYTHING is assumed to be comment, except for lines marked with +the formalising symbol '>' in column 1. For example the following lines + +> fac 0 = 1 +> fac (n+1) = (n+1)*fac n + +would be taken as formal program text - and could be preceded and/or +followed by some narrative explaining what the factorial function is and +why we define it in this way. + +To minimise the danger that you will accidentally omit the '>" from one +line of your formal text without the compiler noticing that something is +wrong, the following additional rule applies to Miranda literate scripts +- whenever a group of lines of formal program text is preceded or +followed by some lines of "narrative", the two types of text must be +separated by at least one blank line. You will see that this has been +done for the definition of factorial given above. (Definition - a +"blank line" is one containing only white space.) + +Within the formal sections of a literate script the standard comment +convention still works. For example + +> result = sum [fac n | n <- [1..50]] ||NB this is a large number! + +The compiler takes a decision on which comment convention applies by +looking at the first line of a script. If this has a '>' in column 1, +then it is a literate script, otherwise the compiler assumes it is a +conventional script. Typically the first line of a literate script will +just be a comment, eg + +> ||This is a literate script + +In fact this manual section is a legal Miranda script, defining `fac' +and `result' (see first line). + +An alternative convention is based on the name of the file - if this +ends in `.lit.m' then it is assumed to be a literate script, +independently of the form of the first line. This makes it possible to +have literate scripts which begin in `narrative' mode. + +As an aid to maintaining good layout in literate scripts, a simple text +formatting program, called `just' (short for justify), is supplied with +the Miranda system. This leaves untouched the formal sections of the +script and formats the narrative parts to specified width (default 72). + +There is a UNIX manual page for `just' which gives details of its +behaviour. Note that `just' is a general purpose text formatting tool +and is not in any way Miranda-specific. + +As an additional aid to the use of document preparation tools in +conjunction with Miranda scripts, the Miranda compiler will recognise +underlined keywords. This applies both to reserved words, such as `_d_i_v' +and `_m_o_d' and to directives such as `_%_e_x_p_o_r_t' (underlining of the +initial `%' is optional). The style of underlining accepted is +`backspace-underline-character' as generated by nroff/troff. It will +also recognise the underlined symbols _> and _< as being equivalent to >=, +<= respectively. This works in both literate scripts and scripts using +the standard comment convention. + +_U_s_i_n_g_ _L_a_T_e_X_ _w_i_t_h_ _M_i_r_a_n_d_a_ _l_i_t_e_r_a_t_e_ _s_c_r_i_p_t_s + Because of the `.lit.m' convention it is possible for a file to be both +a Miranda script and a LaTeX source file. In such a case the sections +of formal Miranda text (recognised by the Miranda compiler by the `>' in +column 1) will be surrounded by the LaTeX commands + \begin{verbatim} + + \end{verbatim} + A similar arrangement can be made for troff. + +[The 1989 distribution included a program, mtotex, for using mira with +LaTeX, but this no longer works and has been removed - DT] + +_A_c_k_n_o_w_l_e_d_g_e_m_e_n_t_s + The '>' inverse-comment convention (and the "blank line" rule) are due +to Richard Bird and Philip Wadler of Oxford University Programming +Research Group, and were first used in their language "Orwell". + diff --git a/miralib/manual/3 b/miralib/manual/3 new file mode 100644 index 0000000..46206c7 --- /dev/null +++ b/miralib/manual/3 @@ -0,0 +1,55 @@ +_A_b_o_u_t_ _t_h_i_s_ _r_e_l_e_a_s_e + +This is Miranda release two of October 1989 rereleased thirty years on +as open source - as historical record and in the hope that it may still +be useful. Originally released in 1985, Miranda was the first widely +used non-strict, purely functional language with polymorphic typing and +had a significant influence on the development of the field. + +The source code has been revised to the current C standard (C11) so it +will compile for both 32 and 64 bit platforms. Various bugs have been +fixed and some features added (see the Changes section of the manual) +but the Miranda language and main features of the system interface +remain unchanged. The manual has been revised in places for clarity and +to remove out of date material. + +The online manual pages are primarily intended to document the system at +the level required by someone who already knows quite a lot about +programming languages and has some previous exposure to functional +programming. There is a certain amount of tutorial material, but if you +are a beginner to functional programming you may find parts of the +manual hard to follow, and will need to seek help elsewhere. + +The following paper gives a convenient summary of the main features of +Miranda: + D. A. Turner "An Overview of Miranda", SIGPLAN Notices, December 1986. +A copy of this paper is included in the manual pages, but this and other +information about Miranda can be found on the world wide web at + miranda.org.uk + +Miranda has two available text books + +1. Simon Thompson "Miranda: the Craft of Functional Programming", + Addison-Wesley, 470 pages, 1995. + ISBN 0-201-42279-4 (Paperback) +A webpage for the book by the author is at + www.cs.kent.ac.uk/people/staff/sjt/Miranda_craft/ +or follow the link under BOOKS at miranda.org.uk. + +2. Chris Clack, Colin Myers & Ellen Poon "Programming with Miranda", + Prentice Hall, 312 pages, 1995. + ISBN 0-13-192592-X +The rights in this book have reverted to the authors who have made it +available online - follow link under BOOKS at miranda.org.uk. + +There were two other texts, both now out of print, but there may be +copies in a library or with second hand book sellers. + + Richard Bird & Philip Wadler "An Introduction to Functional Programming", + Prentice Hall, 293 pages, March 1988. + This used a mathematical notation, quite closely based on Miranda but + equally suitable for use with other functional languages. + + Ian Holyer "Functional Programming with Miranda" + Pitman, 215 pages, 1991 + diff --git a/miralib/manual/30 b/miralib/manual/30 new file mode 100644 index 0000000..b28e6ee --- /dev/null +++ b/miralib/manual/30 @@ -0,0 +1,261 @@ +_S_o_m_e_ _g_u_i_d_e_l_i_n_e_s_ _o_n_ _g_o_o_d_ _p_r_o_g_r_a_m_m_i_n_g_ _s_t_y_l_e_ _i_n_ _M_i_r_a_n_d_a + +We give here a series of suggested guidelines for good programming style +in Miranda. The list is not meant to be exhaustive. These rules are +also not intended to be followed in all cases, regardless of conflicting +considerations. That is why they are only suggestions for good style +and not grammar rules. + +_A_v_o_i_d_ _t_h_e_ _i_n_d_i_s_c_r_i_m_i_n_a_t_e_ _u_s_e_ _o_f_ _r_e_c_u_r_s_i_o_n + A Miranda script that consists of large number of functions which call +each other in an apparently random fashion is no easier to understand +than, say, a piece of FORTRAN code which is written as a rat's nest of +GOTO statements. An excessive reliance on recursion (especially mutual +recursion) can be an indication of a weak programming style. Some +pointers: + +Use list comprehensions, `..' lists, and library functions, in +preference to ad-hoc recursion. For example it is probably clearer to +define factorial by writing + fac n = product[1..n] + +than to define it from first principles, as + fac 0 = 1 + fac (n+1) = (n+1) * fac n + +and to define the cartesian product of two lists by a list +comprehension, thus + cp x y = [(a,b)|a<-x;b<-y] + +is certainly a lot clearer than the recursive definition, + cp (a:x) y = f y ++ cp x y + where + f (b:y) = (a,b): f y + f [] = [] + cp [] y = [] + +The standard environment contains a number of useful list processing +functions (eg map filter reverse foldr foldl) with whose properties it +is worth becoming familiar. They capture common patterns of recursion +over lists, and can often be used to simplify your code, and reduce the +reliance on `ad-hoc' recursion. Programs using list comprehensions and +standard functions are also likely to run faster (on the current +implementation) than equivalent programs using ad-hoc recursion. + +The standard environment is only a basic collection of useful general +purpose functions. As you get used to programming in Miranda you will +probably begin to discover other useful functions that express common +patterns of recursion (perhaps over data structures other than lists). +It is a good practice to collect such functions in libraries (together +with some explanations of their properties) so that you can reuse them, +and share them with others. Not all of them will survive the test of +time, but it cannot hurt to experiment. + +To cause the definitions from such a library to be in scope in another +script you would use a `%include' directive (see manual section on +library directives). + +_A_v_o_i_d_ _u_n_n_e_c_e_s_s_a_r_y_ _n_e_s_t_i_n_g_ _o_f_ _d_e_f_i_n_i_t_i_o_n_s + Scripts that get deeply nested in where-clauses are harder to +understand, harder to reason about formally, harder to debug (because +functions defined inside where's cannot be exercised seperately) slower +to compile, and generally more difficult to work with. + +A well structured script will consist of a series of top-level +definitions, each of which (if it carries a where-clause at all) has a +fairly small number of local definitions. A third level of definition +(where inside where) should be used only very occasionally. [And if you +find yourself getting nested four and five levels deep in block +structure you can be pretty sure that your program has gone badly out of +control.] + +A function should normally be placed inside a where clause only if it is +logically necessary to do so (which will be the case when it has a free +variable which is not in scope outside the where clause). If your +script consists, of say six functions, one of which solves a problem and +the other five of which are auxiliary to it, it is probably not a good +style to put the five subsidiary functions inside a where clause of the +main one. It is usually better to make all six top level definitions, +with the important one written first, say. + +There are several reasons for this. First that it makes the program +easier to read, since it consists of six separate chunks of information +rather than one big one. Second that the program is much easier to +debug, because each of its functions can be exercised separately, on +appropriate test data, within a Miranda session. Third that this +program structure is more robust for future development - for example if +we later wish to add a second `main' function that solves a different +problem by using the same five auxiliary functions in another way, we +can do so without having to restructure any existing code. + +There is a temptation to use `where' to hide information that is not +relevant at top-level. This may be misguided (especially if it leads to +code with large and complex where-clauses). If you don't wish all of +your functions or data structures to be "visible" from outside, the +proper way to do this is to include a `%export' directive in the script. + +Note also that (in the current implementation) functions defined inside +a "where" clause cannot have their types explicitly specified. This is +a further reason to avoid putting structure inside a where clause that +does not logically have to be there. + +_S_p_e_c_i_f_y_ _t_h_e_ _t_y_p_e_s_ _o_f_ _t_o_p_ _l_e_v_e_l_ _i_d_e_n_t_i_f_i_e_r_s + The Milner type discipline is an impressive advance in compiler +technology. It is also a trap for the unwary. The fact that the +Miranda compiler will accept several hundred lines of code without a +single type specification, and correctly infer the types of all the +identifiers does NOT mean that it is sensible to write code with no type +information. (Compare: compilers will also accept large programs with +no comments in, but that doesn't make such programs sensible.) + +For other than fairly small scripts it is good style to insert an +explicit specification of the type of any top level identifier whose +type is not immediately apparent from its definition. Type +specifications look like this + ack::num->num->num +says that `ack' is a function taking two numbers and returning a number. +A type specification can occur anywhere in a script, either before or +after the definition of the corresponding identifier, but common sense +suggests that the best place for it is just before the corresponding +definition. + +If in doubt it is always better to put in a type specification than to +leave it out. The compiler may not need this extra type information but +human beings definitely do. The extra type information becomes +particularly important when your code reaches the level of complexity at +which you start to make type errors. + +If your script contains a type error it is unreasonable to expect the +compiler to correctly locate the real source of the error in the absence +of explicit type declarations. A type error means different parts of +your code are inconsistent with one another in their use of identifiers +- if you have not given the compiler any information about the intended +use of an identifier, you cannot expect it to know which of several +conflicting uses are the `wrong' ones. In such a case it can only tell +you that something is wrong, and indicate the line on which it first +deduced an inconsistency - which may be many lines later than the `real' +error. Explicit type declarations make it much more likely that the +compiler will spot the `real error' on the line where it actually +occurs. + +Code containing explicit type information is also incomparably easier +for other people to read. + +_U_s_e_ _s_a_f_e_ _l_a_y_o_u_t + This is a point to do with the operation of the offside rule. It is +most easily explained by means of an example. Consider the following +definition, here assumed to be part of a larger script + + hippo = (rhino - swan)/piglet + _w_h_e_r_e + piglet = 17 + rhino = 63 + swan = 29 + +Some time after writing this we carry out a global edit to expand +`hippo' to `hippopotamus'. The definition now looks like this. + + hippopotamus = (rhino - swan)/piglet + _w_h_e_r_e + piglet = 17 + rhino = 63 + swan = 29 + +the where-clause has become offside, and the definition will no longer +compile. Worse, it is possible (with a little ingenuity) to construct +examples of layout where changing the length of an identifier will move +a definition from one level of scope to another, so that the script +still compiles but now has a different meaning!!! Replacing an +identifier by a shorter one can cause similar difficulties with layout. + +The layout of the `hippo' definition was unsafe, because the level of +indentation depended on the length of an identifier. There are several +possible styles of `safe' layout. The basic rule to follow is: + + Whenever a right hand side goes on for more than one line + (because it consists of a set of guarded cases, or because it + carries a where clause, or just because it is an expression too + big to fit on one line), you should take a newline BEFORE + starting the rhs, and indent by some standard amount (not + depending on the width of the lhs). + +There are two main styles of safe layout, depending on whether you take +the newline before or after the `=' of the definition. Here are two +possible safe layouts for the `hippo' definition + + hippo = + (rhino - swan)/piglet + _w_h_e_r_e + piglet = 17 + rhino = 63 + swan = 29 + + hippo + = (rhino - swan)/piglet + _w_h_e_r_e + piglet = 17 + rhino = 63 + swan = 29 + +The reason that either style can be used is that the boundary, for +offside purposes, of a right hand side, is set by the first symbol of +the rhs itself, and not by the preceding `=' sign. + +Both of these layouts have the property that the parse cannot be +affected by edits which alter the lengths of one or more identifiers. +Either of these layout styles also have the advantage that successive +levels of indentation can move to the right by a fixed step - this makes +code easier to read and lessens the danger that your layout will `fall +off' the right hand edge of the screen (although if you follow the +advice given earlier about avoiding deeply nested block structure this +is in any case unlikely to be a problem). + +It would be convenient if there was a program for reformatting Miranda +scripts with a standard layout. Apart from ensuring that the layout was +`safe' in the above sense, it might make it easier for people to read +each other's code. A layout program of this kind may be provided in +later releases of the system. + +Acknowledgement: The `hippopotamus' example (and the problem of unsafe +layout) was first pointed out by Mark Longley of the University of Kent. + +_W_r_i_t_e_ _o_r_d_e_r_ _i_n_d_e_p_e_n_d_e_n_t_ _c_o_d_e + When defining functions by pattern matching it is best (except in a few +cases where it leads to real clumsiness of expression) to make sure the +patterns are mutually exclusive, so it does not matter in what order the +cases are written. + +For the same reason it is better style to use sets of guards which are +composed of mutually exclusive boolean expressions. The keyword +`otherwise' sometimes helps to make this less painful. + +By way of illustration of some of the issues here is a definition of a +function `merge' which combines two already sorted lists into a single +sorted result, eliminating duplicates in the process + 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, if a>b + = a:merge x y, otherwise + +Note the use of mutually exclusive sets of patterns (it was tempting to +write `merge x [] = x' as the second case, but the above is probably +better style). + +A related issue to these is that where a function is not everywhere +defined on its argument type, it is good practice to insert an explicit +error case. For example the definition given in the standard +environment for `hd', the function which extracts the first element of a +list, is + hd (a:x) = a + hd [] = error "hd []" + +Of course if a function is applied to an argument for which no equation +has been given, the Miranda system will print an error message anyway, +but one advantage of putting in an explicit call to `error' is that the +programmer gets control of the error message. The other (and perhaps +main) advantage is that for someone else reading the script, it +explicitly documents the fact that a certain use of the function is +considered an error. + diff --git a/miralib/manual/31/1 b/miralib/manual/31/1 new file mode 100644 index 0000000..388cc0d --- /dev/null +++ b/miralib/manual/31/1 @@ -0,0 +1,92 @@ +_I_n_p_u_t_ _f_r_o_m_ _U_N_I_X_ _f_i_l_e_s_ _e_t_c_. + +The following Miranda functions provide an interface to the UNIX file +system from within Miranda expressions: + + read :: [char]->[char] +This takes a string valued argument, which it treats as a UNIX pathname, +and returns the contents of the file or device of that name, also as a +string (i.e. as a list of characters). There is no end-of-file +character, the termination of the file is indicated simply by the end of +the list of characters. The Miranda evaluation terminates with an error +message if the file does not exist or the user does not have read +permission for it. + +A special case - the notation `$-' denotes the contents of the standard +input, as a list of characters. Note that multiple occurrences of `$-' +always denote a single shared input stream. So for example ($- ++ $-) +reads one lot of data from the terminal and duplicates it. + +(See separate subsection on Input/Output of binary data for the binary +versions readb and $:-) + + filemode :: [char]->[char] +Takes a pathname and returns a string representing the access +permissions of the current process to the file of that name. The string +is empty if the file does not exist, otherwise it is of length four +containing, in order, the following characters - 'd' if the file is a +directory, 'r' if it is readable, 'w' if it is writeable, 'x' if it is +executable. Each character not applicable is replaced by '-'. So for +example "drwx" is the filemode of a directory with all access +permissions, while "-rw-" is the filemode of a normal file with read and +write but no execute permission. + + getenv :: [char]->[char] +Looks up the string associated with a given name in the current UNIX +environment (see man (2) getenv in the UNIX manual system). For example + getenv "HOME" +returns the name of the current home directory. Returns the empty +string if the given name not present in the environment. + + system :: [char]->([char],[char],num) +The effect of `system string' is that a UNIX process is forked off to +execute `string' as a shell command (by `/bin/sh'). The result of the +call to `system' is a triple containing the standard output, error +output, and exit_status, respectively, resulting from the execution of +the UNIX command. (The exit_status of a UNIX command is a number in the +range 0..127, with a non-zero exit status usually indicating some kind +of abnormal event.) Note that inspecting the exit_status will force the +Miranda process to wait until the execution of the shell command has +completed - otherwise the two processes proceed concurrently. + +If the attempt to set up a shell process fails, `system' returns the +result ([],errmess,-1), where errmess is an error message. + +WARNING - the function `system' provides a very general interface to +UNIX. Obviously, this can be abused to cause the evaluation of a +Miranda expression to have side effects on the state of the filing +system. It is not intended to be used in this way - `system' should be +used only to _o_b_t_a_i_n _i_n_f_o_r_m_a_t_i_o_n about the state of the world. If you +wish to change the state of the world, this should be done by placing a +`System' message in your output list (see next manual section). + +Since reading data from the terminal would constitute a side effect, the +background process created by `system' comes into being with its +standard input closed. + +_I_m_p_l_e_m_e_n_t_a_t_i_o_n_ _R_e_s_t_r_i_c_t_i_o_n + `read', `filemode', `getenv', and `system' all require their argument +to be at most 1024 characters long. + +_N_o_t_e_ _o_n_ _s_y_s_t_e_m_ _r_e_a_d_i_n_g_ _f_u_n_c_t_i_o_n_s_ _a_n_d_ _r_e_f_e_r_e_n_t_i_a_l_ _t_r_a_n_s_p_a_r_e_n_c_y + +Although `read', `filemode', `getenv' do not have side effects, they are +not referentially transparent because it cannot be guaranteed that an +expression like + read "file" +will return the same result if evaluated twice. Some external event may +have changed the state of the filing system in the meantime. Clearly +the same problem applies to `system' - consider for example the +expression + system "date" +which gets date-and-time as a string. Evaluating this twice in +succession is unlikely to produce the same result. + +Strictly speaking all calls to `read' and the other functions in this +section ought to be evaluated with respect to the state-of-the-world as +it existed before the evaluation of the given Miranda expression +commenced. Otherwise referentially transparent behaviour cannot be +guaranteed. Enforcing this would appear to require, among other things, +taking a copy of the whole filing system before each Miranda +command-level evaluation. For obvious reasons this is not implemented. + diff --git a/miralib/manual/31/2 b/miralib/manual/31/2 new file mode 100644 index 0000000..9348cc5 --- /dev/null +++ b/miralib/manual/31/2 @@ -0,0 +1,138 @@ +_O_u_t_p_u_t_ _t_o_ _U_N_I_X_ _f_i_l_e_s_ _e_t_c_. + +Since Miranda is a functional language, the evaluation of an expression +cannot in itself cause a side effect on the state of the world. The +side effects occur when the value of the expression is printed. The +value of a command level expression is a list of `system messages', +where the possible forms of message are shown by the following type +declaration, + + sys_message ::= Stdout [char] | Stderr [char] | Tofile [char] [char] | + Closefile [char] | Appendfile [char] | System [char] | + Exit num | Stdoutb [char] | Tofileb [char] [char] | + Appendfileb [char] + +The system `prints' such a list of messages by reading it in order from +left to right, evaluating and obeying each message in turn as it is +encountered. The effect of the various messages is as follows. + + Stdout string +The list of characters `string' is transmitted to the standard output, +which will normally be connected to the user's screen. So for example +the effect of obeying + [Stdout "!!!"] +is that three exclamation marks appear on the screen. + + Stderr string +The list of characters `string' is sent to the standard error output. +[Explanation to those unfamiliar with UNIX stream philosophy: all normal +UNIX processes come into existence with a standard input stream, and two +output streams, called standard out and standard error respectively. +Under normal circumstances standard error and standard out are both +connected to the users screen, but in principle they could be connected +to different places.] + + Tofile fil string +The characters of the string are transmitted to the file or device whose +UNIX pathname is given by `fil'. Successive `Tofile' messages to the +same destination are appended together (i.e. the first such message +causes the file to be opened for writing, and it remains open until the +end of the whole message list). Note that opening a file for output +destroys its previous contents (unless preceded by an `Appendfile' +message, see below). + + Closefile fil +The stream which has been opened to the file `fil' (presumably the +subject of some previous `Tofile' messages) is closed. If `fil' was not +in fact open this command has no effect (i.e. is harmless). All +open-for-output streams are automatically closed at the end of a +message-list evaluation, so it is only necessary to invoke `Closefile' +explicitly if you wish to terminate output to given file during a +message-list evaluation. (One reason why you might want to do this is +so as not to have too many output files open at one time, since many +UNIX systems place a limit on the number of streams which a process can +have.) + + Appendfile fil +If obeyed before any `Tofile' messages to destination `fil', causes the +file to be opened in `append-mode', so its previous contents are added +to, instead of being replaced. + +See separate subsection on Input/Output of binary data for explanation +of the binary versions Stdoutb, Tofileb, Appendfileb. + + System string +Causes `string' to be executed as a shell command (by `/bin/sh') at this +point in time. Enables arbitrary UNIX commands to be invoked from +within a Miranda output list. The shell process comes into being with +its streams (standard input, standard output, standard error) inherited +from the Miranda process. + + Exit num +Causes the UNIX process evaluating the message list to terminate at this +point with exit status `num' (an integer between 0 and 127). The +remaining messages in the list (if any) are discarded. The exit status +of a Miranda evaluation which terminates other than by a call to Exit +will be 0 if it terminates successfully or 1 if it encounters a runtime +error. The exit status is only relevant if you are using Miranda to +implement a stand-alone UNIX command (see separate manual page about +this). + +[Explanation: the exit status of a UNIX command is a one byte quantity +which is communicated back to the calling shell and can be tested by it +- the usual convention is that 0 exit status means all ok, anything else +means something was amiss. If you are not into shell programming you +can safely ignore the whole issue.] + +_T_h_e_ _d_e_f_a_u_l_t_ _o_u_t_p_u_t_ _m_e_c_h_a_n_i_s_m + +We have stated above that the value of a command level expression is +expected to be of type `[sys_message]'. + +If it is not of that type mira applies the following rules: + (i) if the value is of type [char] the characters are directed to +standard output, as if you had written [Stdout (expr)]. + (ii) if it is of another type, show is first applied to convert it to +type [char], so it is as if you had written [Stdout (show (expr))] + +This explains how the Miranda system is able to function in its standard +`desk-calculator' mode. + +Be aware that if <stdenv> is not loaded (because you invoked mira with +-stdenv, and the script does not explicitly %include <stdenv> there will +be no type sys_message and only the default output mechanism will be +available. + +_O_u_t_p_u_t_ _r_e_d_i_r_e_c_t_i_o_n + +A Miranda command of the form + exp &> pathname +causes a background process to be set up for the evaluation of `exp', +with both the standard output and the standard error output of the +process redirected to `pathname'. If `exp' is of type [sys_message], +the destination of `Tofile' messages are not affected by the global +redirection - only messages which would otherwise have gone to the +screen are sent to `pathname'. + +If two (blank separated) pathnames are given after the `&>', standard +output is redirected to the first file and standard error to the second. +Thus: + exp &> outfil errfil + +If the `&>' is replaced by a `&>>', instead of overwriting the previous +contents, the relevant output is appended to the end of the file. Thus: + exp &>> pathname(s) +As with the `&>' command, either one or two pathnames can be given, +depending on whether you wish standard error to be merged with standard +out, or separated from it. + +Note that a background process created by a `&>' or `&>>' command has no +standard input - if the expression contains `$-', the latter will +evaluate to `[]'. + +_I_m_p_l_e_m_e_n_t_a_t_i_o_n_ _R_e_s_t_r_i_c_t_i_o_n_s + Arguments representing pathnames (to Tofile, Appendfile, Closefile) are +restricted to 1024 characters in length - pathnames longer than this +cause an error message. The shell command supplied to System is also +restricted to 1024 characters in length. + diff --git a/miralib/manual/31/3 b/miralib/manual/31/3 new file mode 100644 index 0000000..1746682 --- /dev/null +++ b/miralib/manual/31/3 @@ -0,0 +1,42 @@ +_R_e_a_d_i_n_g_ _w_i_t_h_ _i_n_t_e_r_p_r_e_t_a_t_i_o_n_ _(_`_r_e_a_d_v_a_l_s_'_ _a_n_d_ _`_$_+_'_) + +There is a function _r_e_a_d_v_a_l_s which takes a string representing a UNIX +pathname, and returns a list of values found in the file of that name. +The values may be represented by arbitrary Miranda expressions, written +one per line. Blank lines, and Miranda style comments (||...) are +ignored. If the input file appears to be a teletype, _r_e_a_d_v_a_l_s reacts to +syntactically incorrect or wrongly typed data by prompting the user to +repeat the line, and such bad values are omitted from the result list. +If the input file does not appear to be a teletype, bad data causes +readvals to abort with an error message. + +Note that, similarly to _s_h_o_w + (i) _r_e_a_d_v_a_l_s is a reserved word, not an identifier. + (ii) the context in which it is used must be such as to determine its +type monomorphically. Extra type specifications may be needed in the +script to meet this condition. + +Here is a simple example of how _r_e_a_d_v_a_l_s might be used in a script + x :: [num] + x = readvals "data" +The file `data' should contain expressions of type num (one per line). + +The _r_e_a_d_v_a_l_s function provides Miranda with a simple form of data +persistence - data can be written to a file (e.g. using `_s_h_o_w') and read +back using _r_e_a_d_v_a_l_s in a later session. Data objects saved in this way +must of course be finite. Notice also that if you wish to save data +containing functions, you will have to set up some special arrangement, +since such data cannot be written out using `_s_h_o_w'. + +Data of abstract type can be written to file using _s_h_o_w and read back +with _r_e_a_d_v_a_l_s - provided that an appropriate show-function was included +in the signature of the abstract type (see manual section on abstract +types). + +Finally note that $+ behaves exactly like an application of _r_e_a_d_v_a_l_s to +the name of the file to which the standard input is connected. For +example + sum $+ +read a sequence of numeric expressions from the keyboard (one per line) +up to the next control-D, and then returns their sum. + diff --git a/miralib/manual/31/4 b/miralib/manual/31/4 new file mode 100644 index 0000000..5378454 --- /dev/null +++ b/miralib/manual/31/4 @@ -0,0 +1,175 @@ +_U_s_i_n_g_ _M_i_r_a_n_d_a_ _t_o_ _b_u_i_l_d_ _e_x_e_c_u_t_a_b_l_e_ _f_i_l_e_s + +FIRST METHOD (using a `magic string') + +Create a file, prog.m say, containing a normal miranda script, but with +first line + #! /usr/bin/mira -exec + +The first two characters must be "#!" followed by an optional space and +the absolute pathname of the miranda interpreter. This may be somewhere +other than /usr/bin/mira, the UNIX shell command "which mira" should +tell you where it is. The flag "-exec" is necessary and no other flags +should be added. (Note "-exec2" can be substituted for "-exec", see +below.) + +The remainder of the file can be any legal miranda script, which may +%include other scripts. Somewhere in the file, or in an included file, +there must be a definition of `main'. When `prog.m' is executed as a +UNIX command, the result will be that `main' is evaluated, using the +same rules as if you had entered it in an interactive session, and the +results sent to standard output. Remember to give the file execute +permission (e.g. by saying `chmod +x prog.m'). + +A command of this form can take data from the terminal. The notation +`$-' can be used anywhere in the second and later lines of the file to +denote the list of characters taken from the standard input. (That is +`$-' behaves like a Miranda identifier of type [char].) + +The command can be invoked with arguments, eg + prog.m fig 23 +and the notation `$*' can be used in the script as a Miranda identifier +of type [[char]] denoting the argument list, with the convention that +the initial (zero'th) argument is the name of the command. So in this +case the value of `$*' would be + ["prog.m","fig","23"] +If there are no arguments, `$*' will be a singleton list containing just +the command name. + +_E_x_p_l_a_n_a_t_i_o_n + The line beginning `#!' is a standard UNIX incantation, called a `magic +string', indicating that the following pathname is an interpreter to be +invoked with the name of the file in which it occurs as argument (see +under `execve' in section 2 of the UNIX manual). The flag "-exec" +instructs the Miranda system to evaluate `main', which can be of any +type. If main is a string this is sent to stdout, if it is of another +printable type `show main' is sent to stdout, or if main is of type +[sys-message] the sequence of I/O commands is executed. + +Examples + Here is the Miranda "hello world" program + #! /usr/bin/mira -exec + main = "hello world\n" + +The following script is a Miranda version of the UNIX `cat' command - if +it is invoked without arguments it simply copies its standard input to +its standard output, otherwise it concatenates the contents of its +argument files to the standard output. + #! /usr/bin/mira -exec + + main = [Stdout $-], _i_f tl $* = [] + = [Stdout (concat(map read(tl $*)))], _i_f badargs=[] + = [Stderr (concat(map errmess badargs))], _o_t_h_e_r_w_i_s_e + badargs = [f|f<-tl $*;~member(filemode f)'r'] + errmess f = f++": cannot access\n" + +See the manual pages on input from UNIX files and output to UNIX files +for the explanation of `read', `filemode' and the constructors Stdout, +Stderr etc. + +The rule that Miranda source files must have names ending in ".m" is not +enforced for "magic" scripts, in keeping with the UNIX convention that +executables require no special suffix. However a magic script whose +name ends in ".m" can also be made the subject of a miranda session. +This is advantageous during development, as individual definitions can +be tested. A first line beginning #! is ignored by the Miranda compiler +which treats it as a comment. In this situation $* has the value [], +since the script was not executed as a command. + +Note also that if your Miranda executable file has the ".m" suffix, a +corresponding ".x" file will be created at its first call, avoiding the +need for mira to recompile it on subsequent calls (unless there has been +an update of the source file). + +Notes + (1) In some UNIX-like systems `execve' places a limit on the total +length of the `magic string'. + (2) Because in many systems (including Linux) `execve' permits at most +one flag in a magic string, mira does not understand a `-lib' flag given +in conjunction with a `-exec' flag. This is a possible source of +difficulty if you keep the miralib directory at a non-standard place. +One way round this is to set environment variable MIRALIB, instead of +using a `-lib' flag. See manual section on flags etc. [To do: more +general mechanism to add other flags to -exec in a magic string - DT] + (3) If called from the UNIX command line, + mira -exec script.m +will find and evaluate `main' in script.m and in this situation you can +combine -exec with other flags, -lib miralib, -heap N, etc preceding the +name of the script. Any additional arguments following script.m will +be found in $*. + +_D_e_b_u_g_g_i_n_g_ _s_t_a_n_d_-_a_l_o_n_e_ _s_c_r_i_p_t_s + As an aid to debugging a variant flag is available: + #!/usr/bin/mira -exec2 + definitions... +The -exec2 flag has the same effect as -exec but runtime errors (only, +not compile time errors) are redirected to file miralog/prog, where prog +is the name of the script. The redirection takes place if a miralog +directory exists in the current working directory and the process +running the script has write permission to it. This is useful for +debugging cgi scripts written in Miranda, particularly in the not +infrequent situation that they compile without errors and seem to work +fine from the command line but fail when invoked by an http call. (You +will need to create a directory miralog in cgi-bin and chown it to +apache, or whatever personality cgi scripts run as). + +SECOND METHOD (using a `here document') + +Create a file ("prog' say) containing the following + + mira [script] <<! + exp1 + exp2 + . + . + . + ! + +The `!' after << can be replaced by any character sequence - the same +sequence, on a line by itself, terminates the `here document'. + +Remember to make the file executable (by saying `chmod +x prog'). Now +when `prog' is executed as a UNIX command, the result will be that the +miranda expressions `exp1', `exp2' ... will be evaluated in the +environment defined by `script', and the results sent to the standard +output. As usual, if `script' is omitted, a default name `script.m' is +assumed. The text following the special redirection `<<!' is called a +"here-document". The contents of the here-document are fed to the mira +command in place of its standard input. (So anything you would type to +the miranda system at top level can appear in the here document.) + +Here-documents are a normal feature of UNIX, not something special to +miranda. Miranda's only contribution to making this work smoothly is +that it detects when its input is not coming from a terminal, and in +this case suppresses prompts and other extraneous feedback. Note also +that lines beginning `||' are ignored by the Miranda command +interpreter, which gives a way to include comments in the text of the +here-document. + +The program `prog' might be invoked with one or more arguments, for +example, + prog big 23 +In the here-document, `$1' can be used to denote the first argument, +`$2' the second and so on - in this case `big' and `23' respectively +will be textually substituted for these before the here-document is fed +to mira as input. Arguments not present are replaced by empty text. +Other replacements carried out on the text of the here-document are - +`$*' is replaced by all the arguments together, as a single piece of +text, `$#' is replaced by the number of arguments present (`2' in the +case shown above), and `$0' is replaced by the name of the program being +executed (in this case `prog'). + +If the here-document contains instances of `$' which you don't want +replaced by something (for example inside a Miranda string), you have to +escape them by preceding them with a backslash character. But if the +delimiter after the >> is in quotation marks, eg + mira [script] <<"!" + stuff + ! +then no substitutions will take place inside the here-document. + +The drawbacks of commands built in this way are two - (a) they have no +way of taking information from the terminal during execution (because +the here-document replaces the standard input) and (b) the method of +access to command line arguments is clumsy. + diff --git a/miralib/manual/31/5 b/miralib/manual/31/5 new file mode 100644 index 0000000..546724d --- /dev/null +++ b/miralib/manual/31/5 @@ -0,0 +1,105 @@ +_H_o_w_ _t_o_ _c_h_a_n_g_e_ _t_h_e_ _d_e_f_a_u_l_t_ _e_d_i_t_o_r + +The Miranda /edit or /e command (see manual page on Miranda command +interpreter) invokes an editor. By default this is the screen editor +"vi", but if you wish to use another editor, this is easily changed. + +The Miranda command + /editor + +reports the editor currently in use by the Miranda system. To change it +to (for example) pico, say + /editor pico + +Alternatively, when next invoking the miranda system from UNIX you can +supply it with a flag requesting a specific editor by name, as follows: + mira -editor pico + +In either case it is only necessary to do this once since the Miranda +system stores this and other information in a file called ".mirarc" in +your home directory - you should not remove or try to edit this file. + +You can select any editor that is installed on your system. If you are +unfamiliar with vi and haven't an editor in mind, the editor pico (if +installed) is particularly easy to use - it has instructions on screen. +Similar are nano (an open source clone of pico) and joe. Other editors +include emacs and gvim - these both open a separate editor window. + +The editor you select will be used by both the /e command and by + ??identifier +which opens the relevant source file at the definition of identifier. + +_M_o_r_e_ _a_d_v_a_n_c_e_d_ _i_n_f_o_r_m_a_t_i_o_n + +The Miranda system is designed to work with an editor which can open a +file at a specified line number. For example to make the editor `vi' +open `file' at line 13, the UNIX command is + vi +13 file +the Miranda system has built in knowledge of this, so if the installed +editor is `vi' and the compiler has found a syntax error in the script, +the `/e' command will open the script at the line containing the error. + +To retain this ability when substituting another editor, the `/editor' +command requires a template for invoking the chosen editor at a given +line number. In this template the line number is represented by the +character `!' and the filename by `%'. For example the full template +for `vi' would be supplied as follows + /editor vi +! % + +If the `%' character does not occur in the template, Miranda will add +the name of the file at the end of the command. So the template for +`vi' could equally well be given as + /editor vi +! +The same formula works for pico, nano, joe. If the editor is one that +starts up its own window, separate from the Miranda session window (gvim +and emacs do this), you will want to make the editor run as a concurrent +process by putting "&" at the end of the command, thus + /editor emacs +! % & +Note that in this case you must include % where the filename goes, +because adding it after the "&" would not make sense. + +In fact Miranda has built in knowledge of vi, pico, nano, joe, emacs and +gvim, so just giving the name of the editor will generate the correct +template in these cases. + +If you install an editor without the capability to be opened at a +specified line number (i.e. you cannot give a template for it +containing the `!' character), the /e command loses its ability to go to +the right place after an error, and the `??' command will be disabled. + +The Miranda system will work without either of these features, but there +is a significant loss of power in the user interface. + +If the installed editor lacks the `open at line number' feature, you may +find it convenient to have the script listed to the screen during +compilation (this feature of the compiler can be switched on and off by +the commands `/list', `/nolist'). As an assistance to naive users, the +Miranda system turns on `/list' for you if the `/editor' command is used +to install an editor without the `open at line number' feature. + +[Pathological case: if the editor command you wish to install contains a +literal `!' or `%' that you don't want replaced, place a backslash +before the relevant ! or %. This protects it from being expanded.] + +_C_h_e_c_k_i_n_g_ _f_o_r_ _s_o_u_r_c_e_ _u_p_d_a_t_e_s + +If during a session changes have been made to any relevant source file, +the Miranda system automatically recompiles the current script and any +other scripts which it directly or indirectly `%includes' and which have +been changed. At a minimum this check is performed after each /edit +command and after each shell escape. + +A mode of operation possible on a windowing system is to keep an editor +window and Miranda session window both open. In this case more frequent +checking is appropriate and you should say /recheck (see 6 "Summary of +remaining commands"). This sets a flag which tells the Miranda +interpreter to check for source file updates before each evaluation, +instead of only after /e and ! commands. But remember that you will +need to save any edits to file before the `mira' session can see them. + +As an assistance to naive users /recheck is automatically turned on if +/editor is used to install an editor template which includes "&", the +symbol used in UNIX shell commands to start a concurrent process. + +Say /norecheck to revert to the default behaviour. + diff --git a/miralib/manual/31/6 b/miralib/manual/31/6 new file mode 100644 index 0000000..d088c79 --- /dev/null +++ b/miralib/manual/31/6 @@ -0,0 +1,38 @@ +_H_o_w_ _t_o_ _a_l_t_e_r_ _t_h_e_ _s_i_z_e_s_ _o_f_ _w_o_r_k_s_p_a_c_e_s + +The Miranda system uses two main internal workspaces called "heap" and +"dic". If either overflows during a session, a self explanatory error +message is given. The sizes of both areas may changed by the user if +required. Any change made is remembered thereafter and for subsequent +sessions until countermanded. + +The heap contains almost all the data structures created both by the +Miranda compiler and the evaluation system. To compile and/or run very +large scripts you may need a bigger heap. To find out (change) the +current size of the heap say + /heap (or /heap newsize e.g. /heap 2000000 ) + +The heap size may also be altered by using a flag (see below). You +should be aware that running Miranda processes with a very large heap +may give you slower responses. + +The dictionary is used to store identifiers and file names by the +Miranda compiler. It is unlikely that you will need to change the size +of the dictionary. The current size of the dictionary can be +ascertained by the command + /dic + +it cannot be changed dynamically, from within the Miranda system. To +alter the dictionary size use a flag (see next para). + +The sizes of either or both areas may be set by flags when invoking the +miranda system. The following shows both possibilities + mira -dic 80000 -heap 2000000 [script] + +Note that the size of the heap is given in `cells' (a cell is 9 bytes, +currently) and the size of the dictionary is in bytes. + +The most recent settings of the workspace sizes are stored in the file +".mirarc" in the users home directory, and automatically carried over to +the next miranda session. + diff --git a/miralib/manual/31/7 b/miralib/manual/31/7 new file mode 100644 index 0000000..ae6b20c --- /dev/null +++ b/miralib/manual/31/7 @@ -0,0 +1,160 @@ +_O_p_t_i_o_n_s_,_ _s_e_t_u_p_ _f_i_l_e_s_ _e_t_c_. + +The full form of the `mira' command is + mira [flags...] [script] +this command causes a Miranda session to be entered with the given file +as current script. If no script is specified a default filename +`script.m' is assumed. The specified file need not yet exist - in this +case you will be starting a Miranda session with an empty current +script. + +Note that `.m' is the standard extension for Miranda language source +files - the mira command always adds the `.m' extension, if missing, to +any filename argument denoting a Miranda script. + +The available options are: + + -lib pathname +Tells mira to find miralib (directory containing libraries, manual pages +etc.) at `pathname'. The default is to look for miralib of same version +number as the program at `/usr/lib/miralib', `/usr/local/lib/miralib' +and `./miralib', in that order. The -lib flag overrides the version +number check. The same effect is obtained by setting an environment +variable MIRALIB, see next manual section. + + -gc +Switches on a flag causing the garbage collector to print information +each time a garbage collection takes place. This flag can also be +switched on and off from within the miranda session by the commands +`/gc', `/nogc'. + + -count +Switches on a flag causing statistics to be printed after each +expression evaluation. This flag can also be switched on and off from +within the miranda session by the commands `/count', `/nocount'. + + -list + -nolist +Switches on (off) a flag causing Miranda scripts to be listed to the +screen during compilation. This flag can also be switched on and off +from within the miranda session by the commands `/list', `/nolist'. + + -nostrictif +Enables the compiler to accept old Miranda scripts with missing +occurrences of the keyword `if' in guard syntax. Probably obsolete but +retained just in case someone needs it. + + -hush + -nohush +The miranda system decides whether or not to give prompts and other +feedback by testing its standard input with `isatty'. If the standard +input does not appear to be a terminal it assumes that prompts would be +inappropriate, otherwise it gives them. In either case this behaviour +can be overriden by an explicit flag ("-hush" for silence, "-nohush" for +prompts etc). This switch is also available from within a miranda +session by the commands `/hush', `/nohush'. + + -dic SIZE +Causes the dictionary (used by the compiler to store identifiers etc.) +to be set up with SIZE bytes instead of the default 24kb. + + -heap SIZE +Causes the heap to be set up with SIZE cells instead of the default +(currently 100k). This can also be done from within the miranda session +by the command `/heap SIZE'. A cell currently occupies 9 bytes. + + -editor name +Causes the resident editor (initially `vi', unless the environment +variable EDITOR was set to something else) to be `name' instead. This +can also be done from within the miranda session by the command `/editor +name'. + + -UTF-8 + -noUTF-8 +Assume the current locale is (is not) UTF-8 overriding environment vars +(version 2.044 and later). + + -stdenv +Run mira without loading the standard environment. Every script that +needs functions from the standard environment will then have to either +explicitly %include <stdenv> or define the required functions for +itself. Not recommended as normal practice since it may have unexpected +consequences (for example I/O will be limited by the absence of type +sys-message). + + -object +Used for debugging the compiler. Modifies behaviour of ?identifier(s) +to show the associated combinator code, which may or may not be +comprehensible as there is no documentation other than the source code. + +_S_P_E_C_I_A_L_ _C_A_L_L_S + In addition the following special calls to `mira' are available which +do not enter a Miranda session but accomplish another purpose, as +described below. + + mira -man +To enter the miranda online manual system directly from the UNIX shell. + + mira -exp +Special call permitting the use of miranda script as a stand-alone UNIX +command. See separate manual page for details. + + mira -log +Same as -exp except that it redirects stderr to a file log/mira.errors, +if log directory exists in the current directory and mira has write +permission to it. + + mira -make [sourcefiles] +Forces a check that all the miranda source files listed have up-to-date +object code files, triggering compilation processes if necessary (see +manual subsection on the library mechanism: separate compilation). + + mira -exports [sourcefiles] +Sends to stdout a list of the identifiers exported (see manual +subsection on library mechanism: separate compilation) from each of the +given miranda source files, together with their types (may also force +recompilation if needed). + + mira -sources [sourcefiles] +Sends to stdout a list of all the Miranda source files on which the +given source files directly or indirectly depend (via %include or +%insert statements), excluding the standard environment <stdenv>. + + mira -version +Gives version information. This information can also be obtained from +within a Miranda session by the command `/version'. + + mira -V +More detailed version information. + +_S_E_T_U_P_ _F_I_L_E_S + +The current settings of _d_i_c, _h_e_a_p and _e_d_i_t_o_r are saved in the file +`.mirarc' in the users home directory, and are thereby carried over to +the next miranda session. The settings of the compiler flag which +controls whether or not source is listed to the screen during +compilation (toggled by the commands _/_l_i_s_t _/_n_o_l_i_s_t during a Miranda +session) and of the flag which controls the frequency of checking for +source updates (toggled by the commands /recheck /norecheck) are also +saved in the users `.mirarc' file. + +The default settings of these entities, which will be picked up by new +users executing `mira' for the first time, are dic 24000 (bytes), heap +100000 (9-byte cells), editor _v_i, nolist, norecheck. The current +settings can be interrogated from a Miranda session by the command +`/settings' or `/s'. + +The defaults can be changed, on a system wide basis, by moving a copy of +a `.mirarc' file containing the desired settings into the `miralib' +directory (normally found at /usr/lib/miralib). The user's local +.mirarc file, once created in his home directory by the first call to +mira, will override the global one, however. + +The behaviour of the `mira' program is also sensitive to the settings of +certain environment variables - see separate manual entry about this. + +_O_U_T_P_U_T_ _B_U_F_F_E_R_I_N_G + Output from the Miranda system to the user's terminal should not be +line buffered, or some things will not work as they are intended. There +is no problem about input being line buffered, however. + diff --git a/miralib/manual/31/8 b/miralib/manual/31/8 new file mode 100644 index 0000000..7b35202 --- /dev/null +++ b/miralib/manual/31/8 @@ -0,0 +1,83 @@ +_E_n_v_i_r_o_n_m_e_n_t_ _v_a_r_i_a_b_l_e_s_ _u_s_e_d_ _b_y_ _M_i_r_a_n_d_a + (This section may be of particular interest to installers and system +administrators) + +The behaviour of the `mira' program is sensitive to the settings of +certain environment variables. + +An alternative location for the miralib directory may be specified by +setting the environment variable "MIRALIB". An explicit -lib flag, if +present, overrides this. + +The first time it is called (i.e. if no .mirarc file is present, either +in the home directory or in miralib) the miranda system picks up the +name of the resident editor from the environment variable EDITOR - if +this is not set it assumes `vi'. + +At startup (version 2.044 and later) `mira' inspects LC_CTYPE or if that +is empty LANG, to determine if it is running in a UTF-8 locale. On +Windows/Cygwin this information is taken from the "user-default ANSI +code page". The flag -UTF-8 or -noUTF-8, if present, overrides. + +If the environment variable RECHECKMIRA is set (to any non-empty string) +the Miranda system rechecks to see if any relevant source files have +been updated, and performs any necessary recompilation, before each +interaction with the user - this is the appropriate behaviour if an (eg +emacs) editor window is being kept open permanently during the Miranda +session. If this environment variable is not set, the check is +performed only after `/e' commands and `!' escapes. + +To decide what shell to use in `!' escapes, mira looks in the +environment variable SHELL (this will normally contain the name of the +user's login shell). If no SHELL is entered in the environment, /bin/sh +is assumed. + +If environment variable MIRAPROMPT is set, its contents will be used as +the session prompt, instead of the default prompt "Miranda " (version +2.044 and later). + +If the environment variable NOSTRICTIF is set (to any non-empty string) +Miranda accepts old scripts with no `if' after the guard comma. + +For displaying pages of the manual mira uses the program entered in the +environment as VIEWER - if this variable is not set the default is +likely to be 'more -d' or (roughly equivalent) 'less -EX'. + +If you set VIEWER to something, you may also need to set an environment +variable RETURNTOMENU. + +RETURNTOMENU=YES prevents another prompt being given after displaying +each section, causing instead an immediate return to contents page. It +should be `YES' if VIEWER is a program that pauses for input at end of +file (eg "less"), `NO' if VIEWER is a program that quits silently at end +of file (eg "more", "less -EX"). + +Finally note that a third environment variable MENUVIEWER can be set to +choose the program used to display contents pages (by default this is +normally 'cat' or 'more'). + +To find the current settings of these display commands enter + ??? +to the "next selection" prompt of the manual system. + +_H_o_w_ _t_o_ _s_e_t_ _a_n_ _e_n_v_i_r_o_n_m_e_n_t_ _v_a_r_i_a_b_l_e_ _i_n_ _y_o_u_r_ _U_N_I_X_ _s_h_e_l_l_: + (Reminder/tutorial information) + +Example, setting the environment variable VIEWER to /usr/local/view + + (i) if you use a Bourne-like shell (sh ksh bash) + say at the UNIX command level (i.e. before calling Miranda) + + export VIEWER=/usr/local/view + + to undo the above say `unset VIEWER', + to make permanent add this line to your .profile or .bashrc + + (ii) if you use a C shell (csh tcsh) + say at the UNIX command level (i.e. before calling Miranda) + + setenv VIEWER /usr/local/view + + to undo the above say `unsetenv VIEWER', + to make permanent add the setenv line to your .login or .cshrc + diff --git a/miralib/manual/31/9 b/miralib/manual/31/9 new file mode 100644 index 0000000..8e6bb2d --- /dev/null +++ b/miralib/manual/31/9 @@ -0,0 +1,54 @@ +_I_n_p_u_t_/_o_u_t_p_u_t_ _o_f_ _b_i_n_a_r_y_ _d_a_t_a + +From version 2.044 Miranda stdenv.m includes a function + readb :: [char]->[char] +and new sys-message constructors + Stdoutb :: [char]->sys_message + Tofileb :: [char]->[char]->sys_message + Appendfileb :: [char]->[char]->sys_message + +These behave similarly to (respectively) read, Stdout, Tofile, +Appendfile but are needed in a UTF-8 locale for reading/writing binary +data (for further explanation see below). In a non UTF-8 locale they do +not behave differently from read, Stdout etc but you might still prefer +to use them for handling binary data, for portability reasons. + +The notation $:- is used for the binary version of the standard input. +In a non UTF-8 locale $:- and $- will produce the same results. It is +an error to access both $:- and $- in the same evaluation. + +_E_x_p_l_a_n_a_t_i_o_n + +The locale of a UNIX process is a collection of settings in the +environment which specify, among other things, what character encoding +is in use. To see this information use `locale' as a shell command. +The analogous concept in Windows is called a "code page". + +UTF-8 is a standard for encoding text from a wide variety of languages +as a byte stream, in which ascii characters (codes 0..127) are +represented by themselves while other symbols are represented by a +sequence of two or more bytes: a `multibyte character'. + +The Miranda type `char' consists of characters in the range (0..255) +where the codes above 127 represent various accented letters etc +according to the conventions of Latin-1 (i.e. ISO-8859-1, commonly used +for West European languages). There are national variants on Latin-1 +but since Miranda source, outside comments and string and character +constants, uses only ascii this does not normally cause a problem. + +In a UTF-8 locale: on reading string/character literals or text files +Miranda has to translate multibyte characters to the corresponding point +in the Latin-1 range (128-255). If the text does not conform to the +rules of UTF-8, or includes a character not present in Latin-1, an +"illegal character" error occurs. On output, Miranda strings are +translated back to UTF-8. + +If data being read/written is not text, but binary data of some kind, +translation from/to UTF-8 is not appropriate and could cause "illegal +character" errors, and/or corruption of data. Whence the need for the +byte oriented I/O functions readb etc, which transfer data without any +conversion from/to UTF-8. + +In a non UTF-8 locale read and readb, Tofile and Tofileb, etc. do not +differ in their results. + diff --git a/miralib/manual/31/contents b/miralib/manual/31/contents new file mode 100644 index 0000000..ef9fdbd --- /dev/null +++ b/miralib/manual/31/contents @@ -0,0 +1,12 @@ +_U_N_I_X_/_M_i_r_a_n_d_a_ _s_y_s_t_e_m_ _i_n_t_e_r_f_a_c_e_ _i_n_f_o_r_m_a_t_i_o_n + + 1. Input from UNIX files etc + 2. Output to UNIX files etc + 3. Reading with interpretation (`_r_e_a_d_v_a_l_s' and $+) + 4. Using Miranda to build UNIX commands + 5. How to change the default editor + 6. How to alter sizes of workspaces + 7. Options, setup files etc + 8. Environment variables used by Miranda + 9. Input/Output of binary data + diff --git a/miralib/manual/32 b/miralib/manual/32 new file mode 100644 index 0000000..a54d084 --- /dev/null +++ b/miralib/manual/32 @@ -0,0 +1,98 @@ +_R_E_C_E_N_T_ _C_H_A_N_G_E_S + +January 2020 (version 2.066) + +The Miranda source code has been revised to conform to the C11 standard +and to run on both 64 and 32 bit platforms. Earlier releases were 32 +bit only. + +December 2019 (version 2.057) + +Miranda type `char' now includes all Unicode characters, which can be +specified by hexadecimal escape codes in char and string constants. For +example '\x5d2' is the Hebrew letter Gimel. + +The lexical syntax of Miranda has been extended to include octal and +hexadecimal numerals - e.g. 0o777 is 511 and 0xffffffff is 4294967295. + +See man section 11 (literals) for details of both the above. + +Functions showoct, showhex :: num->[char] have been added to the +standard environment. + +Data types with "laws", declared obsolete at release two, have finally +gone. Strictness annotations: `!' on fields of an algebraic data type +remain part of the language, see man section 20 (algebraic data types). + +The flag -exp, for executable scripts, has gone and is replaced by +-exec, see man section 31/4 (Using Miranda to build UNIX commands). +This is not backwards compatible (sorry) but the change needed is +trivial. If you have a magic script + #!/usr/bin/mira -exp + expression + definitions... +change it to + #!/usr/bin/mira -exec + main = expression + definitions... +The new mechanism executes `main' wherever it is in the script (whereas +-exp required an expression on the second line). + +_O_l_d_e_r_ _C_h_a_n_g_e_s (in reverse date order) + +September 2009 (version 2.044) + +The environment variable MIRAPROMPT may be set to a string to be used as +the Miranda session prompt instead of the default "Miranda ". + +For reading/writing binary files in UTF-8 locale, stdenv is extended by + readb, Stdoutb, Tofileb, Appendfileb +these behave similarly to + read, Stdout, Tofile, Appendfile +but transfer data as bytes with no conversions from/to UTF-8. See new +manual section 31/9. + +August 2008 (version 2.041, 2.042) + +Miranda now detects if it is in UTF-8 locale and converts from/to UTF-8 +on reading/writing string and char values. + +May 2006 (version 2.032) + +The commands /nostrictif, /strictif to control enforcement of `if' in +guard syntax have gone. The `if' has been part of Miranda's syntax +since 1988. In case there are surviving if-less scripts, you can use + mira -nostrictif +or set the environment variable NOSTRICTIF to any non-empty string. + +New command /recheck makes mira check if any loaded script has been +updated before every evaluation, instead of only after /edit (/norecheck +to disable). Appropriate if an editor window is running concurrently +with the Miranda session window. The setting is remembered for +subsequent sessions. Formerly enabled by setting environment variable +RECHECKMIRA to a non-empty string - that method still works also. + +mira now checks that it has miralib of same version number - exits with +error message otherwise. An explicit mira -lib <path> overrides this +but it is in general inadvisable to run mira with wrong miralib. + +_H_i_s_t_o_r_y_ _o_f_ _M_i_r_a_n_d_a_ _r_e_l_e_a_s_e_s + +1 May 1985 - alpha test, released to University of Kent only. + +October 1985 - beta test (version 0.292 for VAX, 0.293 for SUN) +Distributed to 88 sites. + +April 1987 - release one (version 1.009 or 1.016 or 1.019) +Added literate scripts, library mechanism: %export, %include, (n+k) patterns. +Around 250 sites. + +October 1989 - release two (versions 2.0xx for various machines) +Added unbounded size integers, %free, faster SK reduction m/c +Around 550 sites by mid-90's. + +May 2006 - revised and released as free software (but not open source). + +Nov 2019 - revised and made open source. + +Jan 2020 - revised to C11 standard and made 64 bit compatible. diff --git a/miralib/manual/33 b/miralib/manual/33 new file mode 100644 index 0000000..1d985ce --- /dev/null +++ b/miralib/manual/33 @@ -0,0 +1,4 @@ +The Miranda system is Copyright (c) Research Software Limited, 1985-2019 +and is distributed under an open source license. For terms see the file +COPYING in the miralib directory. + diff --git a/miralib/manual/34 b/miralib/manual/34 new file mode 100644 index 0000000..4631f32 --- /dev/null +++ b/miralib/manual/34 @@ -0,0 +1,87 @@ +_B_u_g_ _R_e_p_o_r_t_s + +Bug reports should be sent to mira-bugs at the domain + miranda.org.uk +First check below, however, in case it is already known. Also check the +downloads section at miranda.org.uk in case there is a new version of +Miranda in which your bug may be fixed. When sending a bug report, +please state the version number of your Miranda system and the platform +that it is running on. + +The error messages from the Miranda system are mostly self explanatory. +Note, however, that messages of the form "impossible event ..." or +similar indicate that the internal state of the system has become +corrupted. This should be reported as a bug. Segmentation faults also +falls into this category. + +First check if the problem only occurs following a garbage collection. +Garbage collector reports can be turned on by `mira -gc' from the +command line or by /gc within a miranda session. If your error does +appear to be associated with garbage collection you can try running with +a bigger heap and/or getting mira recompiled at a lower level of +optimisation (eg -O instead of -O2, or without -O). Miranda uses a +"conservative collector" which scans the C stack to follow things that +are, or appear to be, pointers into the heap. Unfortunately this is +vulnerable to compiler optimisations affecting the state of the stack. + +Even if the problem does appear to be gc-related it is still worth +reporting. + +The source code, orginally written for 32 bit platforms, has been +extensively revised and tested for 64 bit compatibility. It is quite +possible that some hidden "integer width" problems remain in the code +and will be discovered in use. + +_L_i_s_t_ _o_f_ _k_n_o_w_n_ _b_u_g_s_,_ _d_e_f_i_c_i_e_n_c_i_e_s_,_ _a_n_d_ _u_n_i_m_p_l_e_m_e_n_t_e_d_ _f_e_a_t_u_r_e_s + +If there is not enough heap to compile the current script, mira exits +after reporting this fact. The fix is to increase the heap size: + mira -heap N [filename] +where N is a bigger number than you had before. + +It is not currently permitted to give a type specification for an +identifier defined locally, as part of a _w_h_e_r_e clause. That is (see +formal syntax) `spec' is not allowed after _w_h_e_r_e. + +When abstract objects are tested for equality or order (under <, <= etc) +the result is that obtained by applying the operation to the underlying +representation type. In some cases this will be what you want, but in +others it will be wrong - there ought to be a way of controlling this. + +The standard input cannot be accessed both as a list of characters (with +$-) and as a list of values (with $+) at the same time. If $+ is in +use, an occurrence of $- will evaluate to [], and vice versa. This is +not referentially transparent - uses of $+ and $- ought to share data. + +Scripts with multiple occurrences of $+ also behave opaquely - each +occurrence of $+ reads from the terminal independently, and they do not +share data with each other. (Multiple occurrences of $+ in a single +command-level expression behave transparently, however.) + +There is a subtle issue concerning `show' and %export. If you define a +function which, internally, uses `show' on an object of algebraic type, +and then %export that function to another scope, the format used by the +`show' depends on the status of the algebraic type in the NEW scope. +Thus if the type has been aliased the new constructor names will be +used, and if the algebraic type is no longer in scope, it will show as +"<unprintable>" (this latter case can arise if an abstract type based on +the algebraic type is exported, and one of the signature identifiers +invokes `show' on the base type). Although this behaviour is +defensible, it might be better for each use of `show' at algebraic type +to be frozen to use the constructor names in the scope where it occurs. +[An analogous issue arises with `readvals'.] + +Implementation restrictions not mentioned elsewhere in the manual:- + +A shell command called from mira using `!' is limited to 1024 characters +in length after any implied expansions (eg of `%') have been performed. +The same restriction applies to the result of expanding out a `/e' +command. The pathnames of Miranda scripts are limited to 1024 +characters in length, including the `.m' extension. The name of the +editor supplied for the `/e' command, and the absolute pathnames of the +miralib directory, and of the user's home directory, are also each +limited to 1024 characters in length. + +The name of a Miranda script may not contain spaces (but directory names +with spaces are allowed in pathnames). + diff --git a/miralib/manual/4 b/miralib/manual/4 new file mode 100644 index 0000000..8fa4c83 --- /dev/null +++ b/miralib/manual/4 @@ -0,0 +1,147 @@ +_T_h_e_ _M_i_r_a_n_d_a_ _c_o_m_m_a_n_d_ _i_n_t_e_r_p_r_e_t_e_r + +The Miranda system is invoked from unix by the command + mira [script] +where `script' (optional parameter) is the pathname of a file containing +a set of Miranda definitions. If no script is specified a default name +`script.m' is assumed. The named script (script.m by default) becomes +your _c_u_r_r_e_n_t _s_c_r_i_p_t, during the ensuing Miranda session. You can change +your "current script" during a session, but at any time there is a +unique filename which is current. + +Note that a file containing a Miranda script is expected to have a name +ending in `.m' and the `mira' command will add this extension if +missing. So `mira stuff' will be interpreted as `mira stuff.m'. It is +a convenient and widely used convention that files containing program +sources should have names indicating which language they are written in. + +The set of names in scope at any time are those of the current script, +together with the names of any scripts which it `includes' (see library +directives) plus the names of the _s_t_a_n_d_a_r_d _e_n_v_i_r_o_n_m_e_n_t, which is always +in scope. The current script may be an empty or non-existent file if +you have not yet put any definitions in it. In this case just the names +of the standard environment will be in scope. + +The prompt `Miranda' indicates that you are talking to the Miranda +interpreter. This activity is called a Miranda ``session''. Each +command should be typed on a single line, following the prompt, and is +entered by hitting return. Any command not beginning with one of the +special characters `/', `?', or `!' is assumed to be an expression to be +evaluated. The following commands are available during a session. + +exp + Any Miranda expression typed on a line by itself is evaluated, and the +value is printed on the screen. If the value is of type [char] it is +printed literally, otherwise the special function `_s_h_o_w' is applied to +it to convert it to printable form. Example + Miranda sum[1..100] + 5050 (response) + +There is a special symbol $$ which is always set to the last expression +evaluated. So after the above command $$ will have the value 5050, and +this can be used in the next expression - e.g. `$$/2' will produce the +response 2525 (and the value of `$$' is now 2525). + +exp &> pathname + A background process is set up to evaluate exp, and the resulting +output (including error messages, if any) sent to the designated file. + +exp &>> pathname + As above, except that the output is appended to the designated file, +instead of replacing its previous contents. + +exp :: + Print the type of the expression (instead of the value). Useful for +investigating the type structure of a script. + +? + Lists all identifiers currently in scope, grouped by file of origin, +starting with the standard environment. + +?identifier(s) + Gives more information about any identifier defined in the current +environment (namely its type and the name of the file in which it is +defined). This command will also accept a list of identifiers, +separated by spaces. + +??identifier + Opens the relevant source file at the definition of identifier, which +may be any currently in scope. Try for example ??map + For this and several other features to work Miranda must be configured +to use an appropriate editor - the default is vi, but you can change +this. See section 31 subheading 5 of this manual ("How to change the +default editor"). + +!command + Execute any UNIX shell command. + +!! + Repeat last shell command. + +Note that the character `%' can be used in any Miranda session command, +including a `!' command, as an abbreviation for the pathname of the +current script. So for example + !wc % +does a word count on the current script. (If for some reason you need +to include a literal % character in a command, you can escape it with a +preceding backslash.) + +All the remaining commands begin with `/'. Each of the following +commands can be abbreviated to its first letter. + +/edit (also /e) + Edit the current script. Calls up the currently installed editor +(default _v_i, to change this see remark under ?? above). On quitting the +editor, if changes have been made to any relevant source file, the +Miranda system automatically recompiles the current script and any other +scripts on which it depends and which have been updated. + +/edit pathname (also /e pathname) + Edit arbitrary script. Note that the pathname should end in `.m' and +that this will be added if missing. + +Note by the way that (on most UNIX-like systems) Miranda understands the +commonly used `~' convention in pathnames. That is ~/file means file in +your home directory, and ~jack/file means file in jack's home directory. + +/file (also /f) + Print the name of file containing the current script. + +/file pathname (also /f pathname) + Change to new current script. Equivalent to quitting the Miranda +system and reinvoking it with a new sourcefile. Like /e, /f adds ".m" +to the end of the filename if missing. + +Important special case - reselecting the current script, eg by saying + /f % +forces the current script to be RECOMPILED - this is useful if script +has errors and you wish to see the error messages again. + +/help (also /h) + Display summary of main available commands. There are a few less used +auxiliary commands, not covered here /aux (or /a) will summarise these. + +/man (also /m) + Enter online manual system. + +/quit (also /q) + Quit the Miranda system. Typing the end of file character (control-D) +also has this effect. + +Finally note that $- and $+ are allowed as notations for the standard +input in Miranda expressions. The standard input as a list of +characters is denoted by `$-'. As a simple example, evaluating the +expression + reverse $- +causes everything typed at the keyboard upto the next control-D to be +echoed backwards. + +The notation `$+' also denotes the standard input, but as a sequence of +Miranda expressions (one per line), and returns their values as a list. +For example + sum $+ +reads a sequence of numeric expressions from the standard input, and +returns the sum of their values. See the manual section on reading with +interpretation (under UNIX/Miranda system interface) for further +information. + diff --git a/miralib/manual/5 b/miralib/manual/5 new file mode 120000 index 0000000..a8d227c --- /dev/null +++ b/miralib/manual/5 @@ -0,0 +1 @@ +../helpfile
\ No newline at end of file diff --git a/miralib/manual/6 b/miralib/manual/6 new file mode 120000 index 0000000..0ce89f6 --- /dev/null +++ b/miralib/manual/6 @@ -0,0 +1 @@ +../auxfile
\ No newline at end of file diff --git a/miralib/manual/7 b/miralib/manual/7 new file mode 100644 index 0000000..bd9e102 --- /dev/null +++ b/miralib/manual/7 @@ -0,0 +1,81 @@ +_E_x_p_r_e_s_s_i_o_n_s + +In Miranda an expression denotes a value. Expressions occur in two +contexts, but have the same(*) syntax in both situations. First, the +basic mode of operation of the Miranda command interpreter is that it +evaluates expressions typed at the terminal (these are called +`command-level expressions'). Second, expressions are an important +syntactic component of _s_c_r_i_p_t_s (because scripts are collections of +definitions, and the right hand sides of definitions are composed of +expressions). + +Expressions typed at the terminal are volatile - only by being made part +of a script can an expression be saved for future use. + +An expression is either simple, or a function application, or an +operator expression, or an operator. + +_A_ _s_i_m_p_l_e_ _e_x_p_r_e_s_s_i_o_n_ _i_s_ _o_n_e_ _o_f_ _t_h_e_ _f_o_l_l_o_w_i_n_g: + +Identifier: (see separate manual entry) these are of two kinds based on +the case of the initial letter + - variable e.g. `x' or `map' + - constructor e.g. `X' or `True' + +Literal, e.g. 136 or "fruit" (see separate manual entry) + +An operator section (see separate manual entry) + +The keyword `_s_h_o_w' or `_r_e_a_d_v_a_l_s' (see separate manual entries) + +A list, such as `[1,5,7,9]' or a `dotdot' list or a list comprehension +(see manual entry on iterative expressions). + +A tuple, such as `(True,"green",37)'. Tuples differ from lists in that +they can have components of mixed type. They are always enclosed in +round parentheses. The empty tuple, which has no components, is written +`()'. Otherwise, a tuple must have at least two components - there is +no concept of a one-tuple. Tuples cannot be subscripted, but their +components can be extracted by pattern matching. Since there is no +concept of a one-tuple, the use of parentheses for grouping does not +conflict with their use for tuple formation. + +Any expression enclosed in parentheses is a simple expression. + +_F_u_n_c_t_i_o_n_ _a_p_p_l_i_c_a_t_i_o_n + is denoted by juxtaposition, and is left associative, so e.g. + f a b + +denotes a curried function application of two arguments. (So f is +really a function of one argument whose result is another function - +thus `f a b' is actually parsed as `(f a) b' - the advantage of this +arrangement is that `f a' has a meaning in its own right, it is a +partially applied version of f.) + +_O_p_e_r_a_t_o_r_ _e_x_p_r_e_s_s_i_o_n_s + e.g. `5*x-17' +There are a variety of infix and prefix operators, of various binding +powers (see manual entry on operators). Note that function application +is more binding than any operator. + +An operator on its own can be used as the name of the corresponding +function, as shown in the following examples + arith2_ops = [+,-,*,/,div,mod,^] + sum = foldr (+) 0 + +both of which are legal definitions. Note that when an operator is +passed as a parameter it needs to be parenthesised, to force the correct +parse. An ambiguity arises in the case of `-' which has two meanings as +an operator (infix and prefix) - the convention is that `-' occurring +alone always refers to the infix (i.e. dyadic) case. The name `neg' is +provided for the unary minus function, as part of the standard +environment. + +A formal syntax for expressions can be found in the manual section +called `Formal syntax of Miranda scripts'. + +(*) _N_o_t_e There is one exception to the rule that command level +expressions have the same syntax as expressions inside scripts - the +notation `$$', meaning the last expression evaluated, is allowed only in +command level expressions. + diff --git a/miralib/manual/8 b/miralib/manual/8 new file mode 100644 index 0000000..8909b5c --- /dev/null +++ b/miralib/manual/8 @@ -0,0 +1,75 @@ +_O_p_e_r_a_t_o_r_s_ _a_n_d_ _t_h_e_i_r_ _b_i_n_d_i_n_g_ _p_o_w_e_r_s + +Here is a list of all prefix and infix operators, in order of increasing +binding power. Operators given on the same line are of the same binding +power. Prefix operators are identified as such in the comments - all +others are infix. + + operator comments + + : ++ -- right associative + \/ associative + & associative + ~ prefix + > >= = ~= <= < continued relations allowed, eg 0<x<=10 + + - left associative + - prefix + * / _d_i_v _m_o_d left associative + ^ right associative + . associative + # prefix + ! left associative + $identifier $IDENTIFIER right associative + +Brief explanation of each operator: +: prefix an element to a list, type *->[*]->[*] +++ -- list concatenation, list subtraction, both of type [*]->[*]->[*] + A formal definition of list subtraction is given below. +\/ & logical `or', `and', both of type bool->bool->bool +~ logical negation, type bool->bool +> >= = ~= <= < + comparison operators, all of type *->*->bool + Note that there is an ordering defined on every (non-function) + type. In the case of numbers, characters and strings the order + is as you would expect, on other types it as an arbitrary but + reproducible ordering. Equality on structured data is a test + for isomorphism. (i.e. in LISP terms it is "EQUAL" not "EQ"). + It is an error to test functions for equality or order. ++ - plus, minus, type num->num->num +- unary minus, type num->num + Note that in Miranda unary minus binds less tightly than + the multiplication and division operators. This is the + usual algebraic convention, but is different from PASCAL. +* / _d_i_v _m_o_d + times, divide, integer divide, integer remainder, + all of type num->num->num + `/' can be applied to integers or fractional numbers, and + always gives a fractional result, so eg 6/2 is 3.0 + _d_i_v and _m_o_d can only be applied to integers and + give integer results, eg 7 div 2 is 3, 7 mod 2 is 1. + _d_i_v and _m_o_d obey the following laws, for a b any integers + with b ~= 0 + (i) b * (a _d_i_v b) + a _m_o_d b = a + (ii) if b>0 then 0 <= a _m_o_d b < b + if b<0 then b < a _m_o_d b <= 0 +^ `to the power of', type num->num->num +. function composition, type (**->***)->(*->**)->*->*** +# length of list, type [*]->num +! list subscripting, type [*]->num->* + note that the first element of a non-empty list x is x!0 and the + last element is x!(#x-1) +$identifier $IDENTIFIER + do-it-yourself infix, `a $f b' is equivalent in all contexts to + `f a b'. Also works for constructors of two or more arguments. + +_N_o_t_e_ _o_n_ _l_i_s_t_ _s_u_b_t_r_a_c_t_i_o_n + Here is a formal definition of the `--' operator in Miranda. It is +defined using an auxiliary function `remove' which removes the first +occurrence (if any) of a given item from a list. + + x -- [] = x + x -- (b:y) = (remove b x) -- y + remove b [] = [] + remove b (a:x) = x, if a=b + = a:remove b x, otherwise + diff --git a/miralib/manual/9 b/miralib/manual/9 new file mode 100644 index 0000000..3d7599a --- /dev/null +++ b/miralib/manual/9 @@ -0,0 +1,62 @@ +_S_e_c_t_i_o_n_s + +An infix operator can be partially applied, by supplying it with only +one of its operands, the result being a function of one argument. Such +expressions are always parenthesised, to avoid ambiguity, and are called +`sections'. Two different kinds of sections (called presections and +postsections) are possible since either the first or the second operand +can be supplied. + +An example of a presection is + (1/) +which denotes the reciprocal function. An example of a postsection is + (/3) +which gives a concise notation for the `divide by three' function. Note +that both of these examples are functions of type (num->num). With one +exception (see below) sections can be formed using any infix operator. +Further examples are (0:) which is a function for prefixing lists of +numbers with zero, and (^2) which is the square function. + +Sections may be regarded as the analogue of currying for infix +operators. They are a minor syntactic convenience, and do not really +add any power to the language, since any function denoted in this way +could have been introduced by explicit definition. For the first two +examples given above we could have written, say + reciprocal y = 1/y + divide_by_three x = x/3 +and then used the function names, although this would have been somewhat +more verbose. + +To summarise the conventions for infixes, taking infix division as an +example, note that the following expressions are all equivalent. + a / b + (/) a b + (a /) b + (/ b) a + +The usual rules about operator precedence (see manual section on +operators) apply to sections. For example we can write (a*b+) but not +(a+b*), because `*' is more binding than `+'. The latter example should +have been written ((a+b)*). As always when writing complicated +expressions, if there is any possibility of ambiguity it is better to +put in extra parentheses. + +_S_p_e_c_i_a_l_ _c_a_s_e + It is not possible to form a postsection in infix minus, because of a +conflict of meaning with unary minus. For example: + (-b) +is a parenthesised occurrence of negative b, not a section. As a way +round this there is a function `subtract' in the standard environment +with the definition:- subtract x y = y - x. This is a normal curried +function, so we can write (subtract b) to get the function that +subtracts b from things. + +Presections in infix minus, such as (a-), cause no ambiguity. There are +no problems with infix plus because Miranda does not have a unary plus +operator. + +_A_c_k_n_o_w_l_e_d_g_e_m_e_n_t: + The idea of sections is due to Richard Bird (of Oxford University +Programming Research Group) and David Wile (of USC Information Sciences +Institute). + diff --git a/miralib/manual/99 b/miralib/manual/99 new file mode 100755 index 0000000..1a8feb8 --- /dev/null +++ b/miralib/manual/99 @@ -0,0 +1,5 @@ +#! /bin/sh +echo a listing of the manual is being put in the file +echo "mira.man" in your home directory ... +echo +./printman > $HOME/mira.man diff --git a/miralib/manual/contents b/miralib/manual/contents new file mode 100644 index 0000000..42cbf25 --- /dev/null +++ b/miralib/manual/contents @@ -0,0 +1,22 @@ +_M_i_r_a_n_d_a_ _S_y_s_t_e_m_ _M_a_n_u_a_l _ _C_o_p_y_r_i_g_h_t_ _R_e_s_e_a_r_c_h_ _S_o_f_t_w_a_r_e_ _L_i_m_i_t_e_d_ _1_9_8_5_-_2_0_2_0 + + 1. How to use the manual system 20. Algebraic types + 2. About the name "Miranda" 21. Abstract types + 3. About this release 22. Empty types + 4. The Miranda command interpreter 23. The special function _s_h_o_w + 5. Brief summary of main commands 24. Formal syntax of Miranda scripts + 6. List of remaining commands 25. Comments on syntax + 7. Expressions 26. Miranda lexical syntax + 8. Operators 27. The library mechanism + 9. Operator sections 28. The standard environment +10. Identifiers 29. Literate scripts +11. Literals 30. Some hints on Miranda style +12. Tokenisation and layout 31. UNIX/Miranda system interface +13. Iterative expressions 32. -->> CHANGES <<-- +14. Scripts, overview 33. Copying +15. Definitions 34. Bug reports +16. Pattern matching +17. Compiler directives +18. Basic type structure 99. Create a printout of the manual +19. Type synonyms 100. An Overview of Miranda (paper) + diff --git a/miralib/manual/howtoprint b/miralib/manual/howtoprint new file mode 100644 index 0000000..c5e540c --- /dev/null +++ b/miralib/manual/howtoprint @@ -0,0 +1,4 @@ +To get a hard copy, say the following + lpr mira.man +or similar, as a UNIX command, from your home directory. + diff --git a/miralib/manual/permission b/miralib/manual/permission new file mode 100644 index 0000000..271052b --- /dev/null +++ b/miralib/manual/permission @@ -0,0 +1,6 @@ +/----------------------------------------------------------------------\ +| The Miranda System Manual is Copyright (c) Research Software | +| Limited, 1985-2019. It may be freely reproduced, with or without | +| changes, for use with the Miranda System but commercial publication | +| rights are reserved to the Copyright holder. | +\----------------------------------------------------------------------/ diff --git a/miralib/manual/printman b/miralib/manual/printman new file mode 100755 index 0000000..6786e7c --- /dev/null +++ b/miralib/manual/printman @@ -0,0 +1,42 @@ +#! /bin/sh +if test -f contents +then cat contents +else echo printman: no contents; exit +fi +if test -f ../.version +then read VERSION < ../.version +else VERSION=?? +fi +echo "printout of online manual pages for version $VERSION" +cat .epoch +echo +cat permission +echo +for i in ? ?? +do test "$i" = "99" && exit + echo :::::::::::::::::::::: + echo $i + echo :::::::::::::::::::::: + if test -d $i + then if test -f $i/contents + then cat $i/contents + else echo $i: no contents; break + fi + for j in $i/? + do echo :::::::::::::::::::::: + if test -d $j + then echo $j omitted #don't go into 3rd level + echo :::::::::::::::::::::: + else echo $j + echo :::::::::::::::::::::: + cat $j + fi + done + else cat $i + fi +done +echo :::::::::::::::::::::: +echo APPENDIX +echo :::::::::::::::::::::: +echo +cat 100 diff --git a/miralib/menudriver.csh b/miralib/menudriver.csh new file mode 100755 index 0000000..2aa89e7 --- /dev/null +++ b/miralib/menudriver.csh @@ -0,0 +1,104 @@ +#!/bin/csh -f +# menu driver - Copyright Research Software Ltd 1985, 2006 +# this version modified to ignore execute permissions of files + +# see below for explanation of these variables, which we +# set to defaults if not present in the user's environment + +if(! $?MENUVIEWER) set MENUVIEWER = cat #ALTERNATIVE: more +if(! $?VIEWER) then +# choose one of these by removing the '#' in column one + set VIEWER = 'less -EX' RETURNTOMENU = NO +# set VIEWER = less RETURNTOMENU = YES +# set VIEWER = 'more -d' RETURNTOMENU = NO +endif + +set sansnl n invalid last oldlasts noglob +set histchars = '@^' #neutralize '!' + +if("`echo -n`" == '') then #use flag -n to suppress newline, if working +set sansnl = '-n' +endif + +if("$1" != '') cd "$1" +set top = "`pwd`" +while( -f contents ) + if("$n" == '') then + clear + if("$invalid" != '') echo invalid option "$invalid" + set invalid = '' + $MENUVIEWER contents; + echo $sansnl ::please type selection number \(or q to quit\): + set line = "$<" + set n = `expr " $line" : ' *\([^ ]*\)'` + endif + if("$n" == '.' && "$last" != '') then + set n = $last; + else if("$n" == '+' && "$last" != '' && "$last" != '.') then + set n = `expr $last + 1` + else if("$n" == '-' && "$last" != '' && "$last" != '.') then + set n = `expr $last - 1` + endif + if("$n" != '') then + if(-d "$n") then + if(-f "$n/contents") then + cd "$n"; set oldlasts = "$n,$oldlasts" last = "." + else set invalid = "$n" + endif + set n = '' + else if(-f "$n") then + if("$n" == '99') then #special case, 99 is an executable + clear; "./$n" + else clear; + $VIEWER "$n" + if("$RETURNTOMENU" == 'YES') then + set last = $n n = '' + continue #next iteration of while-loop + endif + endif + echo $sansnl ::next selection \(return to go back to menu, q to quit\): + set last = $n line = "$<" + set n = `expr " $line" : ' *\([^ ]*\)'` + else if("$n" == 'q' || "$n" == '/q') then + exit + else if("$n" == '???') then # ??? interrogates display settings + echo " MENUVIEWER='$MENUVIEWER'" + echo " VIEWER='$VIEWER', RETURNTOMENU='$RETURNTOMENU'" + echo these can be changed by setting environment variables \ +of the same names + set n = '' + echo $sansnl '[Hit return to continue]' + set lose = "$<" + else if( "$n" =~ !* ) then + set line = `expr "$line" : ' *\(.*\)'` + set line = `expr "$line" : '\(.*[^ ]\) *'` + if( ".$line" == '.!!' || ".$line" == '.!' ) then + if(! $?lastbang) then + set invalid = "$n" n = ''; continue + else echo !"$lastbang" + endif + else set lastbang = `expr "$line" : '!\(.*\)'` + endif + $lastbang + echo $sansnl '[Hit return to continue]' + set n = '' + set lose = "$<" + else set invalid = "$n" n = '' + endif + else if("$oldlasts" == '') exit #we are at the root of the tree + cd .. + set last = `expr $oldlasts : '\([^,]*\)'` + set oldlasts = `expr $oldlasts : '[^,]*,\(.*\)'` + endif +end #of while-loop +exit +# Explanation of variables +# +# MENUVIEWER is the program used to display contents pages +# +# VIEWER is the program used to display individual sections +# +# RETURNTOMENU=YES prevents another prompt being given after displaying +# each section, causing instead an immediate return to contents page. It +# should be `YES' if VIEWER is a program that pauses for input at end of +# file, `NO' if VIEWER is a program that quits silently at end of file. diff --git a/miralib/menudriver.sh b/miralib/menudriver.sh new file mode 100755 index 0000000..81d4362 --- /dev/null +++ b/miralib/menudriver.sh @@ -0,0 +1,102 @@ +#! /bin/sh +# menu driver - Copyright Research Software Ltd 1985, 2006 +# this version modified to ignore execute permissions of files + +# see below for explanation of these variables, which we +# set to defaults if not present in the user's environment + +test "$MENUVIEWER" || MENUVIEWER=cat #ALTERNATIVE: more +if test ! "$VIEWER" +then +# choose one of these by removing the '#' in column one + VIEWER='less -EX'; RETURNTOMENU=NO +# VIEWER=less, RETURNTOMENU=YES +# VIEWER='more -d'; RETURNTOMENU=NO +fi + +if test -z "`echo -n`" #use flag -n to suppress newline, if working +then sansnl='-n' +fi + +cd "$1" +top="`pwd`" +while test -f contents +do + if test '' = "$n" + then echo [H[J #clear + test ."$invalid" = . || echo invalid option "$invalid" + invalid="" + $MENUVIEWER contents; + echo $sansnl ::please type selection number \(or q to quit\): + read n + fi + if test '.' = "$n" -a "$last" + then n=$last + elif test '+' = "$n" -a "$last" -a "$last" != . + then n=`expr $last + 1` + elif test '-' = "$n" -a "$last" -a "$last" != . + then n=`expr $last - 1` + fi + if test '' != "$n" + then if test -d "$n" + then if test -f "$n/contents" + then cd "$n"; oldlasts=$n:$oldlasts; last="."; + else invalid="$n"; fi + n="" + elif test -f "$n" + then if test '99' = "$n" #special case, 99 is an executable + then echo [H[J; "./$n" + else echo [H[J #clear + $VIEWER "$n" + if test "$RETURNTOMENU" = YES + then last=$n; n=""; continue #next iteration of while-loop + fi + fi + echo $sansnl ::next selection \(return to go back to menu, q to quit\): + last=$n; read n + elif test ."$n" = .q -o ."$n" = ./q + then exit + elif test '???' = "$n" # ??? interrogates display settings + then echo " MENUVIEWER='$MENUVIEWER'" + echo " VIEWER='$VIEWER', RETURNTOMENU='$RETURNTOMENU'" + echo these can be changed by setting environment variables \ +of the same names + n="" + echo $sansnl '[Hit return to continue]' + read lose + else case $n in + !*) if test ".$n" = '.!!' -o ".$n" = '.!' + then if test "$lastbang" = '' + then invalid="$n"; n=""; continue + else echo !"$lastbang" + fi + else lastbang=`expr "$n" : '!\(.*\)'` + fi + $lastbang + echo $sansnl '[Hit return to continue]' + n="" + read lose ;; + *) invalid="$n"; n="" ;; + esac + fi + else test "$oldlasts" || exit #we are at the root of the tree + cd .. + last=`expr $oldlasts : '\([^:]*\)'` + oldlasts=`expr $oldlasts : '[^:]*:\(.*\)'` + fi +done +exit +# Oct 2003 modified for Peter Bartke to overcome problem on UWIN +# no test -x, instead all files displayed except 99 which is executed +# May 2006 use echo $sansnl because echo -n not portable + +# Explanation of variables +# +# MENUVIEWER is the program used to display contents pages +# +# VIEWER is the program used to display individual sections +# +# RETURNTOMENU=YES prevents another prompt being given after displaying +# each section, causing instead an immediate return to contents page. It +# should be `YES' if VIEWER is a program that pauses for input at end of +# file, `NO' if VIEWER is a program that quits silently at end of file. diff --git a/miralib/prelude b/miralib/prelude new file mode 100644 index 0000000..f9fe7a7 --- /dev/null +++ b/miralib/prelude @@ -0,0 +1,110 @@ +||names defined in this file are not in scope for users - they are part +||of the internal mechanisms of the Miranda system. + +||the following three identifiers are "untypeable" and defined internally +||changetype::*->** ||primitive function, semantically equivalent to id +||first::*->** ||gets first element of a tuple +||rest::*->** ||gets rest of a tuple (i.e. without first component) + +||offside::[char] ||defined internally and used by indent, see below + + diagonalise :: [[*]]->[*] ||used by [//] comprehensions + diagonalise x = diag 1 x ||when nested does "cantorian" diagonalisation + diag n [] = [] + diag n x = map hd px++diag (#px+1)rest, otherwise + where + px = filter (~=[]) (take n x) + rest = map tl px ++ drop n x + listdiff::[*]->[*]->[*] ||listdiff defines the action of "--" + listdiff x [] = x + listdiff x (b:y) = listdiff (remove b x) y + remove b [] = [] + remove b (a:x) = x, if a=b + = a:remove b x, otherwise + showbool::bool->[char] + showbool True = "True" + showbool False = "False" +||shownum defined internally + base r x = "0", if x=0 ||base is used by charname + = f x, otherwise + where + f 0 = [] + f n = f(n div r) ++ [mkdigit(n mod r)] + mkdigit n = decode(n + code '0'), if n<10 + = decode(n - 10 + code 'a'), if 10<=n<36 + showchar::char->[char] + showchar x = "'" ++ charname x ++ "'" +||note - charname has the right conventions for showchar +||i.e. ' is escaped and " is not escaped - showstring inverts this + charname '\\' = "\\\\" + charname '\'' = "\\\'" + charname x = [x], if 32 <= code x < 127 \/ 160 <= code x < 256 + charname '\a' = "\\a" + charname '\b' = "\\b" + charname '\f' = "\\f" + charname '\n' = "\\n" + charname '\r' = "\\r" + charname '\t' = "\\t" + charname '\v' = "\\v" + charname x = "\\" ++ pad 3 (base 10 n), if n<1000 ||H=this case only & no pad + = "\\x" ++ pad 4 (base 16 n), if n<=0xffff + = "\\X" ++ pad 6 (base 16 n), otherwise + where + n = code x + pad w s = rep(w-#s)'0'++s + rep n x = [], if n<=0 + = x:rep (n-1) x, otherwise + showlist::(*->[char])->[*]->[char] + showlist f x = '[':rest + where + rest = "]", if x=[] + = f(hd x)++foldr g "]" (tl x), otherwise + g a s = ',':f a++s + showstring::[char]->[char] + showstring x = '"' : showstr x + showstr [] = "\"" + showstr ('"':x) = "\\\"" ++ showstr x + showstr (a:x) = s ++ showstr x ||for Haskell style padding use s1 here + where ||see also line marked H above + s = charname a +|| s1 = s ++ "\\&", if clash s x +|| = s, otherwise +|| clash ('\\':c:cs) (d:ds) = digit c & digit d +|| clash s x = False + digit c = '0' <= c <= '9' + shownum1::num->[char] + shownum1 n = "("++shownum n++")", if n<0 + = shownum n, otherwise + showparen::(*->[char])->*->[char] + showparen f x = "("++f x++")" + showpair::(*->[char])->(**->[char])->***->[char] + showpair f1 f2 tup = f1(first tup)++","++f2(rest tup) + showvoid::()->[char] + showvoid () = "()" + showfunction::(*->**)->[char] + showfunction x = "<function>" + showabstract::*->[char] + showabstract x = "<abstract ob>" + showwhat::*->[char] + showwhat x = error "undeclared show-function", if x=x +||the following function is used to implement the offside rule (under %bnf) + indent :: *->**->** || * is type of `col' function, ** is parser + outdent :: *->* || * is a parser + indent = changetype indent1 + outdent = changetype outdent1 + indent1 col f ((a,s):x) + = f ((a,s):cutoff col (col s) x), if a~=offside + indent1 col f x = f x + cutoff col n = g + where + g ((a,s):x) = (a,s):g x, if col s>=n + = (offside,s):(a,s):x, otherwise + g [] = [] + outdent1 f = reconstruct.f + reconstruct (m:x) = m:g x + where + g ((a,s):x) = x, if a=offside + g (t:x) = t:g x + g [] = [] + reconstruct fail = fail ||internal repn of failure is a non-CONS object +||offside is defined internally and differs from every string diff --git a/miralib/stdenv.m b/miralib/stdenv.m new file mode 100644 index 0000000..8c53ac8 --- /dev/null +++ b/miralib/stdenv.m @@ -0,0 +1,761 @@ +> ||The Miranda Standard Environment (C) Research Software Limited 1989 + +We give here, in alphabetical order, a brief explanation of all the +identifiers in the Miranda standard environment, each followed by its +definition (except in a few cases where the definition cannot +conveniently be given in Miranda). The lines marked with a `>' in +column one are formal program text, the other lines in the file are +comment. Note that a number of the functions given here are defined +internally (for speed) even though their definitions could have been +given in Miranda - in these cases the Miranda definition is given as a +comment. This is the standard environment of Miranda release two. + +Added October 2019 - showhex, showoct - see below. + +`abs' takes the absolute value of a number - e.g. abs (-3) is 3, abs 3.5 +is 3.5 + +> abs :: num->num +> abs x = -x, if x<0 +> = x, otherwise + +`and' applied to a list of truthvalues, takes their logical conjunction. + +> and :: [bool]->bool +> and = foldr (&) True + +`arctan' is the trigonometric function, inverse tangent. It returns a +result in the range -pi/2 to pi/2. See also `sin', `cos'. + +> arctan :: num->num ||defined internally + +`bool' is the type comprising the two truthvalues. + + bool ::= False | True ||primitive to Miranda + +`char' is the type comprising the Latin-1 character set (e.g. 'a', +'\n'). + + char :: type ||primitive to Miranda + +`cjustify' applied to a number and a string, centre justifies the string +in a field of the specified width. See also `ljustify', `rjustify', +`spaces'. + +> cjustify :: num->[char]->[char] +> cjustify n s = spaces lmargin++s++spaces rmargin +> where +> margin = n - # s +> lmargin = margin div 2 +> rmargin = margin - lmargin + +`code' applied to a character returns its code number. Example + code 'a' = 97. +See also `decode'. + +> code :: char->num ||defined internally + +`concat' applied to a list of lists, joins them all together into a +single list with `++'. E.g. + concat [[1,2],[],[3,4]] = [1,2,3,4]. + +> concat :: [[*]]->[*] +> concat = foldr (++) [] + +`const' is a combinator for creating constant-valued functions. E.g. +(const 3) is the function that always returns 3. + +> const :: *->**->* +> const x y = x + +`converse' is a combinator for inverting the order of arguments of a +two-argument function. + +> converse :: (*->**->***)->**->*->*** +> converse f a b = f b a + +`cos' is the trigonometric cosine function, argument in radians. + +> cos :: num->num ||defined internally + +`decode' applied to an integer returns the character with that code. + +> decode :: num->char ||defined internally + +`digit' is a predicate on characters. True if the character is a digit. +See also `letter'. + +> digit :: char->bool +> digit x = '0'<=x<='9' + +`drop' applied to a number and a list returns the list with that many +elements removed from the front. If the list has less than the required +number of elements, `drop' returns []. Example + drop 2 [1,2,3,4] = [3,4] +See also `take'. + +> drop :: num->[*]->[*] ||defined internally, as below + + drop (n+1) (a:x) = drop n x + drop n x = x, if integer n + = error "drop applied to fractional number", otherwise + +`dropwhile' applied to a predicate and a list, removes elements from the +front of the list while the predicate is satisfied. Example: + dropwhile digit "123gone" = "gone" +See also `takewhile'. + +> dropwhile :: (*->bool)->[*]->[*] +> dropwhile f [] = [] +> dropwhile f (a:x) = dropwhile f x, if f a +> = a:x, otherwise + +`e' is a transcendental number, the base of natural logarithms. + +> e :: num +> e = exp 1 + +`entier' when applied to a number returns its integer part, meaning the +largest integer not exceeding it. E.g. + entier 1.0 = 1 + entier 3.5 = 3 + entier (-3.5) = -4. +Notice that for Miranda the number `1' and the number `1.0' are +different values - for example they yield different results under the +`integer' test. However `1=1.0' is True, because of the automatic +conversion from integer to float. + +> entier :: num->num ||defined internally + +A useful fact about `entier', which relates it to the operators div and +mod, is that the following law holds for any integers a, b with b~=0 and +a/b within the range for which integers can be represented exactly as +fractional numbers + a div b = entier (a/b) + +`error' applied to a string creates an error value with the associated +message. Error values are all equivalent to the undefined value - any +attempt to access the value causes the program to terminate and print +the string as a diagnostic. + +> error :: [char]->* ||defined internally + +`exp' is the exponential function on real numbers. See also `log'. + +> exp :: num->num ||defined internally + +`filemode' applied to a string representing the pathname of a UNIX file, +returns a string of length four giving the access permissions of the +current process to the file. The permissions are encoded as (in this +order) "drwx", any permission not granted is replaced by a '-' +character. If there is no file at pathname p, filemode p returns the +empty string. Example + member (filemode f) 'w' +tests f for write permission. See also `getenv', `read', `system'. + +> filemode :: [char]->[char] ||defined internally + +`filestat' applied to a UNIX pathname returns three integers +((inode,device),mtime), where mtime is the time-last-modified of the +file, in seconds since 00.00h on 1 Jan 1970. The pair (inode,device) +identifies a file uniquely, regardless of the pathname used to reach it. +A non-existent file has inode & device (0,-1) and mtime 0. + +> filestat :: [char]->((num,num),num) ||defined internally + +`filter' applied to a predicate and a list, returns a list containing +only those elements that satisfy the predicate. Example + filter (>5) [3,7,2,8,1,17] = [7,8,17] + +> filter :: (*->bool)->[*]->[*] +> filter f x = [a | a<-x; f a] + +`foldl' folds up a list, using a given binary operator and a given start +value, in a left associative way. Example: + foldl op r [a,b,c] = (((r $op a) $op b) $op c) +But note that in order to run in constant space, foldl forces `op' to +evaluate its first parameter. See the definitions of `product', +`reverse', `sum' for examples of its use. See also `foldr'. + +> foldl :: (*->**->*)->*->[**]->* ||defined internally, as below + + foldl op r [] = r + foldl op r (a:x) = strict (foldl op) (op r a) x + where + strict f x = seq x (f x) + +WARNING - this definition of foldl differs from that in older versions +of Miranda. The one here is the same as that in Bird and Wadler (1988). +The old definition had the two args of `op' reversed. That is:- + old_foldl op r = new_foldl (converse op) r +the function `converse' has been added to the standard environment. + +`foldl1' folds left over non-empty lists. See the definitions of `max', +`min' for examples of its use. + +> foldl1 :: (*->*->*)->[*]->* ||defined internally, as below + + foldl1 op (a:x) = foldl op a x + foldl1 op [] = error "foldl1 applied to []" + +`foldr' folds up a list, using a given binary operator and a given start +value, in a right associative way. Example: + foldr op r [a,b,c] = a $op (b $op (c $op r)) +See the definitions of `and', `concat', `or', for examples of its use. + +> foldr :: (*->**->**)->**->[*]->** ||defined internally, as below + + foldr op r [] = r + foldr op r (a:x) = op a (foldr op r x) + +`foldr1' folds right over non-empty lists. + +> foldr1 :: (*->*->*)->[*]->* +> foldr1 op [a] = a +> foldr1 op (a:b:x) = op a (foldr1 op (b:x)) +> foldr1 op [] = error "foldr1 applied to []" + +`force' applied to any data structure, returns it, but forces a check +that every part of the structure is defined. Example + hd(force x) +returns the hd of x, but fully evaluates x first (so x must be finite). +See also `seq'. Notice in particular the idiom `seq (force a) b' which +returns `b' but only after fully evaluating `a'. + +> force :: *->* ||defined internally + +`fst' returns the first component of a pair. See also `snd'. + +> fst :: (*,**)->* +> fst (a,b) = a + +`getenv' looks up a string in the user's UNIX environment. Example + getenv "HOME" +returns the pathname of your home directory. [If you want to see what +else is in your UNIX environment, say `printenv' as a UNIX command.] + +> getenv :: [char]->[char] ||defined internally + +`hd' applied to a non empty list, returns its first element. It is an +error to apply `hd' to the empty list, []. See also `tl'. + +> hd :: [*]->* +> hd (a:x) = a +> hd [] = error "hd []" + +`hugenum' is the largest fractional number that can exist in this +implementation (should be around 1e308 for IEEE standard 64 bit floating +point). See also `tinynum'. + +> hugenum :: num ||defined internally + +`id' is the identity function - applied to any object it returns it. + +> id :: *->* +> id x = x + +`index' applied to a (finite or infinite) list, returns a list of its +legal subscript values, in ascending order. E.g. index "hippopotamus" +is [0,1,2,3,4,5,6,7,8,9,10,11]. + +> index :: [*]->[num] +> index x = f 0 x +> where +> f n [] = [] +> f n (a:x) = n:f(n+1)x + +`init' is dual to `tl', it returns a list without its last component. +Example + init [1,2,3,4] = [1,2,3]. +See also `last'. [Note, by the `dual' of a list processing function we +mean the function which does the same job in a world where all lists +have been reversed.] + +> init :: [*]->[*] +> init (a:x) = [], if x=[] +> = a:init x, otherwise +> init [] = error "init []" + +`integer' is a predicate on numbers. True if and only if the number is +not fractional. + +> integer :: num->bool ||defined internally + +`iterate' - iterate f x returns the infinite list [x, f x, f(f x), ... ] +Example: iterate (2*) 1 yields a list of the powers of 2. + +> iterate :: (*->*)->*->[*] +> iterate f x = [y | y<-x, f y ..] + +Note use of ", .." to generate an arbitrary sequence (see manual section +13/2). + +`last' applied to a non empty list returns its last element. This +function is the dual of `hd'. Note that for any non-empty list x + (init x ++ [last x]) = x + +> last :: [*]->* ||defined internally, as below + + last x = x!(#x-1) + +`lay' applied to a list of strings, joins them together after appending +a newline character to each string. Example + lay ["hello","world"] = "hello\nworld\n" +Used to format output thus, + lay(map show x) +as a top level expression, causes the elements of the list x to be +printed one per line. See also `layn', `lines'. + +> lay :: [[char]]->[char] +> lay [] = [] +> lay (a:x) = a++"\n"++lay x + +`layn' is similar to `lay', but produces output with numbered lines. + +> layn :: [[char]]->[char] +> layn x = f 1 x +> where +> f n [] = [] +> f n (a:x) = rjustify 4 (show n) ++") "++a++"\n"++f (n+1) x + +'letter' is a predicate on characters. True if the character is a +letter. + +> letter :: char->bool +> letter c = 'a'<=c<='z' \/ 'A'<=c<='Z' + +`limit' applied to a list of values, returns the first value which is +the same as its successor. Useful in testing for convergence. For +example the following Miranda expression computes the square root of 2 +by the Newton-Raphson method + limit [x | x<-2, 0.5*(x + 2/x).. ] + +> limit :: [*]->* +> limit (a:b:x) = a, if a=b +> = limit (b:x), otherwise +> limit other = error "incorrect use of limit" + +`lines' applied to a list of characters containing newlines, returns a +list of lists, by breaking the original into lines. The newline +characters are removed from the result. Example, `lines' applied to + "hello world\nit's me,\neric\n" +returns ["hello world","it's me","eric"]. Note that `lines' treats +newline as a terminator, not a separator (although it will tolerate a +missing '\n' on the last line). + +> lines :: [char]->[[char]] +> lines [] = [] +> lines (a:x) = []:lines x, if a='\n' +> = (a:x1):xrest, otherwise +> where +> (x1:xrest) = lines x, if x~=[] +> = []:[], otherwise +> ||this handles missing '\n' on last line + +Note that the inverse of `lines' is the function `lay', in that applying +`lay' to the output of `lines' will restore the original string (except +that a final newline will be added, if missing in the original string). + +`ljustify' applied to a number and a string, left justifies the string +in a field of the specified width. + +> ljustify :: num->[char]->[char] +> ljustify n s = s++spaces(n - # s) + +`log' applied to a number returns its natural logarithm (i.e. logarithm +to the base `e'). It is the inverse of the exponential function, `exp'. +See also log10. Note that the log functions use a different algorithm +when applied to integer arguments (rather than just converting to float +first) so it is possible to take log, or log10, of very large integers. + +> log :: num->num ||defined internally + +`log10' applied to a number returns its logarithm to the base 10. + +> log10 :: num->num ||defined internally + +`map' applied to a function and a list returns a copy of the list in +which the given function has been applied to every element. + +> map :: (*->**)->[*]->[**] +> map f x = [f a | a<-x] + +`map2' is similar to `map', but takes a function of two arguments, and +maps it along two argument lists. We could also define `map3', `map4' +etc., but they are much less often needed. + +> map2 :: (*->**->***)->[*]->[**]->[***] +> map2 f x y = [f a b | (a,b)<-zip2 x y] + +Note: the Bird and Wadler function `zipwith' is just an uncurried +version of `map2', that is `zipwith f (x,y)' means `map2 f x y'. + +`max' applied to a list returns the largest element under the built in +ordering of `>'. Examples + max [1,2,12,-6,5] = 12 + max "hippopotamus" = 'u' +See also `min', `sort'. + +> max :: [*]->* +> max = foldl1 max2 + +`max2' applied to two values of the same type returns the larger under +the built in ordering of '>'. See also `min2'. + +> max2 :: *->*->* +> max2 a b = a, if a>=b +> = b, otherwise + +`member' applied to a list and a value returns True or False as the +value is or not present in the list. + +> member :: [*]->*->bool +> member x a = or (map (=a) x) + +`merge' applied to two sorted lists merges them to produce a single +sorted result. Used to define `sort', see later. + +> merge :: [*]->[*]->[*] ||defined internally, as below + + 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 + +`min' applied to a list returns its least member under `<'. + +> min :: [*]->* +> min = foldl1 min2 + +`min2' applied to two values of the same type returns the smaller under +the built in ordering of '<'. + +> min2 :: *->*->* +> min2 a b = b, if a>b +> = a, otherwise + +`mkset' applied to a list returns a copy of the list from which any +duplicated elements have been removed. A list without duplications can +be used to represent a set, whence the name. Works even on infinite +list, but (beware) takes a time quadratic in the number of elements +processed. + +> mkset :: [*]->[*] +> mkset [] = [] +> mkset (a:x) = a:filter (~=a) (mkset x) + +`neg' is a function of one numeric argument, with the same action as the +unary `-' operator. + +> neg :: num->num +> neg x = -x + +`num' is the type comprising both integer and fractional numbers (such +as 42, -12.73e8). + + num :: type ||primitive to Miranda + +`numval' converts a numeric string to the corresponding number - accepts +optional leading "-" followed by integer or floating point number, using +same rules as the Miranda compiler. Strings containing inappropriate +characters cause an error (exception - leading white space is harmless). + +> numval :: [char]->num ||defined internally + +`or' applied to a list of truthvalues, takes their logical disjunction. + +> or :: [bool]->bool +> or = foldr (\/) False + +`pi' is the well known real number (the ratio of the circumference of a +circle to its diameter). + +> pi :: num +> pi = 4*arctan 1 + +`postfix' takes an element and a list and adds the element to the end of +the list. This is the dual of the prefix operator, `:'. + +> postfix :: *->[*]->[*] +> postfix a x = x ++ [a] + +`product' applied to list of numbers returns their product. See also +`sum'. + +> product :: [num]->num +> product = foldl (*) 1 + +`read' returns the contents of file with a given pathname. Provides an +interface to the UNIX filing system. If the file is empty `read' +returns [], but if the file does not exist, or lacks read permission, +`read' causes an error. See also `filemode', `getenv'. + +> read :: [char]->[char] ||defined internally + +`readb' reads a file as bytes - useful in a UTF-8 locale, where binary +data may contain illegal characters if read as text. (In a non UTF-8 +locale the results of read and readb do not differ.) See manual section +31/9 for more information. + +> readb :: [char]->[char] ||defined internally + +_r_e_a_d_v_a_l_s is a family of functions for reading a list of values from a +file. See manual section 31/3. + +`rep' applied to a number and a value, returns a list containing the +specified number of instances of the value. (The name is short for +`replicate'.) Example + rep 6 'o' = "oooooo" +See also `repeat'. + +> rep :: num->*->[*] +> rep n x = take n (repeat x) + +`repeat' applied to a value returns an infinite list, all of whose +elements are the given value. + +> repeat :: *->[*] +> repeat x = xs +> where xs = x:xs + +`reverse' applied to any finite list returns a list of the same elements +in reverse order. + +> reverse :: [*]->[*] +> reverse = foldl (converse(:)) [] + +`rjustify' applied to a number and a string, right justifies the string +in a field of the specified width. + +> rjustify :: num->[char]->[char] +> rjustify n s = spaces(n - # s)++s + +`scan op r' applies `foldl op r' to every initial segment of a list. +For example `scan (+) 0 x' computes running sums. + +> scan :: (*->**->*)->*->[**]->[*] +> scan op = g +> where +> g r = (r:). rest +> where +> rest [] = [] +> rest (a:x) = g (op r a) x + +There is another way to explain `scan', which makes it clearer why it is +useful. Let s0 be the initial state of an automaton, and +f::state->input->state, its state transition function - then `scan f s0' +is a function that takes a list of inputs for the automaton and returns +the resulting list of states, starting with s0. + +`seq' applied to two values, returns the second but checks that the +first value is not completely undefined. Sometimes needed, e.g. to +ensure correct synchronisation in interactive programs. + +> seq :: *->**->** ||defined internally + +_s_h_o_w is a keyword denoting a family of functions for converting values +of different types to their print representations. See manual section +23 for more details. + +`shownum' applied to a number returns as a string a standard print +representation for it. A special case of the operator `show'. Applied +to fractional numbers `shownum' gives 16 significant figures (less any +trailing zeros), using a format appropriate to the size of number. For +more detailed control over number format see `showfloat', `showscaled'. + +> shownum :: num->[char] ||defined internally, + +`showhex', `showoct' applied to an integer return its hexadecimal or +octal representation as a string. Note that showhex will also convert +floating point numbers to hexdecimal format as per the C 2011 standard. +Example + showhex pi => 0x1.921fb54442d18p+1 +the scale factor in p is a power of 2 (oddly, this part is in decimal). + +> showhex, showoct :: num->[char] ||defined internally + +`showfloat p x' returns as a string the number x printed in floating +point format, that is in the form "digits.digits", where the integer +p (>=0) gives the number of digits after the decimal point. + +> showfloat :: num->num->[char] ||defined internally, + +`showscaled p x' returns as a string the number x printed in scientific +format, that is in the form "n.nnnnnne[+/-]nn", where the integer p +(>=0) gives the number of digits required after the decimal point. + +> showscaled :: num->num->[char] ||defined internally, + +`sin' is the trigonometric sine function, argument in radians. + +> sin :: num->num ||defined internally + +`snd' returns the second component of a pair. + +> snd :: (*,**)->** +> snd (a,b) = b + +`sort' applied to any finite list sorts the elements of the list into +ascending order on the built in '<' relation. Note that you cannot sort +a list of functions. Example + sort "hippopotamus" = "ahimoopppstu" +The following definition uses merge-sort, which has n log n worst-case +behaviour. + +> sort :: [*]->[*] +> sort x = x, if n<=1 +> = merge (sort(take n2 x)) (sort(drop n2 x)), otherwise +> where +> n = # x +> n2 = n div 2 + +`spaces' applied to a number returns a list of that many spaces. + +> spaces :: num->[char] +> spaces n = rep n ' ' + +`sqrt' is the square root function on (integer or fractional) numbers. +The result is always fractional. + +> sqrt :: num->num ||defined internally + +`subtract' is a name for (converse) infix minus. Needed because you +cannot form postsections in `-'. (See manual page 9 on `sections'.) +Example + subtract 3 +is the function that subtracts 3. + +> subtract :: num->num->num +> subtract x y = y - x + +`sum' applied to list of numbers returns their sum. + +> sum :: [num]->num +> sum = foldl (+) 0 + +`sys_message' is an algebraic type containing a family of constructors +used to control output to UNIX files. See manual section 31/2 on Output +to UNIX files. The binary versions Stdoutb etc are used to write binary +data in a UTF-8 locale, see section 31/9 for more information. + +> sys_message ::= Stdout [char] | Stderr [char] | Tofile [char] [char] | +> Closefile [char] | Appendfile [char] | System [char] | +> Exit num | Stdoutb [char] | Tofileb [char] [char] | +> Appendfileb [char] + +`system' applied to a string causes the string to be executed as a UNIX +shell command (by `sh'). The result returned is a 3-tuple, comprising +the standard_output, error_output, and exit_status respectively, +resulting from the execution of the UNIX command. See manual section +31/1 on Input from UNIX files etc for more details. + +> system :: [char]->([char],[char],num) ||defined internally + +`take' applied to a number and a list returns the specified number of +elements from the front of the list. If the list has less than the +required number of elements, `take' returns as many as it can get. +Examples + take 2 [1,2,3,4] = [1,2] + take 7 "girls" = "girls" + +> take :: num->[*]->[*] ||defined internally, as below + + take (n+1) (a:x) = a:take n x + take n x = [], if integer n + = error "take applied to fractional number", otherwise + +`takewhile' applied to a predicate and a list, takes elements from the +front of the list while the predicate is satisfied. Example: + takewhile digit "123gone" = "123" + +> takewhile :: (*->bool)->[*]->[*] +> takewhile f [] = [] +> takewhile f (a:x) = a:takewhile f x, if f a +> = [], otherwise + +`tinynum' is the smallest positive fractional number that can be +distinguished from zero in this implementation (should be around 1e-324 +for IEEE standard 64 bit floating point). + +> tinynum :: num ||defined internally + +`tl' applied to a non empty list returns the list without its first +element. Example, tl "snow" is "now". + +> tl :: [*]->[*] +> tl (a:x) = x +> tl [] = error "tl []" + +`transpose' applied to a list of lists, returns their transpose (in the +sense of matrix transpose - rows and columns are interchanged). Example + transpose [[1,2,3],[4,5,6]] = [[1,4],[2,5],[3,6]] +The following definition is slightly more subtle than is at first sight +necessary, in order to deal correctly with `upper triangular' matrices. +Example + transpose [[1,2,3],[4,5],[6]] = [[1,4,6],[2,5],[3]] + +> transpose :: [[*]]->[[*]] +> transpose x = [], if x'=[] +> = map hd x':transpose(map tl x'), otherwise +> where +> x' = takewhile (~=[]) x + +It might be thought that this function belongs in a specialised library +of matrix handling functions, but it has been found useful as a general +purpose list processing function, whence its inclusion in the standard +environment. + +`undef' is a name for the completely undefined value. Any attempt +access it results in an error message. Note that `undef' belongs to +every type. + +> undef :: * +> undef = error "undefined" + +`until' applied to a predicate, a function and a value, returns the +result of applying the function to the value the smallest number of +times necessary to satisfy the predicate. Example + until (>1000) (2*) 1 = 1024 + +> until :: (*->bool)->(*->*)->*->* +> until f g x = x, if f x +> = until f g (g x), otherwise + +`zip2' applied to two lists returns a list of pairs, formed by tupling +together corresponding elements of the given lists. Example + zip2 [0..3] "type" = [(0,'t'),(1,'y'),(2,'p'),(3,'e')] +This function is often useful in list comprehensions, where it provides +an idiom for traversing two lists in parallel. For example the +following expression returns the scalar product of x and y (x,y::[num]) + sum [ a*b | (a,b) <- zip2 x y ] + +> zip2 :: [*]->[**]->[(*,**)] ||defined internally, as below + + zip2 (a:x) (b:y) = (a,b):zip2 x y + zip2 x y = [] + +Note that if the lists being zipped are of different lengths, the length +of the result is that of the shortest list (this holds for zip2 and all +the following zip functions). + +The function `zip3' is analogous but takes three lists and returns a +list of 3-tuples. Similarly for `zip4', `zip5', `zip6' - zip functions +above zip6 are not provided in the standard environment. + +> zip3 (a:x) (b:y) (c:z) = (a,b,c):zip3 x y z +> zip3 x y z = [] +> zip4 (a:w) (b:x) (c:y) (d:z) = (a,b,c,d):zip4 w x y z +> zip4 w x y z = [] +> zip5 (a:v) (b:w) (c:x) (d:y) (e:z) = (a,b,c,d,e):zip5 v w x y z +> zip5 v w x y z = [] +> zip6 (a:u)(b:v)(c:w)(d:x)(e:y)(f:z) = (a,b,c,d,e,f):zip6 u v w x y z +> zip6 u v w x y z = [] + +The following is included for compatibility with Bird and Wadler (1988). +The normal Miranda style is to use the curried form `zip2'. + +> zip :: ([*],[**])->[(*,**)] +> zip (x,y) = zip2 x y + +End of definitions of the standard environment + diff --git a/new/big.c b/new/big.c new file mode 100644 index 0000000..7a1cfe1 --- /dev/null +++ b/new/big.c @@ -0,0 +1,643 @@ +/* MIRANDA INTEGER PACKAGE */ +/* package for unbounded precision integers */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +#include <errno.h> + +static double logIBASE,log10IBASE; +word big_one; + +void bigsetup() +{ logIBASE=log((double)IBASE); + log10IBASE=log10((double)IBASE); + big_one=make(INT,1,0); +} + +word isnat(x) +word x; +{ return(tag[x]==INT&&poz(x)); +} + +word sto_word(i) /* store C long long as mira bigint */ +long long i; +{ word s,x; + if(i<0)s=SIGNBIT,i= -i; else s=0; + x=make(INT,s|i&MAXDIGIT,0); + if(i>>=DIGITWIDTH) + { word *p = &rest(x); + *p=make(INT,i&MAXDIGIT,0),p= &rest(*p); + while(i>>=DIGITWIDTH) + *p=make(INT,i&MAXDIGIT,0),p= &rest(*p); } + return(x); +} /* change to long long, DT Oct 2019 */ + +#define maxval (1ll<<60) + +long long get_word(x) /* mira bigint to C long long */ +word x; +{ long long n=digit0(x); + word sign=neg(x); + if(!(x=rest(x)))return(sign?-n:n); +{ word w=DIGITWIDTH; + while(x&&w<60)n+=(long long)digit(x)<<w,w+=DIGITWIDTH,x=rest(x); + if(x)n=maxval; /* overflow, return large value */ + return(sign?-n:n); +}} /* change to long long, DT Oct 2019 */ + +word bignegate(x) +word x; +{ if(bigzero(x))return(x); + return(make(INT,hd[x]&SIGNBIT?hd[x]&MAXDIGIT:SIGNBIT|hd[x],tl[x])); +} + +word bigplus(x,y) +word x,y; +{ if(poz(x)) + if(poz(y))return(big_plus(x,y,0)); + else return(big_sub(x,y)); + else + if(poz(y))return(big_sub(y,x)); + else return(big_plus(x,y,SIGNBIT)); /* both negative */ +} + +word big_plus(x,y,signbit) /* ignore input signs, treat x,y as positive */ +word x,y; word signbit; +{ word d=digit0(x)+digit0(y); + word carry = ((d&IBASE)!=0); + word r = make(INT,signbit|d&MAXDIGIT,0); /* result */ + word *z = &rest(r); /* pointer to rest of result */ + x = rest(x); y = rest(y); + while(x&&y) /* this loop has been unwrapped once, see above */ + { d = carry+digit(x)+digit(y); + carry = ((d&IBASE)!=0); + *z = make(INT,d&MAXDIGIT,0); + x = rest(x); y = rest(y); z = &rest(*z); } + if(y)x=y; /* by convention x is the longer one */ + while(x) + { d = carry+digit(x); + carry = ((d&IBASE)!=0); + *z = make(INT,d&MAXDIGIT,0); + x = rest(x); z = &rest(*z); } + if(carry)*z=make(INT,1,0); + return(r); +} + +word bigsub(x,y) +word x,y; +{ if(poz(x)) + if(poz(y))return(big_sub(x,y)); + else return(big_plus(x,y,0)); /* poz x, negative y */ + else + if(poz(y))return(big_plus(x,y,SIGNBIT)); /* negative x, poz y */ + else return(big_sub(y,x)); /* both negative */ +} + +word big_sub(x,y) /* ignore input signs, treat x,y as positive */ +word x,y; +{ word d = digit0(x)-digit0(y); + word borrow = (d&IBASE)!=0; + word r=make(INT,d&MAXDIGIT,0); /* result */ + word *z = &rest(r); + word *p=NULL; /* pointer to trailing zeros, if any */ + x = rest(x); y = rest(y); + while(x&&y) /* this loop has been unwrapped once, see above */ + { d = digit(x)-digit(y)-borrow; + borrow = (d&IBASE)!=0; + d = d&MAXDIGIT; + *z = make(INT,d,0); + if(d)p=NULL; else if(!p)p=z; + x = rest(x); y = rest(y); z = &rest(*z); } + while(y) /* at most one of these two loops will be invoked */ + { d = -digit(y)-borrow; + borrow = ((d&IBASE)!=0); + d = d&MAXDIGIT; + *z = make(INT,d,0); + if(d)p=NULL; else if(!p)p=z; + y = rest(y); z = &rest(*z); } + while(x) /* alternative loop */ + { d = digit(x)-borrow; + borrow = ((d&IBASE)!=0); + d = d&MAXDIGIT; + *z = make(INT,d,0); + if(d)p=NULL; else if(!p)p=z; + x = rest(x); z = &rest(*z); } + if(borrow) /* result is negative - take complement and add 1 */ + { p=NULL; + d = (digit(r)^MAXDIGIT) + 1; + borrow = ((d&IBASE)!=0); /* borrow now means `carry' (sorry) */ + digit(r) = SIGNBIT|d; /* set sign bit of result */ + z = &rest(r); + while(*z) + { d = (digit(*z)^MAXDIGIT)+borrow; + borrow = ((d&IBASE)!=0); + digit(*z) = d = d&MAXDIGIT; + if(d)p=NULL; else if(!p)p=z; + z = &rest(*z); } + } + if(p)*p=0; /* remove redundant (ie trailing) zeros */ + return(r); +} + +word bigcmp(x,y) /* returns +ve,0,-ve as x greater than, equal, less than y */ +word x,y; +{ word d,r,s=neg(x); + if(neg(y)!=s)return(s?-1:1); + r=digit0(x)-digit0(y); + for(;;) + { x=rest(x); y=rest(y); + if(!x)if(y)return(s?1:-1); + else return(s?-r:r); + if(!y)return(s?-1:1); + d=digit(x)-digit(y); + if(d)r=d; } +} + +word bigtimes(x,y) /* naive multiply - quadratic */ +word x,y; +{ if(len(x)<len(y)) + { word hold=x; x=y; y=hold; } /* important optimisation */ + word r=make(INT,0,0); + word d = digit0(y); + word s=neg(y); + word n=0; + if(bigzero(x))return(r); /* short cut */ + for(;;) + { if(d)r = bigplus(r,shift(n,stimes(x,d))); + n++; + y = rest(y); + if(!y) + return(s!=neg(x)?bignegate(r):r); + d=digit(y); } +} + + +word shift(n,x) /* multiply big x by n'th power of IBASE */ +word n,x; +{ while(n--)x=make(INT,0,x); + return(x); +} /* NB - we assume x non-zero, else unnormalised result */ + +word stimes(x,n) /* multiply big x (>=0) by digit n (>0) */ +word x,n; +{ unsigned d= n*digit0(x); /* ignore sign of x */ + word carry=d>>DIGITWIDTH; + word r = make(INT,d&MAXDIGIT,0); + word *y = &rest(r); + while(x=rest(x)) + d=n*digit(x)+carry, + *y=make(INT,d&MAXDIGIT,0), + y = &rest(*y), + carry=d>>DIGITWIDTH; + if(carry)*y=make(INT,carry,0); + return(r); +} + +word b_rem; /* contains remainder from last call to longdiv or shortdiv */ + +word bigdiv(x,y) /* may assume y~=0 */ +word x,y; +{ word s1,s2,q; + /* make x,y positive and remember signs */ + if(s1=neg(y))y=make(INT,digit0(y),rest(y)); + if(neg(x)) + x=make(INT,digit0(x),rest(x)),s2=!s1; + else s2=s1; + /* effect: s1 set iff y negative, s2 set iff signs mixed */ + if(rest(y))q=longdiv(x,y); + else q=shortdiv(x,digit(y)); + if(s2){ if(!bigzero(b_rem)) + { x=q; + while((digit(x)+=1)==IBASE) /* add 1 to q in situ */ + { digit(x)=0; + if(!rest(x)){ rest(x)=make(INT,1,0); break; } + else x=rest(x); + } + } + if(!bigzero(q))digit(q)=SIGNBIT|digit(q); + } + return(q); +} + +word bigmod(x,y) /* may assume y~=0 */ +word x,y; +{ word s1,s2; + /* make x,y positive and remember signs */ + if(s1=neg(y))y=make(INT,digit0(y),rest(y)); + if(neg(x)) + x=make(INT,digit0(x),rest(x)),s2=!s1; + else s2=s1; + /* effect: s1 set iff y negative, s2 set iff signs mixed */ + if(rest(y))longdiv(x,y); + else shortdiv(x,digit(y)); + if(s2){ if(!bigzero(b_rem)) + b_rem = bigsub(y,b_rem); + } + return(s1?bignegate(b_rem):b_rem); +} + +/* NB - above have entier based handling of signed cases (as Miranda) in + which remainder has sign of divisor. To get this:- if signs of + divi(sor/dend) mixed negate quotient and if remainder non-zero take + complement and add one to magnitude of quotient */ + +/* for alternative, truncate based handling of signed cases (usual in C):- + magnitudes invariant under change of sign, remainder has sign of + dividend, quotient negative if signs of divi(sor/dend) mixed */ + +word shortdiv(x,n) /* divide big x by single digit n returning big quotient + and setting external b_rem as side effect */ + /* may assume - x>=0,n>0 */ +word x,n; +{ word d=digit(x),s_rem,q=0; + while(x=rest(x)) /* reverse rest(x) into q */ + q=make(INT,d,q),d=digit(x); /* leaving most sig. digit in d */ + { word tmp; + x=q; s_rem=d%n; d=d/n; + if(d||!q)q=make(INT,d,0); /* put back first digit (if not leading 0) */ + else q=0; + while(x) /* in situ division of q by n AND destructive reversal */ + d=s_rem*IBASE+digit(x),digit(x)=d/n,s_rem=d%n, + tmp=x,x=rest(x),rest(tmp)=q,q=tmp; + } + b_rem=make(INT,s_rem,0); + return(q); +} + +word longdiv(x,y) /* divide big x by big y returning quotient, leaving + remainder in extern variable b_rem */ + /* may assume - x>=0,y>0 */ +word x,y; +{ word n,q,ly,y1,scale; + if(bigcmp(x,y)<0){ b_rem=x; return(make(INT,0,0)); } + y1=msd(y); + if((scale=IBASE/(y1+1))>1) /* rescale if necessary */ + x=stimes(x,scale),y=stimes(y,scale),y1=msd(y); + n=q=0;ly=len(y); + while(bigcmp(x,y=make(INT,0,y))>=0)n++; + y=rest(y); /* want largest y not exceeding x */ + ly += n; + for(;;) + { word d,lx=len(x); + if(lx<ly)d=0; else + if(lx==ly) + if(bigcmp(x,y)>=0)x=bigsub(x,y),d=1; + else d=0; + else{ d=ms2d(x)/y1; + if(d>MAXDIGIT)d=MAXDIGIT; + if((d -= 2)>0)x=bigsub(x,stimes(y,d)); + else d=0; + if(bigcmp(x,y)>=0) + { x=bigsub(x,y),d++; + if(bigcmp(x,y)>=0) + x=bigsub(x,y),d++; } + } + q = make(INT,d,q); + if(n-- ==0) + { b_rem = scale==1?x:shortdiv(x,scale); return(q); } + ly-- ; y = rest(y); } +} /* see Bird & Wadler p82 for explanation */ + +word len(x) /* no of digits in big x */ +word x; +{ word n=1; + while(x=rest(x))n++; + return(n); +} + +word msd(x) /* most significant digit of big x */ +word x; +{ while(rest(x))x=rest(x); + return(digit(x)); /* sign? */ +} + +word ms2d(x) /* most significant 2 digits of big x (len>=2) */ +word x; +{ word d=digit(x); + x=rest(x); + while(rest(x))d=digit(x),x=rest(x); + return(digit(x)*IBASE+d); +} + +word bigpow(x,y) /* assumes y poz */ +word x,y; +{ word d,r=make(INT,1,0); + while(rest(y)) /* this loop has been unwrapped once, see below */ + { word i=DIGITWIDTH; + d=digit(y); + while(i--) + { if(d&1)r=bigtimes(r,x); + x = bigtimes(x,x); + d >>= 1; } + y=rest(y); + } + d=digit(y); + if(d&1)r=bigtimes(r,x); + while(d>>=1) + { x = bigtimes(x,x); + if(d&1)r=bigtimes(r,x); } + return(r); +} + +double bigtodbl(x) +word x; +{ word s=neg(x); + double b=1.0, r=(double)digit0(x); + x = rest(x); + while(x)b=b*IBASE,r=r+b*digit(x),x=rest(x); + if(s)return(-r); + return(r); +} /* small end first */ +/* note: can return oo, -oo + but is used without surrounding sto_/set)dbl() only in compare() */ + +/* not currently used +long double bigtoldbl(x) +word x; +{ int s=neg(x); + long double b=1.0L, r=digit0(x); + x = rest(x); + while(x)b=b*IBASE,r=r+b*digit(x),x=rest(x); +/*printf("bigtoldbl returns %Le\n",s?-r:r); /* DEBUG + if(s)return(-r); + return(r); +} /* not compatible with std=c90, lib fns eg sqrtl broken */ + +word dbltobig(x) /* entier */ +double x; +{ word s= (x<0); + word r=make(INT,0,0); + word *p = &r; + double y= floor(x); +/*if(fabs(y-x+1.0)<1e-9)y += 1.0; /* trick due to Peter Bartke, see note */ + for(y=fabs(y);;) + { double n = fmod(y,(double)IBASE); + digit(*p) = (word)n; + y = (y-n)/(double)IBASE; + if(y>0.0)rest(*p)=make(INT,0,0),p=&rest(*p); + else break; + } + if(s)digit(r)=SIGNBIT|digit(r); + return(r); +} +/* produces junk in low order digits if x exceeds range in which integer + can be held without error as a double -- NO, see next comment */ +/* hugs, ghci, mira produce same integer for floor/entier hugenum, has 2^971 + as factor so the low order bits are NOT JUNK -- 9.1.12 */ + +/* note on suppressed fix: + choice of 1e9 arbitrary, chosen to prevent eg entier(100*0.29) = 28 + but has undesirable effects, causing eg entier 1.9999999999 = 2 + underlying problem is that computable floor on true Reals is _|_ at + the exact integers. There are inherent deficiences in 64 bit fp, + no point in trying to mask this */ + +double biglog(x) /* logarithm of big x */ +word x; +{ word n=0; + double r=digit(x); + if(neg(x)||bigzero(x))errno=EDOM,math_error("log"); + while(x=rest(x))n++,r=digit(x)+r/IBASE; + return(log(r)+n*logIBASE); +} + +double biglog10(x) /* logarithm of big x */ +word x; +{ word n=0; + double r=digit(x); + if(neg(x)||bigzero(x))errno=EDOM,math_error("log10"); + while(x=rest(x))n++,r=digit(x)+r/IBASE; + return(log10(r)+n*log10IBASE); +} + +word bigscan(p) /* read a big number (in decimal) */ + /* NB does NOT check for malformed number, assumes already done */ +char *p; /* p is a pointer to a null terminated string of digits */ +{ word s=0,r=make(INT,0,0); + if(*p=='-')s=1,p++; /* optional leading `-' (for NUMVAL) */ + while(*p) + { word d= *p-'0',f=10; + p++; + while(*p&&f<PTEN)d=10*d+*p-'0',f=10*f,p++; + /* rest of loop does r=f*r+d; (in situ) */ + d= f*digit(r)+d; + { word carry=d>>DIGITWIDTH; + word *x = &rest(r); + digit(r)=d&MAXDIGIT; + while(*x) + d=f*digit(*x)+carry, + digit(*x)=d&MAXDIGIT, + carry=d>>DIGITWIDTH, + x = &rest(*x); + if(carry)*x=make(INT,carry,0); + }} +/*if(*p=='e') + { int s=bigscan(p+1); + r = bigtimes(r,bigpow(make(INT,10,0),s); } */ + if(s&&!bigzero(r))digit(r)=digit(r)|SIGNBIT; + return(r); +} +/* code to handle (unsigned) exponent commented out */ + +word bigxscan(p,q) /* read unsigned hex number in '\0'-terminated string p to q */ + /* assumes redundant leading zeros removed */ +char *p, *q; +{ word r; /* will hold result */ + word *x = &r; + if(*p=='0'&&!p[1])return make(INT,0,0); + while(q>p) + { unsigned long long hold; + q = q-p<15 ? p : q-15; /* read upto 15 hex digits from small end */ + sscanf(q,"%llx",&hold); + *q = '\0'; + word count=4; /* 15 hex digits => 4 bignum digits */ + while(count-- && !(hold==0 && q==p)) + *x = make(INT,hold&MAXDIGIT,0), + hold >>= DIGITWIDTH, + x = &rest(*x); + } + return r; +} + +word bigoscan(p,q) /* read unsigned octal number in '\0'-terminated string p to q */ + /* assumes redundant leading zeros removed */ +char *p, *q; +{ word r; /* will hold result */ + word *x = &r; + while(q>p) + { unsigned word hold; + q = q-p<5 ? p : q-5; /* read (upto) 5 octal digits from small end */ + sscanf(q,"%o",&hold); + *q = '\0'; + *x = make(INT,hold,0), + x = &rest(*x); + } + return r; +} + +word digitval(c) +char c; +{ return isdigit(c)?c-'0': + isupper(c)?10+c-'A': + 10+c-'a'; } + +word strtobig(z,base) /* numeral (as Miranda string) to big number */ + /* does NOT check for malformed numeral, assumes + done and that z fully evaluated */ +word z; word base; +{ word s=0,r=make(INT,0,0),PBASE=PTEN; + if(base==16)PBASE=PSIXTEEN; else + if(base==8)PBASE=PEIGHT; + if(z!=NIL&&hd[z]=='-')s=1,z=tl[z]; /* optional leading `-' (for NUMVAL) */ + if(base!=10)z=tl[tl[z]]; /* remove "0x" or "0o" */ + while(z!=NIL) + { word d=digitval(hd[z]),f=base; + z=tl[z]; + while(z!=NIL&&f<PBASE)d=base*d+digitval(hd[z]),f=base*f,z=tl[z]; + /* rest of loop does r=f*r+d; (in situ) */ + d= f*digit(r)+d; + { word carry=d>>DIGITWIDTH; + word *x = &rest(r); + digit(r)=d&MAXDIGIT; + while(*x) + d=f*digit(*x)+carry, + digit(*x)=d&MAXDIGIT, + carry=d>>DIGITWIDTH, + x = &rest(*x); + if(carry)*x=make(INT,carry,0); + }} + if(s&&!bigzero(r))digit(r)=digit(r)|SIGNBIT; + return(r); +} + +extern char *dicp; + +word bigtostr(x) /* number to decimal string (as Miranda list) */ +word x; +{ word x1,sign,s=NIL; +#ifdef DEBUG + extern word debug; + if(debug&04) /* print octally */ + { word d=digit0(x); + sign=neg(x); + for(;;) + { word i=OCTW; + while(i--||d)s=cons('0'+(d&07),s),d >>= 3; + x=rest(x); + if(x)s=cons(' ',s),d=digit(x); + else return(sign?cons('-',s):s); } + } +#endif + if(rest(x)==0) + { extern char *dicp; + sprintf(dicp,"%d",getsmallint(x)); + return(str_conv(dicp)); } + sign=neg(x); + x1=make(INT,digit0(x),0); /* reverse x into x1 */ + while(x=rest(x))x1=make(INT,digit(x),x1); + x=x1; + for(;;) + { /* in situ division of (reversed order) x by PTEN */ + word d=digit(x),rem=d%PTEN; + d=d/PTEN; x1=rest(x); + if(d)digit(x)=d; + else x=x1; /* remove leading zero from result */ + while(x1) + d=rem*IBASE+digit(x1), + digit(x1)=d/PTEN, + rem=d%PTEN, + x1=rest(x1); + /* end of in situ division (also uses x1 as temporary) */ + if(x) + { word i=TENW; + while(i--)s=cons('0'+rem%10,s),rem=rem/10; } + else + { while(rem)s=cons('0'+rem%10,s),rem=rem/10; + return(sign?cons('-',s):s); } + } +} + +word bigtostrx(x) /* integer to hexadecimal string (as Miranda list) */ +word x; +{ word r=NIL, s=neg(x); + while(x) + { word count=4; /* 60 bits => 20 octal digits => 4 bignum digits */ + unsigned long long factor=1; + unsigned long long hold=0; + while(count-- && x) /* calculate value of (upto) 4 bignum digits */ + hold=hold+factor*digit0(x), + /* printf("::%llx\n",hold), /* DEBUG */ + factor<<=15, + x=rest(x); + sprintf(dicp,"%.15llx",hold); /* 15 hex digits = 60 bits */ + /* printf(":::%s\n",dicp); /* DEBUG */ + char *q=dicp+15; + while(--q>=dicp)r = cons(*q,r); + } + while(digit(r)=='0'&&rest(r)!=NIL)r=rest(r); /* remove redundant leading 0's */ + r = cons('0',cons('x',r)); + if(s)r = cons('-',r); + return(r); +} + +word bigtostr8(x) /* integer to octal string (as Miranda list) */ +word x; +{ word r=NIL, s=neg(x); + while(x) + { char *q = dicp+5; + sprintf(dicp,"%.5o",digit0(x)); + while(--q>=dicp)r = cons(*q,r); + x = rest(x); } + while(digit(r)=='0'&&rest(r)!=NIL)r=rest(r); /* remove redundant leading 0's */ + r = cons('0',cons('o',r)); + if(s)r = cons('-',r); + return(r); +} + +#ifdef DEBUG +wff(x) /* check for well-formation of integer */ +word x; +{ word y=x; + if(tag[x]!=INT)printf("BAD TAG %d\n",tag[x]); + if(neg(x)&&!digit0(x)&&!rest(x))printf("NEGATIVE ZERO!\n"); + if(digit0(x)&(~MAXDIGIT))printf("OVERSIZED DIGIT!\n"); + while(x=rest(x)) + if(tag[x]!=INT)printf("BAD INTERNAL TAG %d\n",tag[x]); else + if(digit(x)&(~MAXDIGIT)) + printf("OVERSIZED DIGIT!\n"); else + if(!digit(x)&&!rest(x)) + printf("TRAILING ZERO!\n"); + return(y); +} + +normalise(x) /* remove trailing zeros */ +word x; +{ if(rest(x))rest(x)=norm1(rest(x)); + return(wff(x)); +} + +norm1(x) +word x; +{ if(rest(x))rest(x)=norm1(rest(x)); + return(!digit(x)&&!rest(x)?0:x); +} + +#endif + +/* stall(s) +char *s; +{ fprintf(stderr,"big integer %s not yet implemented\n",s); + exit(0); +} + +#define destrev(x,y,z) while(x)z=x,x=rest(x),rest(z)=y,y=z; +/* destructively reverse x into y using z as temp */ + +/* END OF MIRANDA INTEGER PACKAGE */ + diff --git a/new/data.c b/new/data.c new file mode 100644 index 0000000..c7463ac --- /dev/null +++ b/new/data.c @@ -0,0 +1,1250 @@ +/* MIRANDA DATA REPRESENTATIONS */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +#define INITSPACE 250000 +word SPACE=INITSPACE; /* false ceiling in heap to improve paging behaviour + during compilation */ +extern word SPACELIMIT; /* see steer.c for default value */ + /* SPACELIMIT controls the size of the heap (i.e. the number of list + cells available) - the minimum survivable number given the need to + compile the prelude etc is probably about 6000 */ + /* Note: the size of a list cell is 2 ints + 1 char */ +#define BIGTOP (SPACELIMIT + ATOMLIMIT) +word listp=ATOMLIMIT-1; +word *hdspace,*tlspace; +long long cellcount=0; +long claims=0; +long nogcs=0; +extern word atgc; /* flag, set in steer.c */ +#define poschar(c) !(negchar((c)-1)) +#define negchar(c) (c&128) + /* safest to test for -ve chars this way, since not all m/c's do sign + extension - DT Jan 84 */ + +trueheapsize() +{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); } + +setupheap() +{ hdspace=(word *)malloc(SPACELIMIT*sizeof(word)); + tlspace=(word *)malloc(SPACELIMIT*sizeof(word)); + hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT; + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + tag=(char *)calloc(BIGTOP+1,sizeof(char)); + /* NB use calloc because it sets contents to zero */ + /* tag[TOP] must be zero and exists as a sentinel */ + if(hdspace==NULL||tlspace==NULL||tag==NULL)mallocfail("heap"); +} + +resetheap() /* warning - cannot do this dynamically, because both the + compiler and the reducer hold onto absolute heap addresses + during certain space consuming computations */ +{ if(SPACELIMIT<trueheapsize()) + fprintf(stderr,"impossible event in resetheap\n"),exit(1); + hdspace=(word *)realloc((char *)hdspace,SPACELIMIT*sizeof(word)); + if(hdspace==NULL)mallocfail("heap"); + tlspace=(word *)realloc((char *)tlspace,SPACELIMIT*sizeof(word)); + if(tlspace==NULL)mallocfail("heap"); + hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT; + tag=(char *)realloc(tag,BIGTOP+1); + if(tag==NULL)mallocfail("heap"); + tag[BIGTOP]=0; + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + if(SPACE<INITSPACE&&INITSPACE<=SPACELIMIT)SPACE=INITSPACE,tag[TOP]=0; + /* tag[TOP] is always zero and exists as a sentinel */ +} + +mallocfail(x) +char *x; +{ fprintf(stderr,"panic: cannot find enough free space for %s\n",x); + exit(1); +} + +resetgcstats() +{ cellcount= -claims; + nogcs = 0; + initclock(); +} + +make(t,x,y) /* creates a new cell with "tag" t, "hd" x and "tl" y */ +word t,x,y; +{ while(poschar(tag[++listp])); + /* find next cell with zero or negative tag (=unwanted) */ + if(listp==TOP) + { if(SPACE!=SPACELIMIT) + if(!compiling)SPACE=SPACELIMIT; else + if(claims<=SPACE/4&&nogcs>1) + { /* during compilation we raise false ceiling whenever residency + reaches 75% on 2 successive gc's */ + static word wait=0; + word sp=SPACE; + if(wait)wait--; else + SPACE+= SPACE/2,wait=2, + SPACE=5000*(1+(SPACE-1)/5000); /* round upwards */ + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + if(atgc&&SPACE>sp) + printf( "\n<<increase heap from %d to %d>>\n",sp,SPACE); + } + if(listp==TOP) + { +#if defined ORION105 + asm("savew6"); + gc(); + asm("restw6"); +#elif defined sparc + asm("ta 0x03"); /* see /usr/include/sun4/trap.h */ + /* asm("ta ST_FLUSH_WINDOWS"); */ + gc(); +#else + gc(); +#endif + if(t>STRCONS)mark(x); + if(t>=INT)mark(y); + return(make(t,x,y)); } + } + claims++; + tag[listp]= t; + hd[listp]= x; + tl[listp]= y; + return(listp); } + +/* cons ap ap2 ap3 are all #defined in terms of make + - see MIRANDA DECLARATIONS */ + +setwd(x,a,b) +word x,a,b; +{ hd[x]= a; + tl[x]= b; } + +word collecting=0; /* flag for reset(), in case interrupt strikes in gc */ + +gc() /* the "garbage collector" */ +{ char *p1; + extern word making; + collecting=1; + p1= &(tag[ATOMLIMIT]); + if(atgc) + printf("\n<<gc after %ld claims>>\n",claims); + if(claims<=SPACE/10 && nogcs>1 && SPACE==SPACELIMIT) + { /* if heap utilisation exceeds 90% on 2 successive gc's, give up */ + static word hnogcs=0; + if(nogcs==hnogcs) + { extern word ideep; + extern char *current_script; + fprintf(stderr,"<<not enough heap space -- task abandoned>>\n"); + if(!compiling)outstats(); + if(compiling&&ideep==0) + fprintf(stderr,"not enough heap to compile current script\n"), + fprintf(stderr,"script = \"%s\", heap = %d\n",current_script,SPACE); + exit(1); } /* if compiling should reset() instead - FIX LATER */ + else hnogcs=nogcs+1; } + nogcs++; + while(*p1= -*p1)p1++; /* make all tags -ve (= unwanted) */ +/*if(atgc) + { extern int lasthead; +#define BACKSTOP 020000000000 + printf("bases() called\n"); + printf("lasthead= "); + if(lasthead==BACKSTOP)printf("BACKSTOP"); + else out(stdout,lasthead); + putchar('\n'); } /* DEBUG */ + bases(); +/*if(atgc)printf("bases() done\n"); /* DEBUG */ + listp= ATOMLIMIT - 1; + cellcount+= claims; + claims= 0; + collecting=0; +} +/* int Icount; /* DEBUG */ + +gcpatch() /* called when gc interrupted - see reset in steer.c */ +/* must not allocate any cells between calling this and next gc() */ +{ char *p1; + for(p1= &(tag[ATOMLIMIT]);*p1;p1++)if(negchar(*p1))*p1= -*p1; + /* otherwise mutator crashes on funny tags */ +} + +bases() /* marks everthing that must be saved */ +{ word *p; + extern YYSTYPE yyval; + extern word *cstack; + extern word fileq,primenv; + extern word cook_stdin,common_stdin,common_stdinb,rv_expr,rv_script; + extern word margstack,vergstack,litstack,linostack,prefixstack; + extern word idsused,suppressids,lastname, + eprodnts,nonterminals,ntmap,ihlist,ntspecmap,gvars,lexvar; + extern word R,TABSTRS,SGC,ND,SBND,NT,current_id,meta_pending; + extern word showchain,newtyps,algshfns,errs,speclocs; + extern word SUBST[],tvmap,localtvmap; + extern word tfnum,tfbool,tfbool2,tfnum2,tfstrstr, + tfnumnum,ltchar,bnf_t,tstep,tstepuntil; + extern word exec_t,read_t,filestat_t; + extern word big_one; + extern word nill,standardout; + extern word lexstates,lexdefs,oldfiles,includees,embargoes,exportfiles, + exports,internals, freeids,tlost,detrop,rfl,bereaved,ld_stuff; + extern word CLASHES,ALIASES,SUPPRESSED,TSUPPRESSED,DETROP,MISSING,fnts,FBS; + extern word outfilq,waiting; + /* Icount=0; /* DEBUG */ + p= (word *)&p; +/* we follow everything on the C stack that looks like a pointer into +list space. This is failsafe in that the worst that can happen,if e.g. a +stray integer happens to point into list space, is that the garbage +collector will collect less garbage than it could have done */ + if(p<cstack) /* which way does stack grow? */ + while(++p!=cstack)mark(*p);/* for machines with stack growing downwards */ + else + while(--p!=cstack)mark(*p);/* for machines with stack growing upwards */ + mark(*cstack); +/* now follow all pointer-containing external variables */ + mark(outfilq); + mark(waiting); + if(compiling||rv_expr||rv_script) /* rv flags indicate `readvals' in use */ + { extern YYSTYPE *yyvs, *yyvsp; + extern word namebucket[]; + extern word *dstack,*stackp; /* undump stack - see load_script(), below */ + extern word *pnvec,nextpn,loading; /* private name vector */ + extern word make_status; + word i; + mark(make_status); + mark(primenv); + mark(fileq); + mark(idsused); + mark(eprodnts); + mark(nonterminals); + mark(ntmap); + mark(ihlist); + mark(ntspecmap); + mark(gvars); + mark(lexvar); + mark(common_stdin); + mark(common_stdinb); + mark(cook_stdin); + mark(margstack); + mark(vergstack); + mark(litstack); + mark(linostack); + mark(prefixstack); + mark(files); + mark(oldfiles); + mark(includees); + mark(freeids); + mark(exports); + mark(internals); + mark(CLASHES); + mark(ALIASES); + mark(SUPPRESSED); + mark(TSUPPRESSED); + mark(DETROP); + mark(MISSING); + mark(FBS); + mark(lexstates); + mark(lexdefs); + for(i=0;i<128;i++) + if(namebucket[i])mark(namebucket[i]); + for(p=dstack;p<stackp;p++)mark(*p); + if(loading) + { mark(algshfns); + mark(speclocs); + mark(exportfiles); + mark(embargoes); + mark(rfl); + mark(detrop); + mark(bereaved); + mark(ld_stuff); + mark(tlost); + for(i=0;i<nextpn;i++)mark(pnvec[i]); } + mark(lastname); + mark(suppressids); + mark(lastexp); + mark(nill); + mark(standardout); + mark(big_one); + mark(yyval); +/* for(vp= yyvs;vp<=yyvsp;vp++)mark(*vp); */ + mark(yylval); + mark(R); + mark(TABSTRS); + mark(SGC); + mark(ND); + mark(SBND); + mark(NT); + mark(current_id); + mark(meta_pending); + mark(newtyps); + mark(showchain); + mark(errs); + mark(tfnum); + mark(tfbool); + mark(tfbool2); + mark(tfnum2); + mark(tfstrstr); + mark(tfnumnum); + mark(ltchar); + mark(bnf_t); + mark(exec_t); + mark(read_t); + mark(filestat_t); + mark(tstep); + mark(tstepuntil); + mark(tvmap); + mark(localtvmap); + for(i=0;i<hashsize;i++)mark(SUBST[i]); } +/* if(atgc)printf("<<%d I-nodes>>\n",Icount); /* DEBUG */ +} + +#define tlptrbits 030000000000 +/* see reduce.c */ + +mark(x) /* a marked cell is distinguished by having a +ve "tag" */ +word x; +{ x&= ~tlptrbits; /* x may be a `reversed pointer' (see reduce.c) */ + while(isptr(x)&&negchar(tag[x])) + { /*if(hd[x]==I)Icount++; /* DEBUG */ + if((tag[x]= -tag[x])<INT)return; + if(tag[x]>STRCONS)mark(hd[x]); + x= tl[x]&~tlptrbits; } +} + +union numparts {double real; struct{word left;word right;} parts;}; + +double get_dbl(x) +word x; +{ union numparts r; + r.parts.left= hd[x]; + r.parts.right= tl[x]; + return(r.real); } + +/* Miranda's arithmetic model requires fp overflow trapped. On sparc this + can be done by setting a trap with ieee_handler (see steer.c) otherwise + we test for overflow with finite(), see IEEE754-1985 (Appendix) */ + +sto_dbl(R) +double R; +{ union numparts r; +#if !defined sparc /* */ + if(!finite(R))fpe_error(); /* see note on arithmetic model above */ +#endif /* */ + r.real=R; + return(make(DOUBLE,r.parts.left,r.parts.right)); +} + +setdbl(x,R) +double R; +{ union numparts r; +#if !defined sparc /* */ + if(!finite(R))fpe_error(); /* see note on arithmetic model above */ +#endif /* */ + r.real=R; + tag[x]=DOUBLE; hd[x]=r.parts.left; tl[x]=r.parts.right; +} + +sto_char(c) /* assumes 0<=c<=UMAX */ +word c; +{ return c<256?c:make(UNICODE,c,0); } + +get_char(x) +word x; +{ if(x<256)return x; + if(tag[x]==UNICODE)return hd[x]; + fprintf(stderr,"impossible event in get_char(x), tag[x]==%d\n",tag[x]); + exit(1); +} + +is_char(x) +word x; +{ return 0<=x && x<256 || tag[x]==UNICODE; } + +sto_id(p1) +char *p1; +{ return(make(ID,cons(strcons(p1,NIL),undef_t),UNDEF)); } + /* the hd of an ID contains cons(strcons(name,who),type) and + the tl has the value */ + /* who is NIL, hereinfo, or cons(aka,hereinfo) where aka + is of the form datapair(oldname,0) oldname being a string */ + /* hereinfo is fileinfo(script,line_no) */ + +/* hereafter is stuff for dumping and undumping compiled scripts + + (internal heap object) (external file rep - char sequence) + ---------------------- ----------------------------------- + 0..127 self + 128..383 CHAR_X (self-128) + 384..ATOMLIMIT-1 (self-256) + integer (-127..127) SHORT_X <byte> + integer INT_X <4n bytes> (-1) + double DBL_X <8 bytes> + unicode_char UNICODE_X <4 bytes> + typevar TVAR_X <byte> + ap(x,y) [x] [y] AP_X + cons(x,y) [y] [x] CONS_X + id (=occurrence) ID_X <string terminated by '\0'> + pname (=occurrence) PN_X <2 bytes> + PN1_X <4 bytes> + datapair(string,0) AKA_X <string...\0> + fileinfo(script,line_no) HERE_X <string...\0> <2 bytes> (**) + constructor(n,x) [x] CONSTRUCT_X <2 bytes> + readvals(h,t) [t] RV_X + definition [val] [type] [who] [id] DEF_X + [val] [pname] DEF_X + definition-list [definition*] DEF_X + filename <string terminated by '\0'> + mtime <4 bytes> + + complete script XVERSION + [ [filename] + [mtime] + [shareable] (=0 or 1) + [definition-list] ]+ + '\0' + [definition-list] (algshfns) + [ND] or [True] (see below) + DEF_X + [SGC] + DEF_X + [freeids] + DEF_X + [definition-list] (internals) + + type-error script XVERSION + '\1' + <4 bytes> (=errline) + ... (rest as normal script) + + syntax-error script XVERSION + `\0' + <4 bytes> (=errline) + [ [filename] + [mtime] ]+ + + Notes + ----- + first filename in dump must be that of `current_script' (ie the + main source file). All pathnames in dump are correct wrt the + directory of the main source. + (**) empty string is abbreviation for current filename in hereinfo + True in ND position indicates an otherwise correct dump whose exports + include type orphans + + Pending: + -------- + could have abbreviation for iterated ap and cons + + remaining issue - external format should be machine and version + independent - not clear how to do this +*/ + +#define XBASE ATOMLIMIT-256 +#define CHAR_X (XBASE) +#define SHORT_X (XBASE+1) +#define INT_X (XBASE+2) +#define DBL_X (XBASE+3) +#define ID_X (XBASE+4) +#define AKA_X (XBASE+5) +#define HERE_X (XBASE+6) +#define CONSTRUCT_X (XBASE+7) +#define RV_X (XBASE+8) +#define PN_X (XBASE+9) +#define PN1_X (XBASE+10) +#define DEF_X (XBASE+11) +#define AP_X (XBASE+12) +#define CONS_X (XBASE+13) +#define TVAR_X (XBASE+14) +#define UNICODE_X (XBASE+15) +#define XLIMIT (XBASE+16) +#if XLIMIT>512 +SEE ME!!! /* coding scheme breaks down if this occurs */ +#else + +static char prefix[pnlim]; +word preflen; + +setprefix(p) /* to that of pathname p */ +char *p; +{ char *g; + (void)strcpy(prefix,p); + g=rindex(prefix,'/'); + if(g)g[1]='\0'; + else *prefix='\0'; + preflen = strlen(prefix); +} /* before calling dump_script or load_script must setprefix() to that + of current pathname of file being dumped/loaded - to get correct + translation between internal pathnames (relative to dump script) + and external pathnames */ + +char *mkrel(p) /* makes pathname p correct relative to prefix */ +char *p; /* must use when writing pathnames to dump */ +{ if(strncmp(prefix,p,preflen)==0)return(p+preflen); + if(p[0]=='/')return(p); + fprintf(stderr,"impossible event in mkrelative\n"); /* or use getwd */ + /* not possible because all relative pathnames in files were computed + wrt current script */ + return(p); /* proforma only */ +} + +#define bits_15 0177777 +char *CFN; + +dump_script(files,f) /* write compiled script files to file f */ +word files; +FILE *f; +{ extern word ND,bereaved,errline,algshfns,internals,freeids,SGC; + putc(XVERSION,f); /* identifies dump format */ + if(files==NIL){ /* source contains syntax or metatype error */ + extern word oldfiles; + word x; + putc(0,f); + putw(errline,f); + for(x=oldfiles;x!=NIL;x=tl[x]) + fprintf(f,"%s",mkrel(get_fil(hd[x]))),putc(0,f), + /*filename*/ + putw(fil_time(hd[x]),f); /* mtime */ + return; } + if(ND!=NIL)putc(1,f),putw(errline,f); + for(;files!=NIL;files=tl[files]) + { fprintf(f,"%s",mkrel(CFN=get_fil(hd[files]))); /* filename */ + putc(0,f); + putw(fil_time(hd[files]),f); + putc(fil_share(hd[files]),f); + dump_defs(fil_defs(hd[files]),f); + } + putc(0,f); /* header - not a possible filename */ + dump_defs(algshfns,f); + if(ND==NIL&&bereaved!=NIL)dump_ob(True,f); /* special flag */ + else dump_ob(ND,f); + putc(DEF_X,f); + dump_ob(SGC,f); + putc(DEF_X,f); + dump_ob(freeids,f); + putc(DEF_X,f); + dump_defs(internals,f); +} + +dump_defs(defs,f) /* write list of defs to file f */ +word defs; +FILE *f; +{ while(defs!=NIL) + if(tag[hd[defs]]==STRCONS) /* pname */ + { word v=get_pn(hd[defs]); + dump_ob(pn_val(hd[defs]),f); + if(v>bits_15) + putc(PN1_X,f), + putw(v,f); + else + putc(PN_X,f), + putc(v&255,f), + putc(v >> 8,f); + putc(DEF_X,f); + defs=tl[defs]; } + else + { dump_ob(id_val(hd[defs]),f); + dump_ob(id_type(hd[defs]),f); + dump_ob(id_who(hd[defs]),f); + putc(ID_X,f); + fprintf(f,"%s",(char *)get_id(hd[defs])); + putc(0,f); + putc(DEF_X,f); + defs=tl[defs]; } + putc(DEF_X,f); /* delimiter */ +} + +dump_ob(x,f) /* write combinatory expression x to file f */ +word x; +FILE *f; +{ /* printob("dumping: ",x); /* DEBUG */ + switch(tag[x]) + { case ATOM: if(x<128)putc(x,f); else + if(x>=384)putc(x-256,f); else + putc(CHAR_X,f),putc(x-128,f); + return; + case TVAR: putc(TVAR_X,f), putc(gettvar(x),f); + if(gettvar(x)>255) + fprintf(stderr,"panic, tvar too large\n"); + return; + case INT: { /* 32 bit version (suppressed) + int d=get_int(x); + if(abs(d)<=127) + { putc(SHORT_X,f); putc(d,f); return; } + putc(INT_X,f); + putw(d,f); + /* variable length version */ + word d=digit(x); + if(rest(x)==0&&(d&MAXDIGIT)<=127) + { if(d&SIGNBIT)d= -(d&MAXDIGIT); + putc(SHORT_X,f); putc(d,f); return; } + putc(INT_X,f); + putw(d,f); + x=rest(x); + while(x) + putw(digit(x),f),x=rest(x); + putw(-1,f); + /* end of variable length version */ + return; } + /* 4 bytes per digit wasteful at current value of IBASE */ + case DOUBLE: putc(DBL_X,f); + putw(hd[x],f); + putw(tl[x],f); + return; + case UNICODE: putc(UNICODE_X,f); + putw(hd[x],f); + return; + case DATAPAIR: fprintf(f,"%c%s",AKA_X,(char *)hd[x]); + putc(0,f); + return; + case FILEINFO: { word line=tl[x]; + if((char *)hd[x]==CFN)putc(HERE_X,f); + else fprintf(f,"%c%s",HERE_X,mkrel(hd[x])); + putc(0,f); + putc(line&255,f); + putc((line >>= 8)&255,f); + if(line>255)fprintf(stderr, + "impossible line number %d in dump_ob\n",tl[x]); + return; } + case CONSTRUCTOR: dump_ob(tl[x],f); + putc(CONSTRUCT_X,f); + putc(hd[x]&255,f); + putc(hd[x]>>8,f); + return; + case STARTREADVALS: dump_ob(tl[x],f); + putc(RV_X,f); + return; + case ID: fprintf(f,"%c%s",ID_X,get_id(x)); + putc(0,f); + return; + case STRCONS: { word v=get_pn(x); /* private name */ + if(v>bits_15) + putc(PN1_X,f), + putw(v,f); + else + putc(PN_X,f), + putc(v&255,f), + putc(v >> 8,f); + return; } + case AP: dump_ob(hd[x],f); + dump_ob(tl[x],f); + putc(AP_X,f); + return; + case CONS: dump_ob(tl[x],f); + dump_ob(hd[x],f); + putc(CONS_X,f); + return; + default: fprintf(stderr,"impossible tag %d in dump_ob\n",tag[x]); + } +} + +#define ovflocheck if(dicq-dic>DICSPACE)dicovflo() +extern char *dic; extern word DICSPACE; + +word BAD_DUMP=0,CLASHES=NIL,ALIASES=NIL,PNBASE=0,SUPPRESSED=NIL, + TSUPPRESSED=NIL,TORPHANS=0; + +load_script(f,src,aliases,params,main) + /* loads a compiled script from file f for source src */ + /* main=1 if is being loaded as main script, 0 otherwise */ +FILE *f; +char *src; +word aliases,params,main; +{ extern word nextpn,ND,errline,algshfns,internals,freeids,includees,SGC; + extern char *dicp, *dicq; + word ch,files=NIL; + TORPHANS=BAD_DUMP=0; + CLASHES=NIL; + dsetup(); + setprefix(src); + if(getc(f)!=XVERSION){ BAD_DUMP= -1; return(NIL); } + if(aliases!=NIL) + { /* for each `old' install diversion to `new' */ + /* if alias is of form -old `new' is a pname */ + word a,hold; + ALIASES=aliases; + for(a=aliases;a!=NIL;a=tl[a]) + { word old=tl[hd[a]],new=hd[hd[a]]; + hold=cons(id_who(old),cons(id_type(old),id_val(old))); + id_type(old)=alias_t; + id_val(old)=new; + if(tag[new]==ID) + if((id_type(new)!=undef_t||id_val(new)!=UNDEF) + &&id_type(new)!=alias_t) + CLASHES=add1(new,CLASHES); + hd[hd[a]]=hold; + } + if(CLASHES!=NIL){ BAD_DUMP= -2; unscramble(aliases); return(NIL); } + for(a=aliases;a!=NIL;a=tl[a]) /* FIX1 */ + if(tag[ch=id_val(tl[hd[a]])]==ID) /* FIX1 */ + if(id_type(ch)!=alias_t) /* FIX1 */ + id_type(ch)=new_t; /* FIX1 */ + } + PNBASE=nextpn; /* base for relocation of internal names in dump */ + SUPPRESSED=NIL; /* list of `-id' aliases successfully obeyed */ + TSUPPRESSED=NIL; /* list of -typename aliases (illegal just now) */ + while((ch=getc(f))!=0&&ch!=EOF&&!BAD_DUMP) + { word s,holde=0; + dicq=dicp; + if(files==NIL&&ch==1) /* type error script */ + { holde=getw(f),ch=getc(f); + if(main)errline=holde; } + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ovflocheck; + ch=getw(f); /* mtime */ + s=getc(f); /* share bit */ + /*printf("loading: %s(%d)\n",dicp,ch); /* DEBUG */ + if(files==NIL) /* is this the right dump? */ + if(strcmp(dicp,src)) + { BAD_DUMP=1; + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + CFN=get_id(name()); /* wasteful way to share filename */ + files = cons(make_fil(CFN,ch,s,load_defs(f)), + files); + } +/* warning: load_defs side effects id's in namebuckets, cannot be undone by +unload until attached to global `files', so interrupts are disabled during +load_script - see steer.c */ /* for big dumps this may be too coarse - FIX */ + if(ch==EOF||BAD_DUMP){ if(!BAD_DUMP)BAD_DUMP=2; + if(aliases!=NIL)unscramble(aliases); + return(files); } + if(files==NIL){ /* dump of syntax error state */ + extern word oldfiles; + ch=getw(f); + if(main)errline=ch; + while((ch=getc(f))!=EOF) + { dicq=dicp; + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ovflocheck; + ch=getw(f); /* mtime */ + if(oldfiles==NIL) /* is this the right dump? */ + if(strcmp(dicp,src)) + { BAD_DUMP=1; + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + oldfiles = cons(make_fil(get_id(name()),ch,0,NIL), + oldfiles); + } + if(aliases!=NIL)unscramble(aliases); + return(NIL); } + algshfns=append1(algshfns,load_defs(f)); + ND=load_defs(f); + if(ND==True)ND=NIL,TORPHANS=1; + SGC=append1(SGC,load_defs(f)); + if(main||includees==NIL)freeids=load_defs(f); + else bindparams(load_defs(f),hdsort(params)); + if(aliases!=NIL)unscramble(aliases); + if(main)internals=load_defs(f); + return(reverse(files)); +}/* was it necessary to unscramble aliases before error returns? + check this later */ +/* actions labelled FIX1 were inserted to deal with the pathological case + that the destination of an alias (not part of a cyclic alias) has a direct + definition in the file and the aliasee is missing from the file + - this is both nameclash and missing aliasee, but without fix the two + errors cancel each other out and are unreported */ + +word DETROP=NIL,MISSING=NIL; + +bindparams(formal,actual) /* process bindings of free ids */ +/* formal is list of cons(id,cons(original_name,type)) */ +/* actual is list of cons(name,value) | ap(name,typevalue)) */ +/* both in alpha order of original name */ +word formal,actual; +{ extern word FBS; word badkind=NIL; + DETROP=MISSING=NIL; + FBS=cons(formal,FBS); + /* FBS is list of list of formals bound in current script */ + for(;;) + { word a; char *f; + while(formal!=NIL && (actual==NIL || + strcmp((f=(char *)hd[hd[tl[hd[formal]]]]),get_id(a=hd[hd[actual]]))<0)) + /* the_val(hd[hd[formal]])=findid((char *)hd[hd[tl[hd[formal]]]]), + above line picks up identifier of that name in current scope */ + MISSING=cons(hd[tl[hd[formal]]],MISSING), + formal=tl[formal]; + if(actual==NIL)break; + if(formal==NIL||strcmp(f,get_id(a)))DETROP=cons(a,DETROP); + else { word fa=tl[tl[hd[formal]]]==type_t?t_arity(hd[hd[formal]]):-1; + word ta=tag[hd[actual]]==AP?t_arity(hd[actual]):-1; + if(fa!=ta) + badkind=cons(cons(hd[hd[actual]],datapair(fa,ta)),badkind); + the_val(hd[hd[formal]])=tl[hd[actual]]; + formal=tl[formal]; } + actual=tl[actual]; + } +for(;badkind!=NIL;badkind=tl[badkind]) + DETROP=cons(hd[badkind],DETROP); +} + +unscramble(aliases) /* remove old to new diversions installed above */ +word aliases; +{ word a=NIL; + for(;aliases!=NIL;aliases=tl[aliases]) + { word old=tl[hd[aliases]],hold=hd[hd[aliases]]; + word new=id_val(old); + hd[hd[aliases]]=new; /* put back for missing check, see below */ + id_who(old)=hd[hold]; hold=tl[hold]; + id_type(old)=hd[hold]; + id_val(old)=tl[hold]; } + for(;ALIASES!=NIL;ALIASES=tl[ALIASES]) + { word new=hd[hd[ALIASES]]; + word old=tl[hd[ALIASES]]; + if(tag[new]!=ID) + { if(!member(SUPPRESSED,new))a=cons(old,a); + continue; } /* aka stuff irrelevant to pnames */ + if(id_type(new)==new_t)id_type(new)=undef_t; /* FIX1 */ + if(id_type(new)==undef_t)a=cons(old,a); else + if(!member(CLASHES,new)) + /* install aka info in new */ + if(tag[id_who(new)]!=CONS) + id_who(new)=cons(datapair(get_id(old),0),id_who(new)); } + ALIASES=a; /* transmits info about missing aliasees */ +} + +char *getaka(x) /* returns original name of x (as a string) */ +word x; +{ word y=id_who(x); + return(tag[y]!=CONS?get_id(x):(char *)hd[hd[y]]); +} + +get_here(x) /* here info for id x */ +word x; +{ word y=id_who(x); + return(tag[y]==CONS?tl[y]:y); +} + +word *dstack=0,*stackp,*dlim; +/* stackp=dstack; /* if load_script made interruptible, add to reset */ + +dsetup() +{ if(!dstack) + { dstack=(word *)malloc(1000*sizeof(word)); + if(dstack==NULL)mallocfail("dstack"); + dlim=dstack+1000; } + stackp=dstack; +} + +dgrow() +{ word *hold=dstack; + dstack=(word *)realloc(dstack,2*(dlim-dstack)*sizeof(word)); + if(dstack==NULL)mallocfail("dstack"); + dlim=dstack+2*(dlim-hold); + stackp += dstack-hold; + /*printf("dsize=%d\n",dlim-dstack); /* DEBUG */ +} + +load_defs(f) /* load a sequence of definitions from file f, terminated + by DEF_X, or a single object terminated by DEF_X */ +FILE *f; +{ extern char *dicp, *dicq; + extern word *pnvec,common_stdin,common_stdinb,nextpn,rv_script; + word ch,defs=NIL; + while((ch=getc(f))!=EOF) + { if(stackp==dlim)dgrow(); + switch(ch) + { case CHAR_X: *stackp++ = getc(f)+128; + continue; + case TVAR_X: *stackp++ = mktvar(getc(f)); + continue; + case SHORT_X: ch = getc(f); + if(ch&128)ch= ch|(~127); /*force a sign extension*/ + *stackp++ = stosmallint(ch); + continue; + case INT_X: { word *x; + ch = getw(f); + *stackp++ = make(INT,ch,0); + /* for 32 bit version suppress to end of varpart */ + x = &rest(stackp[-1]); + ch = getw(f); + while(ch!= -1) + *x=make(INT,ch,0),ch=getw(f),x= &rest(*x); + /* end of variable length part */ + continue; } + case DBL_X: ch=getw(f); + *stackp++ = make(DOUBLE,ch,getw(f)); + continue; + case UNICODE_X: *stackp++ = make(UNICODE,getw(f),0); + continue; + case PN_X: ch = getc(f); + ch = PNBASE+(ch|(getc(f)<<8)); + *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch); + /* efficiency hack for *stackp++ = sto_pn(ch); */ + continue; + case PN1_X: ch=PNBASE+getw(f); + *stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch); + /* efficiency hack for *stackp++ = sto_pn(ch); */ + continue; + case CONSTRUCT_X: ch = getc(f); + ch = ch|(getc(f)<<8); + stackp[-1] = constructor(ch,stackp[-1]); + continue; + case RV_X: stackp[-1] = readvals(0,stackp[-1]); + rv_script=1; + continue; + case ID_X: dicq=dicp; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + *stackp++=name(); /* see lex.c */ + if(id_type(stackp[-1])==new_t) /* FIX1 (& next 2 lines) */ + CLASHES=add1(stackp[-1],CLASHES),stackp[-1]=NIL; + else + if(id_type(stackp[-1])==alias_t) /* follow alias */ + stackp[-1]=id_val(stackp[-1]); + continue; + case AKA_X: dicq=dicp; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + *stackp++=datapair(get_id(name()),0); + /* wasteful, to share string */ + continue; + case HERE_X: dicq=dicp; + ch=getc(f); + if(!ch){ /* coding hack, 0 means current file name */ + ch = getc(f); + ch = ch|getc(f)<<8; + *stackp++ = fileinfo(CFN,ch); + continue; } + /* next line locates wrt current posn */ + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); + ovflocheck; + ch = getc(f); + ch = ch|getc(f)<<8; + *stackp++ = fileinfo(get_id(name()),ch); /* wasteful */ + continue; + case DEF_X: switch(stackp-dstack){ + case 0: /* defs delimiter */ + { /*printlist("contents: ",defs); /* DEBUG */ + return(reverse(defs)); } + case 1: /* ob delimiter */ + { return(*--stackp); } + case 2: /* pname defn */ + { ch = *--stackp; + pn_val(ch)= *--stackp; + defs=cons(ch,defs); /* NB defs now includes pnames */ + continue; } + case 4: + if(tag[stackp[-1]]!=ID) + if(stackp[-1]==NIL){ stackp -= 4; continue; } /* FIX1 */ + else { /* id aliased to pname */ + word akap; + ch= *--stackp; + SUPPRESSED=cons(ch,SUPPRESSED); + stackp--; /* who */ + akap= tag[*stackp]==CONS?hd[*stackp]:NIL; + stackp--; /* lose type */ + pn_val(ch)= *--stackp; + if(stackp[1]==type_t&&t_class(ch)!=synonym_t) + /* suppressed typename */ + { word a=ALIASES; /* reverse assoc in ALIASES */ + while(a!=NIL&&id_val(tl[hd[a]])!=ch) + a=tl[a]; + if(a!=NIL) /* surely must hold ?? */ + TSUPPRESSED=cons(tl[hd[a]],TSUPPRESSED); + /*if(akap==NIL) + akap=datapair(get_id(tl[hd[a]]),0); */ + /*if(t_class(ch)==algebraic_t) + CSUPPRESS=append1(CSUPPRESS,t_info(ch)); + t_info(ch)= cons(akap,fileinfo(CFN,0)); + /* assists identifn of dangling typerefs + see privatise() in steer.c */ }else + if(pn_val(ch)==UNDEF) + { /* special kludge for undefined names */ + /* necessary only if we allow names specified + but not defined to be %included */ + if(akap==NIL) /* reverse assoc in ALIASES */ + { word a=ALIASES; + while(a!=NIL&&id_val(tl[hd[a]])!=ch) + a=tl[a]; + if(a!=NIL) + akap=datapair(get_id(tl[hd[a]]),0); } + pn_val(ch)= ap(akap,fileinfo(CFN,0)); + /* this will generate sensible error message + see reduction rule for DATAPAIR */ + } + defs=cons(ch,defs); + continue; } + if( + id_type(stackp[-1])!=new_t&& /* FIX1 */ + (id_type(stackp[-1])!=undef_t|| + id_val(stackp[-1])!=UNDEF)) /* nameclash */ + { if(id_type(stackp[-1])==alias_t) /* cyclic aliasing */ + { word a=ALIASES; + while(a!=NIL&&tl[hd[a]]!=stackp[-1])a=tl[a]; + if(a==NIL) + { fprintf(stderr, + "impossible event in cyclic alias (%s)\n", + get_id(stackp[-1])); + stackp-=4; + continue; } + defs=cons(*--stackp,defs); + hd[hd[hd[a]]]= *--stackp; /* who */ + hd[tl[hd[hd[a]]]]= *--stackp; /* type */ + tl[tl[hd[hd[a]]]]= *--stackp; /* value */ + continue; } + /*if(strcmp(CFN,hd[get_here(stackp[-1])])) + /* EXPT (ignore clash if from same original file) */ + CLASHES=add1(stackp[-1],CLASHES); + stackp-=4; } + else + defs=cons(*--stackp,defs), + /*printf("%s undumped\n",get_id(hd[defs])), /* DEBUG */ + id_who(hd[defs])= *--stackp, + id_type(hd[defs])= *--stackp, + id_val(hd[defs])= *--stackp; + continue; + default: + { /* printf("badly formed def in dump\n"); /* DEBUG */ + BAD_DUMP=3; return(defs); } /* should unsetids */ + } /* of switch */ + case AP_X: ch = *--stackp; + if(stackp[-1]==READ&&ch==0)stackp[-1] = common_stdin; else + if(stackp[-1]==READBIN&&ch==0)stackp[-1] = common_stdinb; else + stackp[-1] = ap(stackp[-1],ch); + continue; + case CONS_X: ch = *--stackp; + stackp[-1] = cons(ch,stackp[-1]); + continue; + default: *stackp++ = ch>127?ch+256:ch; + }} + BAD_DUMP=4; /* should unsetids */ + return(defs); +} + +extern char *obsuffix; + +okdump(t) /* return 1 if script t has a non-syntax-error dump */ +char *t; +{ char obf[120]; + FILE *f; + (void)strcpy(obf,t); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + f=fopen(obf,"r"); + if(f&&getc(f)==XVERSION&&getc(f)){fclose(f); return(1); } + return(0); +} + +geterrlin(t) /* returns errline from dump of t if relevant, 0 otherwise */ +char *t; +{ char obf[120]; + extern char *dicp,*dicq; + word ch,el; + FILE *f; + (void)strcpy(obf,t); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + if(!(f=fopen(obf,"r")))return(0); + if(getc(f)!=XVERSION||(ch=getc(f))&&ch!=1){ fclose(f); + return(0); } + el=getw(f); + /* now check this is right dump */ + setprefix(t); + ch=getc(f); + dicq=dicp; + if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen; + /* locate wrt current posn */ + *dicq++ = ch; + while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */ + ch=getw(f); /* mtime */ + if(strcmp(dicp,t)||ch!=fm_time(t))return(0); /* wrong dump */ + /* this test not foolproof, strictly should extract all files and check + their mtimes, as in undump, but this involves reading the whole dump */ + return(el); +} + +hdsort(x) /* sorts list of name-value pairs on name */ +word x; +{ word a=NIL,b=NIL,hold=NIL; + if(x==NIL)return(NIL); + if(tl[x]==NIL)return(x); + while(x!=NIL) /* split x */ + { hold=a,a=cons(hd[x],b),b=hold; + x=tl[x]; } + a=hdsort(a),b=hdsort(b); + /* now merge two halves back together */ + while(a!=NIL&&b!=NIL) + if(strcmp(get_id(hd[hd[a]]),get_id(hd[hd[b]]))<0)x=cons(hd[a],x),a=tl[a]; + else x=cons(hd[b],x),b=tl[b]; + if(a==NIL)a=b; + while(a!=NIL)x=cons(hd[a],x),a=tl[a]; + return(reverse(x)); +} +#endif + +append1(x,y) /* rude append */ +word x,y; +{ word x1=x; + if(x1==NIL)return(y); + while(tl[x1]!=NIL)x1=tl[x1]; + tl[x1]=y; + return(x); +} + +/* following is stuff for printing heap objects in readable form - used + for miscellaneous diagnostics etc - main function is out(FILE *,object) */ + +/* charname returns the printable name of a character, as a string (using + C conventions for control characters */ /* DAT 13/9/83 */ +/* NB we use DECIMAL (not octal) for miscellaneous unprintables */ + +/* WARNING - you should take a copy of the name if you intend to do anything + with it other than print it immediately */ + +char *charname(c) +word c; +{ static char s[5]; + switch(c) + { case '\n': return("\\n"); + case '\t': return("\\t"); + case '\b': return("\\b"); + case '\f': return("\\f"); /* form feed */ + case '\r': return("\\r"); /* carriage return */ + case '\\': return("\\\\"); + case '\'': return("\\'"); + case '"': return("\\\""); + /* we escape all quotes for safety, since the context could be either + character or string quotation */ + default: if(c<32||c>126) /* miscellaneous unprintables -- convert to decimal */ + sprintf(s,"\\%d",c); + else s[0]=c,s[1]='\0'; + return(s); + } +} + +out(f,x) +/* the routines "out","out1","out2" are for printing compiled expressions */ +FILE *f; +word x; +{ +#ifdef DEBUG + static pending=NIL; /* cycle trap */ + word oldpending=pending; /* cycle trap */ +#endif + if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; } +#ifdef DEBUG + if(member(pending,x)){ fprintf(f,"..."); return; } /* cycle trap */ + pending=cons(x,pending); /* cycle trap */ +#endif + if(tag[x]==LAMBDA) + { fprintf(f,"$(");out(f,hd[x]);putc(')',f); + out(f,tl[x]); } else + { while(tag[x]==CONS) + { out1(f,hd[x]); + putc(':',f); + x= tl[x]; +#ifdef DEBUG + if(member(pending,x))break; /* cycle trap */ + pending=cons(x,pending); /* cycle trap */ +#endif + } + out1(f,x); } +#ifdef DEBUG + pending=oldpending; /* cycle trap */ +#endif +} /* warning - cycle trap not interrupt safe if `out' used in compiling + process */ + +out1(f,x) +FILE *f; +word x; +{ if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; } + if(tag[x]==AP) + { out1(f,hd[x]); + putc(' ',f); + out2(f,tl[x]); } + else out2(f,x); } + +out2(f,x) +FILE *f; +word x; +{ extern char *yysterm[], *cmbnms[]; + if(x<0||x>TOP){ fprintf(f,"<%d>",x); return; } + if(tag[x]==INT) + { if(rest(x)) + { x=bigtostr(x); + while(x)putc(hd[x],f),x=tl[x]; } + else fprintf(f,"%d",getsmallint(x)); + return; } + if(tag[x]==DOUBLE){ outr(f,get_dbl(x)); return; } + if(tag[x]==ID){ fprintf(f,"%s",get_id(x)); return; } + if(x<256){ fprintf(f,"\'%s\'",charname(x)); return; } + if(tag[x]==UNICODE){ fprintf(f,"'\%x'",hd[x]); return; } + if(tag[x]==ATOM) + { fprintf(f,"%s",x<CMBASE?yysterm[x-256]: + x==True?"True": + x==False?"False": + x==NIL?"[]": + x==NILS?"\"\"": + cmbnms[x-CMBASE]); + return; } + if(tag[x]==TCONS||tag[x]==PAIR) + { fprintf(f,"("); + while(tag[x]==TCONS) + out(f,hd[x]), putc(',',f), x=tl[x]; + out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==TRIES) + { fprintf(f,"TRIES("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==LABEL) + { fprintf(f,"LABEL("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==SHOW) + { fprintf(f,"SHOW("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==STARTREADVALS) + { fprintf(f,"READVALS("); out(f,hd[x]); putc(',',f); out(f,tl[x]); + putc(')',f); return; } + if(tag[x]==LET) + { fprintf(f,"(LET "); + out(f,dlhs(hd[x])),fprintf(f,"="); + out(f,dval(hd[x])),fprintf(f,";IN "); + out(f,tl[x]); + fprintf(f,")"); return; } + if(tag[x]==LETREC) + { word body=tl[x]; + fprintf(f,"(LETREC "); + x=hd[x]; + while(x!=NIL)out(f,dlhs(hd[x])),fprintf(f,"="), + out(f,dval(hd[x])),fprintf(f,";"),x=tl[x]; + fprintf(f,"IN "); + out(f,body); + fprintf(f,")"); return; } + if(tag[x]==DATAPAIR) + { fprintf(f,"DATAPAIR(%s,%d)",(char *)hd[x],tl[x]); + return; } + if(tag[x]==FILEINFO) + { fprintf(f,"FILEINFO(%s,%d)",(char *)hd[x],tl[x]); + return; } + if(tag[x]==CONSTRUCTOR) + { fprintf(f,"CONSTRUCTOR(%d)",hd[x]); + return; } + if(tag[x]==STRCONS) + { fprintf(f,"<$%d>",hd[x]); return; }/* used as private id's, inter alia*/ + if(tag[x]==SHARE) + { fprintf(f,"(SHARE:"); out(f,hd[x]); fprintf(f,")"); return; } + if(tag[x]!=CONS&&tag[x]!=AP&&tag[x]!=LAMBDA) + /* not a recognised structure */ + { fprintf(f,"<%d|tag=%d>",x,tag[x]); return; } + putc('(',f); + out(f,x); + putc(')',f); } + +outr(f,r) /* prints a number */ +FILE *f; +double r; +{ double p; + p= r<0?-r: r; + if(p>=1000.0||p<=.001)fprintf(f,"%e",r); + else fprintf(f,"%f",r); } + +/* end of MIRANDA DATA REPRESENTATIONS */ + diff --git a/new/lex.c b/new/lex.c new file mode 100644 index 0000000..a4e9d09 --- /dev/null +++ b/new/lex.c @@ -0,0 +1,1213 @@ +/* MIRANDA LEX ANALYSER */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "lex.h" +#include <errno.h> + +extern word DICSPACE; /* see steer.c for default value */ +/* capacity in chars of dictionary space for storing identifiers and file names + to get a larger name space just increase this number */ +extern FILE *s_in; +extern word echoing,listing,verbosity,magic,inbnf,inlex; +word fileq=NIL; /* list of currently open-for-input files, of form + cons(strcons(stream,<ptr to element of 'files'>),...)*/ +word insertdepth= -1,margstack=NIL,col=0,lmargin=0; +word echostack=NIL; +word lverge=0,vergstack=NIL; +char *prefixbase; /* stores prefixes for pathnames, to get static resolution */ +word prefixlimit=1024; /* initial size of space for prefixes */ +word prefix,prefixstack=NIL; /* current prefix, stack of old prefixes */ +word atnl=1,line_no=0; +word lastline; +word litstack=NIL,linostack=NIL; +word c=' ', lastc; +word commandmode; +word common_stdin,common_stdinb,cook_stdin; +word litmain=0,literate=0; /* flags "literate" comment convention */ +char *dic,*dicp,*dicq; +char *pathname(); + +setupdic() +{ dicp=dicq=dic=malloc(DICSPACE); + if(dic==NULL)mallocfail("dictionary"); + /* it is not permissible to realloc dic, because at the moment identifiers + etc. contain absolute pointers into the dictionary space - so we must + choose fairly large initial value for DICSPACE. Fix this later */ + prefixbase=malloc(prefixlimit); + prefixbase[0]='\0'; + prefix=0; +} + +/* this allows ~login convention in filenames */ +/* #define okgetpwnam +/* suppress 26.5.06 getpwnam cases runtime error when statically linked (Linux) */ + +#ifdef okgetpwnam +#include <pwd.h> +struct passwd *getpwnam(); +#endif +char *getenv(); + +char *gethome(n) /* for expanding leading `~' in tokens and pathnames */ +char *n; +{ struct passwd *pw; + if(n[0]=='\0')return(getenv("HOME")); +#ifdef okgetpwnam + if(pw=getpwnam(n))return(pw->pw_dir); +#endif + return(NULL); +} + +#define ovflocheck if(dicq-dic>DICSPACE)dicovflo() + +dicovflo() /* is this called everywhere it should be? Check later */ +{ fprintf(stderr,"\npanic: dictionary overflow\n"); exit(1); } + +char *token() /* lex analyser for command language (very simple) */ +{ extern char *current_script; + word ch=getchar(); + dicq = dicp; /* uses top of dictionary as temporary work space */ + while(ch==' '||ch=='\t')ch=getchar(); + if(ch=='~') + { char *h; + *dicq++ = ch; + ch=getchar(); + while(isalnum(ch)||ch=='-'||ch=='_'||ch=='.') + *dicq++ = ch,ch=getchar(); + /* NB csh does not allow `.' in user ids when expanding `~' + but this may be a mistake */ + *dicq='\0'; + if(h=gethome(dicp+1)) + (void)strcpy(dicp,h),dicq=dicp+strlen(dicp); + } +#ifdef SPACEINFILENAMES + if(ch!='"'&&ch!='<') /* test added 9.5.06 see else part */ +#endif + while(!isspace(ch)&&ch!=EOF) + { *dicq++ = ch; + if(ch=='%') + if(dicq[-2]=='\\')(--dicq)[-1]='%'; + else dicq--,(void)strcpy(dicq,current_script),dicq+=strlen(dicq); + ch=getchar(); } +#ifdef SPACEINFILENAMES + else { word closeq= ch=='<'?'>':'"'; /* this branch added 9.5.06 */ + *dicq++ = ch; /* to allow spaces in "tok" or <tok> */ + ch=getchar(); + while(ch!=closeq&&ch!='\n'&&ch!=EOF) + *dicq++ = ch, ch=getchar(); + if(ch==closeq)*dicq++ = ch, ch=getchar(); } +#endif + *dicq++ = '\0'; + ovflocheck; + while(ch==' '||ch=='\t')ch=getchar(); + ungetc(ch,stdin); + return(*dicp=='\0'?(char *)NULL:dicp); +} /* NB - if no token returns NULL rather than pointer to empty string */ + +char *addextn(b,s) /* if(b)force s to end in ".m", and resolve <quotes> */ +word b; +char *s; +{ extern char *miralib; + extern char linebuf[]; + word n=strlen(s); + /* printf("addextn(%s)\n",s); /* DEBUG */ + if(s[0]=='<'&&s[n-1]=='>') + { static miralen=0; /* code to handle quotes added 21/1/87 */ + if(!miralen)miralen=strlen(miralib); + strcpy(linebuf,miralib); + linebuf[miralen]= '/'; + strcpy(linebuf+miralen+1,s+1); + strcpy(dicp,linebuf); + s=dicp; + n=n+miralen-1; + dicq=dicp+n+1; + dicq[-1] = '\0'; /* overwrites '>' */ + ovflocheck; } else + if(s[0]=='\"'&&s[n-1]=='\"') + { /*strip quotes */ + dicq=dicp; s++; + while(*s)*dicq++ = *s++; + dicq[-1]='\0'; /* overwrites '"' */ + s=dicp; n=n-2; + } + if(!b||strcmp(s+n-2,".m")==0)return(s); + if(s==dicp)dicq--;/*if s in scratch area at top of dic, extend in situ*/ + else { /* otherwise build new copy at top of dic */ + dicq=dicp; + while(*s)*dicq++ = *s++; + *dicq = '\0'; } + if(strcmp(dicq-2,".x")==0)dicq -= 2; else + if(dicq[-1]=='.')dicq -= 1; + (void)strcpy(dicq,".m"); + dicq += 3; + ovflocheck; + /* printf("return(%s)\n",dicp); /* DEBUG */ + return(dicp); +} /* NB - call keep(dicp) if the result is to be retained */ + +word brct=0; + +spaces(n) +word n; +{ while(n-- >0)putchar(' '); +} + +litname(s) +char *s; +{ word n=strlen(s); + return(n>=6 && strcmp(s+n-6,".lit.m")==0); +} + +word getch() /* keeps track of current position in the variable "col"(column) */ +{ word ch= getc(s_in); + if(ch==EOF&&!atnl&&tl[fileq]==NIL) /* badly terminated top level file */ + { atnl=1; return('\n'); } + if(atnl) + { if((line_no==0&&!commandmode||magic&&line_no==1)&&litstack==NIL) + litmain=literate= (ch=='>')||litname(get_fil(current_file)); + if(literate) + { word i=0; + while(ch!=EOF&&ch!='>') + { ungetc(ch,s_in); + line_no++; + (void)fgets(dicp,250,s_in); + if(i==0&&line_no>1)chblank(dicp); i++; + if(echoing)spaces(lverge),fputs(dicp,stdout); + ch=getc(s_in); } + if((i>1||line_no==1&&i==1)&&ch!=EOF)chblank(dicp); + if(ch=='>') + { if(echoing)putchar(ch),spaces(lverge);ch=getc(s_in); } + } /* supports alternative `literate' comment convention */ + atnl=0; col= lverge+literate; + if(!commandmode&&ch!=EOF)line_no++; } + if(echoing&&ch!=EOF) + { putchar(ch); + if(ch=='\n'&&!literate) + if(litmain)putchar('>'),spaces(lverge); + else spaces(lverge); + } + if(ch=='\t')col= ((col-lverge)/8 + 1)*8+lverge; + else col++; + if(ch=='\n')atnl= 1; + return(ch); } + +word blankerr=0; + +chblank(s) +char *s; +{ while(*s==' '||*s=='\t')s++; + if(*s=='\n')return; + syntax("formal text not delimited by blank line\n"); + blankerr=1; + reset(); /* easiest way to recover is to pretend it was an interrupt */ +} + +/* getlitch gets a character from input like getch, but using C escaping + conventions if the char is backslash -- for use in reading character + and string constants */ + +word rawch; +/* it is often important to know, when certain characters are returned (e.g. + quotes and newlines) whether they were escaped or literal */ + +word errch; /* for reporting unrecognised \escape */ + +word getlitch() +{ extern word UTF8; + word ch=c; + rawch = ch; + if(ch=='\n')return(ch); /* always an error */ + if(UTF8&&ch>127) + { /* UTF-8 uses 2 or 3 bytes for unicode points to 0xffff */ + word ch1=c=getch(); + if((ch&0xe0)==0xc0) /* 2 bytes */ + { if((ch1&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return sto_char((ch&0x1f)<<6|ch1&0x3f); } + word ch2=c=getch(); + if((ch&0xf0)==0xe0) /* 3 bytes */ + { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return sto_char((ch&0xf)<<12|(ch1&0x3f)<<6|ch2&0x3f); } + word ch3=c=getch(); + if((ch&0xf8)==0xf0) /* 4 bytes, beyond basic multiligual plane */ + { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80||(ch3&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return((ch&7)<<18|(ch1&0x3f)<<12|(ch2&0x3f)<<6|ch3&0x3f); } + return(-5); + /* not UTF8 */ + } + if(ch!='\\') + { c=getch(); return(ch); } + ch = getch(); + c = getch(); + switch(ch) + { case '\n': return(getlitch()); /* escaped nl was handled in 'getch()' */ + case 'a': return('\a'); + case 'b': return('\b'); + case 'f': return('\f'); /* form feed */ + case 'n': return('\n'); /* newline, == linefeed */ + case 'r': return('\r'); /* carriage return */ + case 't': return('\t'); + case 'v': return('\v'); + case 'X': /* omit for Haskell escape rules, see also lines marked H */ + case 'x': if(isxdigit(c)) + { word value, N=ch=='x'?4:6; /* N=7 for Haskell escape rules */ + char hold[8]; + ch = c; + word count=0; + /* while(ch=='0'&&isxdigit(peekch()))ch=getch(); /* H-lose leading 0s */ + while(isxdigit(ch)&&count<N) + hold[count++]=ch,ch=getch(); + /* read upto N hex digits */ + hold[count] = '\0'; + sscanf(hold,"%x",&value); + c = ch; + return value>UMAX?-3 /* \x out of range */ + :sto_char(value); } + else return -2; /* \x with no hex digits */ + default: if('0'<=ch&&ch<='9') + { word n=ch-'0',count=1,N=3; /* N=8 for Haskell escape rules */ + ch = c; + /* while(ch=='0'&&isdigit(peekch()))ch=getch(); /* H-lose leading 0s */ + while(isdigit(ch)&&count<N) + /* read upto N digits */ + { n = 10*n+ch-'0'; + count++; + ch = getch(); } + c = ch; + return /* n>UMAX?-4: /* H \decimal out of range */ + sto_char(n); } + if(ch=='\''||ch=='"'||ch=='\\'||ch=='`')return(ch); /* see note */ + if(ch=='&')return -7; /* Haskell null escape, accept silently */ + errch=ch<=255?ch:'?'; + return -6; /* unrecognised \something */ + } +} /* note: we accept \` for ` because getlitch() is used by charclass() */ + +char *rdline() /* used by the "!" command -- see RULES */ +{ extern char *current_script; + static char linebuf[BUFSIZE]; + char *p=linebuf; + word ch=getchar(),expansion=0; + while(ch==' '||ch=='\t')ch=getchar(); + if(ch=='\n'||ch=='!'&&!(*linebuf)) + { /* "!!" or "!" on its own means repeat last !command */ + if(*linebuf)printf("!%s",linebuf); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + return(linebuf); } + if(ch=='!') + expansion=1,p=linebuf+strlen(linebuf)-1; /* p now points at old '\n' */ + else ungetc(ch,stdin); + while((*p++ =ch=getchar())!='\n'&&ch!=EOF) + if(p-linebuf>=BUFSIZE) + { *p='\0'; + fprintf(stderr,"sorry, !command too long (limit=%d chars): %s...\n", + BUFSIZE,linebuf); + while((ch=getchar())!='\n'&&ch!=EOF); + return(NULL); + } else + if(p[-1]=='%') + if(p>linebuf+1&&p[-2]=='\\')(--p)[-1]='%'; else + { (void)strncpy(p-1,current_script,linebuf+BUFSIZE-p); + p = linebuf+strlen(linebuf); + expansion = 1; + } + *p = '\0'; + if(expansion)printf("!%s",linebuf); + return(linebuf); } + +setlmargin() /* this and the next routine are used to enforce the offside + rule ("yylex" refuses to read a symbol if col<lmargin) */ +{ margstack= cons(lmargin,margstack); + if(lmargin<col)lmargin= col; } /* inner scope region cannot "protrude" */ + +unsetlmargin() +{ if(margstack==NIL)return; /* in case called after `syntax("..")' */ + lmargin= hd[margstack]; + margstack= tl[margstack]; } + +word okid(); +word okulid(); +word PREL=1; + +#define isletter(c) ('a'<=c&&c<='z'||'A'<=c&&c<='Z') + +errclass(word val, word string) +/* diagnose error in charclass, string or char const */ +{ char *s = string==2?"char class":string?"string":"char const"; + if(val==-2)printf("\\x with no xdigits in %s\n",s); else + if(val==-3)printf("\\hexadecimal escape out of range in %s\n",s); else + if(val==-4)printf("\\decimal escape out of range in %s\n",s); else + if(val==-5)printf("unrecognised character in %s" + "(UTF8 error)\n",s); else + if(val==-6)printf("unrecognised escape \\%c in %s\n",errch,s); else + if(val==-7)printf("illegal use of \\& in char const\n"); else + printf("unknown error in %s\n",s); + acterror(); } + +yylex() /* called by YACC to get the next symbol */ +{ extern word SYNERR,exportfiles,inexplist,sreds; + /* SYNERR flags context sensitive syntax error detected in actions */ + if(SYNERR)return(END); /* tell YACC to go home */ + layout(); + if(c=='\n') /* can only occur in command mode */ +/* if(magic){ commandmode=0; /* expression just read, now script */ +/* line_no=2; +/* return(c); } else /* no longer relevant 26.11.2019 */ + return(END); + if(col<lmargin) + if(c=='='&&(margstack==NIL||col>=hd[margstack]))/* && part fixes utah.bug*/ + { c = getch(); + return(ELSEQ); /* ELSEQ means "OFFSIDE =" */ + } + else return(OFFSIDE); + if(c==';') /* fixes utah2.bug */ + { c=getch(); layout(); + if(c=='='&&(margstack==NIL||col>=hd[margstack])) + { c = getch(); + return(ELSEQ); /* ELSEQ means "OFFSIDE =" */ + } + else return(';'); + } + if( + /* c=='_'&&okid(peekch()) || /* _id/_ID as lowercase id */ + isletter(c)){ kollect(okid); + if(inlex==1){ layout(); + yylval=name(); + return(c=='='?LEXDEF: + isconstructor(yylval)?CNAME: + NAME); } + if(inbnf==1) + /* add trailing space to nonterminal to avoid clash + with ordinary names */ + dicq[-1] = ' ', + *dicq++ = '\0'; + return(identifier(0)); } + if('0'<=c&&c<='9'||c=='.'&&peekdig()) + { if(c=='0'&&tolower(peekch())=='x') + hexnumeral(); else /* added 21.11.2013 */ + if(c=='0'&&tolower(peekch())=='o') + getch(),c=getch(),octnumeral(); /* added 21.11.2013 */ + else numeral(); + return(CONST); } + if(c=='%'&&!commandmode)return(directive()); + if(c=='\'') + { c = getch(); + yylval= getlitch(); + if(yylval<0){ errclass(yylval,0); return CONST; } + if(!is_char(yylval)) + printf("%simpossible event while reading char const ('\\%u\')\n", + echoing?"\n":"",yylval), + acterror(); + if(rawch=='\n'||c!='\'')syntax("improperly terminated char const\n"); + else c= getch(); + return(CONST); } + if(inexplist&&(c=='\"'||c=='<')) + { if(!pathname())syntax("badly formed pathname in %export list\n"); + else exportfiles=strcons(addextn(1,dicp),exportfiles), + keep(dicp); + return(PATHNAME); } + if(inlex==1&&c=='`') + { return(charclass()?ANTICHARCLASS:CHARCLASS); } + if(c=='\"') + { string(); + if(yylval==NIL)yylval=NILS; /* to help typechecker! */ + return(CONST); } + if(inbnf==2) /* fiddle to offside rule in grammars */ + if(c=='[')brct++; else if(c==']')brct--; else + if(c=='|'&&brct==0) + return(OFFSIDE); + if(c==EOF) + { if(tl[fileq]==NIL&&margstack!=NIL)return(OFFSIDE); /* to fix dtbug */ + fclose((FILE *)hd[hd[fileq]]); + fileq= tl[fileq]; insertdepth--; + if(fileq!=NIL&&hd[echostack]) + { if(literate)putchar('>'),spaces(lverge); + printf("<end of insert>"); } + s_in= fileq==NIL?stdin:(FILE *)hd[hd[fileq]]; + c= ' '; + if(fileq==NIL) + { lverge=c=col=lmargin=0; + /* c=0; necessary because YACC sometimes reads 1 token past END */ + atnl=1; + echoing=verbosity&listing; + lastline=line_no; + /* hack so errline can be set right if err at end of file */ + line_no=0; + litmain=literate=0; + return(END); } + else { current_file = tl[hd[fileq]]; + prefix=hd[prefixstack]; + prefixstack=tl[prefixstack]; + echoing=hd[echostack]; + echostack=tl[echostack]; + lverge=hd[vergstack]; + vergstack=tl[vergstack]; + literate=hd[litstack]; + litstack=tl[litstack]; + line_no=hd[linostack]; + linostack=tl[linostack]; } + return(yylex()); } + lastc= c; + c= getch(); +#define try(x,y) if(c==x){ c=getch(); return(y); } + switch(lastc) { + case '_': if(c=='') /* underlined something */ + { c=getch(); + if(c=='<'){ c=getch(); return(LE); } + if(c=='>'){ c=getch(); return(GE); } + if(c=='%'&&!commandmode)return(directive()); + if(isletter(c)) /* underlined reserved word */ + { kollect(okulid); + if(dicp[1]=='_'&&dicp[2]=='') + return(identifier(1)); } + syntax("illegal use of underlining\n"); + return('_'); } + return(lastc); + case '-': try('>',ARROW) try('-',MINUSMINUS) return(lastc); + case '<': try('-',LEFTARROW) try('=',LE) return(lastc); + case '=': if(c=='>'){ syntax("unexpected symbol =>\n"); return '='; } + try('=',EQEQ) return(lastc); + case '+': try('+',PLUSPLUS) return(lastc); + case '.': if(c=='.') + { c=getch(); + return(DOTDOT); + } + return(lastc); + case '\\': try('/',VEL) return(lastc); + case '>': try('=',GE) return(lastc); + case '~': try('=',NE) return(lastc); + case '&': if(c=='>') + { c=getch(); + if(c=='>')yylval=1; + else yylval=0,ungetc(c,s_in); + c=' '; + return(TO); } + return(lastc); + case '/': try('/',DIAG) return(lastc); + case '*': try('*',collectstars()) return(lastc); + case ':': if(c==':') + { c=getch(); + if(c=='='){ c=getch(); return(COLON2EQ); } + else return(COLONCOLON); + } + return(lastc); + case '$': if( + /* c=='_'&&okid(peekch())|| /* _id/_ID as id */ + isletter(c)) + { word t; + kollect(okid); + t=identifier(0); + return(t==NAME?INFIXNAME:t==CNAME?INFIXCNAME:'$'); } + /* the last alternative is an error - caveat */ + if('1'<=c&&c<='9') + { word n=0; + while(isdigit(c)&&n<1e6)n=10*n+c-'0',c=getch(); + if(n>sreds) + /* sreds==0 everywhere except in semantic redn clause */ + printf("%ssyntax error: illegal symbol $%d%s\n", + echoing?"\n":"",n,n>=1e6?"...":""), + acterror(); + else { yylval=mkgvar(n); return(NAME); } + } + if(c=='-') + { if(!compiling) + syntax("unexpected symbol $-\n"); else + {c=getch(); yylval=common_stdin; return(CONST); }} + /* NB we disallow recursive use of $($/+/-) inside $+ data + whence addition of `compiling' to premises */ + if(c==':') + { c=getch(); + if(c!='-')syntax("unexpected symbol $:\n"); else + { if(!compiling) + syntax("unexpected symbol $:-\n"); else + {c=getch(); yylval=common_stdinb; return(CONST); }}} /* $:- */ + if(c=='+') + { /* if(!(commandmode&&compiling||magic)) + syntax("unexpected symbol $+\n"); else /* disallow in scripts */ + if(!compiling) + syntax("unexpected symbol $+\n"); else + { c=getch(); + if(commandmode) + yylval=cook_stdin; + else yylval=ap(readvals(0,0),OFFSIDE); + return(CONST); }} + if(c=='$') + { if(!(inlex==2||commandmode&&compiling)) + syntax("unexpected symbol $$\n"); else + { c=getch(); + if(inlex) { yylval=mklexvar(0); return(NAME); } + else return(DOLLAR2); }} + if(c=='#') + { if(inlex!=2)syntax("unexpected symbol $#\n"); else + { c=getch(); yylval=mklexvar(1); return(NAME); }} + if(c=='*') + { c=getch(); yylval=ap(GETARGS,0); return(CONST); } + if(c=='0') + syntax("illegal symbol $0\n"); + default: return(lastc); +}} + +layout() +{L:while(c==' '||c=='\n'&&!commandmode||c=='\t') c= getch(); + if(c==EOF&&commandmode){ c='\n'; return; } + if(c=='|'&&peekch()=='|' /* ||comments */ + || col==1&&line_no==1 /* added 19.11.2013 */ + &&c=='#'&&peekch()=='!') /* UNIX magic string */ + { while((c=getch())!='\n'&&c!=EOF); + if(c==EOF&&!commandmode)return; + c= '\n'; + goto L; } +} + +collectstars() +{ word n=2; + while(c=='*')c=getch(),n++; + yylval= mktvar(n); + return(TYPEVAR); +} + +word gvars=NIL; /* list of grammar variables - no need to reset */ + +mkgvar(i) /* make bound variable (corresponding to $i in bnf rule) */ +word i; +{ word *p= &gvars; + while(--i) + { if(*p==NIL)*p=cons(sto_id("gvar"),NIL); + p= &tl[*p]; } + if(*p==NIL)*p=cons(sto_id("gvar"),NIL); + return(hd[*p]); +} /* all these variables have the same name, and are not in hashbucket */ + +word lexvar=0; + +mklexvar(i) /* similar - corresponds to $$, $# on rhs of %lex rule */ +word i; /* i=0 or 1 */ +{ extern word ltchar; + if(!lexvar) + lexvar=cons(sto_id("lexvar"),sto_id("lexvar")), + id_type(hd[lexvar])=ltchar, + id_type(tl[lexvar])=genlstat_t(); + return(i?tl[lexvar]:hd[lexvar]); +} + +word ARGC; +char **ARGV; /* initialised in main(), see steer.c */ + +conv_args() /* used to give access to command line args + see case GETARGS in reduce.c */ +{ word i=ARGC,x=NIL; + if(i==0)return(NIL); /* possible only if not invoked from a magic script */ + { while(--i)x=cons(str_conv(ARGV[i]),x); + x=cons(str_conv(ARGV[0]),x); } + return(x); +} + +str_conv(s) /* convert C string to Miranda form */ +char *s; +{ word x=NIL,i=strlen(s); + while(i--)x=cons(s[i],x); + return(x); +} /* opposite of getstring() - see reduce.c */ + +okpath(ch) +word ch; +{ return(ch!='\"'&&ch!='\n'&&ch!='>'); } + +char *pathname() /* returns NULL if not valid pathname (in string quotes) */ +{ layout(); + if(c=='<') /* alternative quotes <..> for system libraries */ + { extern char *miralib; + char *hold=dicp; + c=getch(); + (void)strcpy(dicp,miralib); + dicp+=strlen(miralib); + *dicp++ = '/'; + kollect(okpath); + dicp=hold; + if(c!='>')return(NULL); + c=' '; + return(dicp); } + if(c!='\"')return(NULL); + c=getch(); + if(c=='~') + { char *h,*hold=dicp; + extern char linebuf[]; + *dicp++ = c; + c=getch(); + while(isalnum(c)||c=='-'||c=='_'||c=='.') + *dicp++ = c, c=getch(); + *dicp='\0'; + if(h=gethome(hold+1)) + (void)strcpy(hold,h),dicp=hold+strlen(hold); + else (void)strcpy(&linebuf[0],hold), + (void)strcpy(hold,prefixbase+prefix), + dicp=hold+strlen(prefixbase+prefix), + (void)strcpy(dicp,&linebuf[0]), + dicp+=strlen(dicp); + kollect(okpath); + dicp=hold; + } else + if(c=='/') /* absolute pathname */ + kollect(okpath); + else { /* relative pathname */ + char *hold=dicp; + (void)strcpy(dicp,prefixbase+prefix); + dicp+=strlen(prefixbase+prefix); + kollect(okpath); + dicp=hold; } + if(c!='\"')return(NULL); + c = ' '; + return(dicp); +} /* result is volatile - call keep(dicp) to retain */ + +adjust_prefix(f) /* called at %insert and at loadfile, to get static pathname + resolution */ +char *f; +{ /* the directory part of the pathname f becomes the new + prefix for pathnames, and we stack the current prefix */ + char *g; + prefixstack=strcons(prefix,prefixstack); + prefix += strlen(prefixbase+prefix)+1; + while(prefix+strlen(f)>=prefixlimit) /* check and fix overflow */ + prefixlimit += 1024, prefixbase=realloc(prefixbase,prefixlimit); + (void)strcpy(prefixbase+prefix,f); + g=rindex(prefixbase+prefix,'/'); + if(g)g[1]='\0'; + else prefixbase[prefix]='\0'; +} + +/* NOTES on how static pathname resolution is achieved: +(the specification is that pathnames must always be resolved relative to the +file in which they are encountered) +Definition -- the 'prefix' of a pathname is the initial segment up to but not +including the last occurrence of '/' (null if no '/' present). +Keep the wd constant during compilation. Have a global char* prefix, initially +null. +1) Whenever you read a relative pathname(), insert 'prefix' on the front of it. +2) On entering a new level of insert, stack old prefix and prefix becomes that + of new file name. Done by calling adjust_prefix(). +3) On quitting a level of insert, unstack old prefix. +*/ + +peekdig() +{ word ch = getc(s_in); + ungetc(ch,s_in); + return('0'<=ch&&ch<='9'); +} + +peekch() +{ word ch = getc(s_in); + ungetc(ch,s_in); + return(ch); +} + +openfile(n) /* returns 0 or 1 as indication of success - puts file on fileq + if successful */ +char *n; +{ FILE *f; + f= fopen(n,"r"); + if(f==NULL)return(0); + fileq= cons(strcons(f,NIL),fileq); + insertdepth++; + return(1); +} + +identifier(s) /* recognises reserved words */ +word s; /* flags looking for ul reserved words only */ +{ extern word lastid,initialising; + if(inbnf==1) + { /* only reserved nonterminals are `empty', `end', `error', `where' */ + if(is("empty ")||is("e_m_p_t_y"))return(EMPTYSY); else + if(is("end ")||is("e_n_d"))return(ENDSY); else + if(is("error ")||is("e_r_r_o_r"))return(ERRORSY); else + if(is("where ")||is("w_h_e_r_e"))return(WHERE); } + else + switch(dicp[0]) + { case 'a': if(is("abstype")||is("a_b_s_t_y_p_e")) + return(ABSTYPE); + break; + case 'd': if(is("div")||is("d_i_v")) + return(DIV); + break; + case 'F': if(is("False")) /* True, False alleged to be predefined, not + reserved (??) */ + { yylval = False; + return(CONST); } + break; + case 'i': if(is("if")||is("i_f")) + return(IF); + break; + case 'm': if(is("mod")||is("m_o_d")) + return(REM); + break; + case 'o': if(is("otherwise")||is("o_t_h_e_r_w_i_s_e")) + return(OTHERWISE); + break; + case 'r': if(is("readvals")||is("r_e_a_d_v_a_l_s")) + return(READVALSY); + break; + case 's': if(is("show")||is("s_h_o_w")) + return(SHOWSYM); + break; + case 'T': if(is("True")) + { yylval = True; + return(CONST); } + case 't': if(is("type")||is("t_y_p_e")) + return(TYPE); + break; + case 'w': if(is("where")||is("w_h_e_r_e")) + return(WHERE); + if(is("with")||is("w_i_t_h")) + return(WITH); + break; + } + if(s){ syntax("illegal use of underlining\n"); return('_'); } + yylval=name(); /* not a reserved word */ + if(commandmode&&lastid==0&&id_type(yylval)!=undef_t)lastid=yylval; + return(isconstructor(yylval)?CNAME:NAME); +} + +word disgusting=0; /* flag to turn off typecheck, temporary hack for jrc */ + +directive() /* these are of the form "%identifier" */ +{ extern word SYNERR,magic; + word holdcol=col-1,holdlin=line_no; + c = getch(); + if(c=='%'){ c=getch(); return(ENDIR); } + kollect(okulid); + switch(dicp[0]=='_'&&dicp[1]==''?dicp[2]:dicp[0]) + { case 'b': if(is("begin")||is("_^Hb_^He_^Hg_^Hi_^Hn")) + if(inlex) + return(LBEGIN); + if(is("bnf")||is("_^Hb_^Hn_^Hf")) + { setlmargin(); col=holdcol+4; + /* `indent' to right hand end of directive */ + return(BNF); } + break; + case 'e': if(is("export")||is("_e_x_p_o_r_t")) + { if(magic)syntax( + "%export directive not permitted in \"-exp\" script\n"); + return(EXPORT); } + break; + case 'f': if(is("free")||is("_f_r_e_e")) + { if(magic)syntax( + "%free directive not permitted in \"-exp\" script\n"); + return(FREE); } + break; + case 'i': if(is("include")||is("_i_n_c_l_u_d_e")) + { if(!SYNERR){ layout(); setlmargin(); } + /* does `indent' for grammar */ + if(!pathname()) + syntax("bad pathname after %include\n"); + else yylval=strcons(addextn(1,dicp), + fileinfo(get_fil(current_file),holdlin)), + /* (includee,hereinfo) */ + keep(dicp); + return(INCLUDE); } + if(is("insert")||is("_i_n_s_e_r_t")) + { char *f=pathname(); + if(!f)syntax("bad pathname after %insert\n"); else + if(insertdepth<12&&openfile(f)) + { adjust_prefix(f); + vergstack=cons(lverge,vergstack); + echostack=cons(echoing,echostack); + litstack=cons(literate,litstack); + linostack=strcons(line_no,linostack); + line_no=0; atnl=1; /* was line_no=1; */ + keep(dicp); + current_file = make_fil(f,fm_time(f),0,NIL); + files = append1(files,cons(current_file,NIL)); + tl[hd[fileq]] = current_file; + s_in = (FILE *)hd[hd[fileq]]; + literate= peekch()=='>'||litname(f); + col=lverge=holdcol; + if(echoing) + { putchar('\n'); + if(!literate) + if(litmain)putchar('>'),spaces(holdcol); + else spaces(holdcol); } + c = getch(); } /* used to precede previous cmd when echo + was delayed by one char, see getch() */ + else { word toomany=(insertdepth>=12); + printf("%s%%insert error - cannot open \"%s\"\n", + echoing?"\n":"",f); + keep(dicp); + if(toomany)printf( + "too many nested %%insert directives (limit=%d)\n", + insertdepth); + else + files = append1(files,cons(make_fil(f,0,0,NIL),NIL)); + /* line above for benefit of `oldfiles' */ + acterror(); } + return(yylex()); } + break; + case 'l': if(is("lex")||is("_^Hl_^He_^Hx")) + { if(inlex)syntax("nested %lex not permitted\n"); + /* due to use of global vars inlex, lexdefs */ + return(LEX); } + if(is("list")||is("_l_i_s_t")) + { echoing=verbosity; return(yylex()); } + break; + case 'n': if(is("nolist")||is("_n_o_l_i_s_t")) + { echoing=0; return(yylex()); } + break; + } + if(echoing)putchar('\n'); + printf("syntax error: unknown directive \"%%%s\"\n",dicp), + acterror(); + return(END); +} + +okid(ch) +word ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch=='\''); } + +okulid(ch) +word ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch==''||ch=='\''); } + +kollect(f) +/* note top of dictionary used as work space to collect current token */ +word (*f)(); +{ dicq= dicp; + while((*f)(c)){ *dicq++ = c; c= getch(); } + *dicq++ = '\0'; + ovflocheck; +} + +char *keep(p) /* call this to retain volatile string for later use */ +char *p; +{ if(p==dicp)dicp= dicq; + else (void)strcpy(dicp,p), + p=dicp, + dicp=dicq=dicp+strlen(dicp)+1, + dic_check(); + return(p); +} + +dic_check() /* called from REDUCE */ +{ ovflocheck; } + +numeral() +{ word nflag=1; + dicq= dicp; + while(isdigit(c)) + *dicq++ = c, c=getch(); + if(c=='.'&&peekdig()) + { *dicq++ = c, c=getch(); nflag=0; + while(isdigit(c)) + *dicq++ = c, c=getch(); } + if(c=='e') + { word np=0; + *dicq++ = c, c=getch(); nflag=0; + if(c=='+')c=getch(); else /* ignore + before exponent */ + if(c=='-')*dicq++ = c, c=getch(); + if(!isdigit(c)) /* e must be followed by some digits */ + syntax("badly formed floating point number\n"); + while(c=='0') + *dicq++ = c, c=getch(); + while(isdigit(c)) + np++, *dicq++ = c, c=getch(); + if(!nflag&&np>3) /* scanf falls over with silly exponents */ + { syntax("floating point number out of range\n"); + return; } + } + ovflocheck; + if(nflag) /* `.' or `e' makes fractional */ + *dicq = '\0', + yylval= bigscan(dicp); else + { double r=0.0; + if(dicq-dicp>60) /* this allows 59 chars */ + /* scanf crashes, on VAX, gives wrong answers, on ORION 1/05 */ + { syntax("illegal floating point constant (too many digits)\n"); + return; } + errno=0; + *dicq = '\n'; + sscanf(dicp,"%lf",&r); + if(errno)fpe_error(); else + yylval= sto_dbl((double)r); } +} + +hexnumeral() /* added 21.11.2013 */ +{ extern word errno; + word nflag=1; + dicq= dicp; + *dicq++ = c, c=getch(); /* 0 */ + *dicq++ = c, c=getch(); /* x */ + if(!isxdigit(c)&&c!='.')syntax("malformed hex number\n"); + while(c=='0'&&isxdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */ + while(isxdigit(c)) + *dicq++ = c, c=getch(); + ovflocheck; + if(c=='.'||tolower(c)=='p') /* hex float, added 20.11.19 */ + { double d; + if(c=='.') + { *dicq++ = c, c=getch(); + while(isxdigit(c)) + *dicq++ = c, c=getch(); } + if(c=='p') + { *dicq++ = c, c=getch(); + if(c=='+'||c=='-')*dicq++ = c, c=getch(); + if(!isdigit(c))syntax("malformed hex float\n"); + while(isdigit(c)) + *dicq++ = c, c=getch(); } + ovflocheck; + *dicq='\0'; + if(dicq-dicp>60||sscanf(dicp,"%lf",&d)!=1) + syntax("malformed hex float\n"); + else yylval= sto_dbl(d); + return; } + *dicq = '\0'; + yylval= bigxscan(dicp+2,dicq); +} + +octnumeral() /* added 21.11.2013 */ +{ extern word errno; + word nflag=1; + dicq= dicp; + if(!isdigit(c))syntax("malformed octal number\n"); + while(c=='0'&&isdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */ + while(isdigit(c)&&c<='7') + *dicq++ = c, c=getch(); + if(isdigit(c))syntax("illegal digit in octal number\n"); + ovflocheck; + *dicq = '\0'; + yylval= bigoscan(dicp,dicq); +} + +word namebucket[128]; /* each namebucket has a list terminated by 0, not NIL */ + +hash(s) /* returns a value in {0..127} */ +char *s; +{ word h = *s; + if(h)while(*++s)h ^= *s; /* guard necessary to deal with s empty */ + return(h&127); +} + +isconstrname(s) +char *s; +{ if(s[0]=='$')s++; + return isupper(*s); /* formerly !islower */ +} + +getfname(x) +/* nonterminals have an added ' ', getfname returns the corresponding + function name */ +word x; +{ char *p = get_id(x); + dicq= dicp; + while(*dicq++ = *p++); + if(dicq-dicp<3)fprintf(stderr,"impossible event in getfname\n"),exit(1); + dicq[-2] = '\0'; /* overwrite last char */ + ovflocheck; + return(name()); +} + +isnonterminal(x) +word x; +{ char *n; + if(tag[x]!=ID)return(0); + n = get_id(x); + return(n[strlen(n)-1]==' '); +} + +name() +{ word q,h; + q= namebucket[h=hash(dicp)]; + while(q&&!is(get_id(hd[q])))q= tl[q]; + if(q==0) + { q = sto_id(dicp); + namebucket[h] = cons(q,namebucket[h]); + keep(dicp); } + else q= hd[q]; + return(q); } +/* note - keeping buckets sorted didn't seem to help (if anything slightly + slower) probably because ordering only relevant if name not present, and + outweighed by increased complexity of loop */ + +static word inprelude=1; + +make_id(n) /* used in mira_setup(), primdef(), predef(), all in steer.c */ +char *n; +{ word x,h; + h=hash(n); + x = sto_id(inprelude?keep(n):n); + namebucket[h] = cons(x,namebucket[h]); + return(x); } + +findid(n) /* like name() but returns NIL rather than create new id */ +char *n; +{ word q; + q= namebucket[hash(n)]; + while(q&&!strcmp(n,get_id(hd[q]))==0)q= tl[q]; + return(q?hd[q]:NIL); } + +word *pnvec=0,nextpn,pn_lim=200; /* private name vector */ + +reset_pns() /* (re)initialise private name space */ +{ nextpn=0; + if(!pnvec) + { pnvec=(word *)malloc(pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } +} + +make_pn(val) /* create new private name with value val */ +word val; +{ if(nextpn==pn_lim) + { pn_lim+=400; + pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } + pnvec[nextpn]=strcons(nextpn,val); + return(pnvec[nextpn++]); +} + +sto_pn(n) /* return n'th private name, extending pnvec if necessary */ +word n; +{ if(n>=pn_lim) + { while(pn_lim<=n)pn_lim+=400; + pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } + while(nextpn<=n) /* NB allocates all missing names upto and including nth*/ + pnvec[nextpn]=strcons(nextpn,UNDEF),nextpn++; + return(pnvec[n]); +} + +mkprivate(x) /* disguise identifiers prior to removal from environment */ +word x; /* used in setting up prelude - see main() in steer.c */ +{ while(x!=NIL) + { char *s = get_id(hd[x]); + get_id(hd[x])[0] += 128; /* hack to make private internal name */ + x = tl[x]; } /* NB - doesn't change hashbucket */ + inprelude=0; +} + +word sl=100; + +string() +{ word p; + word ch,badch=0; + c = getch(); + ch= getlitch(); + p= yylval= cons(NIL,NIL); + while(ch!=EOF&&rawch!='\"'&&rawch!='\n') + if(ch==-7) ch=getlitch(); else /* skip \& */ + if(ch<0){ badch=ch; break; } + else { p= tl[p]= cons(ch,NIL); + ch= getlitch(); } + yylval= tl[yylval]; + if(badch)errclass(badch,1); + if(rawch=='\n') + syntax("non-escaped newline encountered inside string quotes\n"); else + if(ch==EOF) + { if(echoing)putchar('\n'); + printf("syntax error: script ends inside unclosed string quotes - \n"); + printf(" \""); + while(yylval!=NIL&& sl-- ) + { putchar(hd[yylval]); + yylval= tl[yylval]; } + printf("...\"\n"); + acterror(); } +} + +charclass() +{ word p; + word ch,badch=0,anti=0; + c = getch(); + if(c=='^')anti=1,c=getch(); + ch= getlitch(); + p= yylval= cons(NIL,NIL); + while(ch!=EOF&&rawch!='`'&&rawch!='\n') + if(ch==-7)ch=getlitch(); else /* skip \& */ + if(ch<0){ badch=ch; break; } + else { if(rawch=='-'&&hd[p]!=NIL&&hd[p]!=DOTDOT) + ch=DOTDOT; /* non-initial, non-escaped '-' */ + p= tl[p]= cons(ch,NIL); + ch= getlitch(); } + if(hd[p]==DOTDOT)hd[p]='-'; /* naturalise a trailing '-' */ + for(p=yylval;tl[p]!=NIL;p=tl[p]) /* move each DOTDOT to front of range */ + if(hd[tl[p]]==DOTDOT) + { hd[tl[p]]=hd[p],hd[p]=DOTDOT; + if(hd[tl[p]]>=hd[tl[tl[p]]]) + syntax("illegal use of '-' in [charclass]\n"); + } + yylval= tl[yylval]; + if(badch)errclass(badch,2); + if(rawch=='\n') + syntax("non-escaped newline encountered in char class\n"); else + if(ch==EOF) + { if(echoing)putchar('\n'); + printf( + "syntax error: script ends inside unclosed char class brackets - \n"); + printf(" ["); + while(yylval!=NIL&& sl-- ) + { putchar(hd[yylval]); + yylval= tl[yylval]; } + printf("...]\n"); + acterror(); } + return(anti); +} + +reset_lex() /* called after an error */ +{ extern word errs,errline; + extern char *current_script; + /*printf("reset_lex()\n"); /* DEBUG */ + if(!commandmode) + { if(!errs)errs=fileinfo(get_fil(current_file),line_no); + /* convention, if errs set contains location of error, otherwise pick up + from current_file and line_no */ + if(tl[errs]==0&&(char *)hd[errs]==current_script) + /* at end of file, so line_no has been reset to 0 */ + printf("error occurs at end of "); + else printf("error found near line %d of ",tl[errs]); + printf("%sfile \"%s\"\ncompilation abandoned\n", + (char *)hd[errs]==current_script?"":"%insert ", + (char *)hd[errs]); + if((char *)hd[errs]==current_script) + errline=tl[errs]==0?lastline:tl[errs],errs=0; + else { while(tl[linostack]!=NIL)linostack=tl[linostack]; + errline=hd[linostack]; } + /* tells editor where to find error - errline contains location of 1st + error in main script, errs is hereinfo of upto one error in %insert + script (each is 0 if not set) - some errors can set both */ + } + reset_state(); +} + +reset_state() /* reset all global variables used by compiler */ +{ extern word TABSTRS,SGC,newtyps,algshfns,showchain,inexplist,sreds, + rv_script,idsused; + /* printf("reset_state()\n"); /* DEBUG */ + if(commandmode) + while(c!='\n'&&c!=EOF)c=getc(s_in); /* no echo */ + while(fileq!=NIL)fclose((FILE *)hd[hd[fileq]]),fileq=tl[fileq]; + insertdepth= -1; + s_in=stdin; + echostack=idsused=prefixstack=litstack=linostack=vergstack + =margstack=NIL; + prefix=0; prefixbase[0]='\0'; + echoing=verbosity&listing; + brct=inbnf=sreds=inlex=inexplist=commandmode=lverge=col=lmargin=0; + atnl=1; + rv_script=0; + algshfns=newtyps=showchain=SGC=TABSTRS=NIL; + c=' '; + line_no=0; + litmain=literate=0; + /* printf("exit reset_state()\n"); /* DEBUG */ +} + +/* end of MIRANDA LEX ANALYSER */ + diff --git a/new/reduce.c b/new/reduce.c new file mode 100644 index 0000000..04f7267 --- /dev/null +++ b/new/reduce.c @@ -0,0 +1,2376 @@ +/* MIRANDA REDUCE */ +/* new SK reduction machine - installed Oct 86 */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include <errno.h> +#include <sys/types.h> +#include <sys/stat.h> +struct stat buf; /* used only by code for FILEMODE, FILESTAT in reduce */ +#include "data.h" +#include "big.h" +#include "lex.h" +extern word debug, UTF8, UTF8OUT; +#define FST HD +#define SND TL +#define BSDCLOCK +/* POSIX clock wraps around after c. 72 mins */ +#ifdef RYU +char* d2s(double); +word d2s_buffered(double, char*); +#endif + +double fa,fb; +long long cycles=0; +word stdinuse=0; +/* int lasthead=0; /* DEBUG */ + +#define constr_tag(x) hd[x] +#define idconstr_tag(x) hd[id_val(x)] +#define constr_name(x) (tag[tl[x]]==ID?get_id(tl[x]):get_id(pn_val(tl[x]))) +#define suppressed(x) (tag[tl[x]]==STRCONS&&tag[pn_val(tl[x])]!=ID) + /* suppressed constructor */ + +#define isodigit(x) ('0'<=(x) && (x)<='7') +#define sign(x) (x) +#define fsign(x) ((d=(x))<0?-1:d>0) +/* ### */ /* functions marked ### contain possibly recursive calls + to reduce - fix later */ + +compare(a,b) /* returns -1, 0, 1 as a is less than equal to or greater than + b in the ordering imposed on all data types by the miranda + language -- a and b already reduced */ + /* used by MATCH, EQ, NEQ, GR, GRE */ +word a,b; +{ double d; + L: switch(tag[a]) + { case DOUBLE: + if(tag[b]==DOUBLE)return(fsign(get_dbl(a)-get_dbl(b))); + else return(fsign(get_dbl(a)-bigtodbl(b))); + case INT: + if(tag[b]==INT)return(bigcmp(a,b)); + else return(fsign(bigtodbl(a)-get_dbl(b))); + case UNICODE: return sign(get_char(a)-get_char(b)); + case ATOM: + if(tag[b]==UNICODE) return sign(get_char(a)-get_char(b)); + if(S<=a&&a<=ERROR||S<=b&&b<=ERROR) + fn_error("attempt to compare functions"); + /* what about constructors - FIX LATER */ + if(tag[b]==ATOM)return(sign(a-b)); /* order of declaration */ + else return(-1); /* atomic object always less than non-atomic */ + case CONSTRUCTOR: + if(tag[b]==CONSTRUCTOR) + return(sign(constr_tag(a)-constr_tag(b))); /*order of declaration*/ + else return(-1); /* atom less than non-atom */ + case CONS: case AP: + if(tag[a]==tag[b]) + { word temp; + hd[a]=reduce(hd[a]); + hd[b]=reduce(hd[b]); + if((temp=compare(hd[a],hd[b]))!=0)return(temp); + a=tl[a]=reduce(tl[a]); + b=tl[b]=reduce(tl[b]); + goto L; } + else if(S<=b&&b<=ERROR)fn_error("attempt to compare functions"); + else return(1); /* non-atom greater than atom */ + default: fprintf(stderr,"\nghastly error in compare\n"); + } + return(0); +} + +force(x) /* ensures that x is evaluated "all the way" */ +word x; /* x is already reduced */ /* ### */ +{ word h; + switch(tag[x]) + { case AP: h=hd[x]; + while(tag[h]==AP)h=hd[h]; + if(S<=h&&h<=ERROR)return; /* don't go inside functions */ + /* what about unsaturated constructors? fix later */ + while(tag[x]==AP) + { tl[x]=reduce(tl[x]); + force(tl[x]); + x=hd[x]; } + return; + case CONS: while(tag[x]==CONS) + { hd[x]=reduce(hd[x]); + force(hd[x]); + x=tl[x]=reduce(tl[x]); } + } + return; +} + +head(x) /* finds the function part of x */ +word x; +{ while(tag[x]==AP)x= hd[x]; + return(x); +} + +extern char linebuf[]; /* used as workspace in various places */ + +/* ### */ /* opposite is str_conv - see lex.c */ +char *getstring(x,cmd) /* collect Miranda string - x is already reduced */ +word x; +char *cmd; /* context, for error message */ +{ word x1=x,n=0; + char *p=linebuf; + while(tag[x]==CONS&&n<BUFSIZE) + n++, hd[x] = reduce(hd[x]), x=tl[x]=reduce(tl[x]); + x=x1; + while(tag[x]==CONS&&n--) + *p++ = hd[x], x=tl[x]; + *p++ ='\0'; + if(p-linebuf>BUFSIZE) + { if(cmd)fprintf(stderr, + "\n%s, argument string too long (limit=%d chars): %s...\n", + cmd,BUFSIZE,linebuf), + outstats(), + exit(1); + else return(linebuf); /* see G_CLOSE */ } + return(linebuf); /* very inefficient to keep doing this for filenames etc. + CANNOT WE SUPPORT A PACKED REPRESENTATION OF STRINGS? */ +} /* call keep(linebuf) if you want to save the string */ + +FILE *s_out=NULL; /* destination of current output message */ + /* initialised in main() */ +#define Stdout 0 +#define Stderr 1 +#define Tofile 2 +#define Closefile 3 +#define Appendfile 4 +#define System 5 +#define Exit 6 +#define Stdoutb 7 +#define Tofileb 8 +#define Appendfileb 9 + /* order of declaration of constructors of these names in sys_message */ + +/* ### */ +output(e) /* "output" is called by YACC (see MIRANDA RULES) to print the + value of an expression - output then calls "reduce" - so the + whole reduction process is driven by the need to print */ + /* the value of the whole expression is a list of `messages' */ +word e; +{ + extern word *cstack; + cstack = &e; /* don't follow C stack below this in gc */ +L:e= reduce(e); + while(tag[e]==CONS) + { word d; + hd[e]= reduce(hd[e]); + switch(constr_tag(head(hd[e]))) + { case Stdout: print(tl[hd[e]]); + break; + case Stdoutb: UTF8OUT=0; + print(tl[hd[e]]); + UTF8OUT=UTF8; + break; + case Stderr: s_out=stderr; print(tl[hd[e]]); s_out=stdout; + break; + case Tofile: outf(hd[e]); + break; + case Tofileb: UTF8OUT=0; + outf(hd[e]); + UTF8OUT=UTF8; + break; + case Closefile: closefile(tl[hd[e]]=reduce(tl[hd[e]])); + break; + case Appendfile: apfile(tl[hd[e]]=reduce(tl[hd[e]])); + break; + case Appendfileb: UTF8OUT=0; + apfile(tl[hd[e]]=reduce(tl[hd[e]])); + UTF8OUT=UTF8; + break; + case System: system(getstring(tl[hd[e]]=reduce(tl[hd[e]]),"System")); + break; + case Exit: { word n=reduce(tl[hd[e]]); + if(tag[n]==INT)n=digit0(n); + else word_error("Exit"); + outstats(); exit(n); } + default: fprintf(stderr,"\n<impossible event in output list: "); + out(stderr,hd[e]); + fprintf(stderr,">\n"); } + e= tl[e]= reduce(tl[e]); + } + if(e==NIL)return; + fprintf(stderr,"\nimpossible event in output\n"), + putc('<',stderr),out(stderr,e),fprintf(stderr,">\n"); + exit(1); +} + +/* ### */ +print(e) /* evaluate list of chars and send to s_out */ +word e; +{ e= reduce(e); + while(tag[e]==CONS && is_char(hd[e]=reduce(hd[e]))) + { unsigned word c=get_char(hd[e]); + if(UTF8)outUTF8(c,s_out); else + if(c<256) putc(c,s_out); + else fprintf(stderr,"\n warning: non Latin1 char \%x in print, ignored\n",c); + e= tl[e]= reduce(tl[e]); } + if(e==NIL)return; + fprintf(stderr,"\nimpossible event in print\n"), + putc('<',stderr),out(stderr,e),fprintf(stderr,">\n"), + exit(1); +} + +word outfilq=NIL; /* list of opened-for-output files */ +/* note that this will be automatically reset to NIL and all files on it +closed at end of expression evaluation, because of the fork-exit structure */ + +/* ### */ +outf(e) /* e is of the form (Tofile f x) */ +word e; +{ word p=outfilq; /* have we already opened this file for output? */ + char *f=getstring(tl[hd[e]]=reduce(tl[hd[e]]),"Tofile"); + while(p!=NIL && strcmp((char *)hd[hd[p]],f)!=0)p=tl[p]; + if(p==NIL) /* new output file */ + { s_out= fopen(f,"w"); + if(s_out==NULL) + { fprintf(stderr,"\nTofile: cannot write to \"%s\"\n",f); + s_out=stdout; + return; + /* outstats(); exit(1); /* release one policy */ + } + if(isatty(fileno(s_out)))setbuf(s_out,NULL); /*for unbuffered tty output*/ + outfilq= cons(datapair(keep(f),s_out),outfilq); } + else s_out= (FILE *)tl[hd[p]]; + print(tl[e]); + s_out= stdout; +} + +apfile(f) /* open file of name f for appending and add to outfilq */ +word f; +{ word p=outfilq; /* is it already open? */ + char *fil=getstring(f,"Appendfile"); + while(p!=NIL && strcmp((char *)hd[hd[p]],fil)!=0)p=tl[p]; + if(p==NIL) /* no, so open in append mode */ + { FILE *s=fopen(fil,"a"); + if(s==NULL) + fprintf(stderr,"\nAppendfile: cannot write to \"%s\"\n",fil); + else outfilq= cons(datapair(keep(fil),s),outfilq); + } + /* if already there do nothing */ +} + +closefile(f) /* remove file of name "f" from outfilq and close stream */ +word f; +{ word *p= &outfilq; /* is this file open for output? */ + char *fil=getstring(f,"Closefile"); + while(*p!=NIL && strcmp((char *)hd[hd[*p]],fil)!=0)p= &tl[*p]; + if(*p!=NIL) /* yes */ + { fclose((FILE *)tl[hd[*p]]); + *p=tl[*p]; /* remove link from outfilq */} + /* otherwise ignore closefile request (harmless??) */ +} + +static word errtrap=0; /* to prevent error cycles - see ERROR below */ +word waiting=NIL; +/* list of terminated child processes with exit_status - see Exec/EXEC */ + +/* pointer-reversing SK reduction machine - based on code written Sep 83 */ + +#define BACKSTOP 020000000000 +#define READY(x) (x) +#define RESTORE(x) +/* in this machine the above two are no-ops, alternate definitions are, eg +#define READY(x) (x+1) +#define RESTORE(x) x-- +(if using this method each strict comb needs next opcode unallocated) + see comment before "ready" switch */ +#define FIELD word +#define tlptrbit 020000000000 +#define tlptrbits 030000000000 + /* warning -- if you change this tell `mark()' in data.c */ +#define mktlptr(x) x |= tlptrbit +#define mk1tlptr x |= tlptrbits +#define mknormal(x) x &= ~tlptrbits +#define abnormal(x) ((x)<0) +/* covers x is tlptr and x==BACKSTOP */ + +/* control abstractions */ + +#define setcell(t,a,b) tag[e]=t,hd[e]=a,tl[e]=b +#define DOWNLEFT hold=s, s=e, e=hd[e], hd[s]=hold +#define DOWNRIGHT hold=hd[s], hd[s]=e, e=tl[s], tl[s]=hold, mktlptr(s) +#define downright if(abnormal(s))goto DONE; DOWNRIGHT +#define UPLEFT hold=s, s=hd[s], hd[hold]=e, e=hold +#define upleft if(abnormal(s))goto DONE; UPLEFT +#define GETARG(a) UPLEFT, a=tl[e] +#define getarg(a) upleft; a=tl[e] +#define UPRIGHT mknormal(s), hold=tl[s], tl[s]=e, e=hd[s], hd[s]=hold +#define lastarg tl[e] +word reds=0; + +/* IMPORTANT WARNING - the macro's + `downright;' `upleft;' `getarg;' + MUST BE ENCLOSED IN BRACES when they occur as the body of a control + structure (if, while etc.) */ + +#define simpl(r) hd[e]=I, e=tl[e]=r + +#ifdef DEBUG +word maxrdepth=0,rdepth=0; +#endif + +#define fails(x) (x==NIL) +#define FAILURE NIL + /* used by grammar combinators */ + +/* reduce e to hnf, note that a function in hnf will have head h with + S<=h<=ERROR all combinators lie in this range see combs.h */ +FIELD reduce(e) +FIELD e; +{ FIELD s=BACKSTOP,hold,arg1,arg2,arg3; +#ifdef DEBUG + if(++rdepth>maxrdepth)maxrdepth=rdepth; + if(debug&02) + printf("reducing: "),out(stdout,e),putchar('\n'); +#endif + + NEXTREDEX: + while(!abnormal(e)&&tag[e]==AP)DOWNLEFT; +#ifdef HISTO + histo(e); +#endif +#ifdef DEBUG + if(debug&02) + { printf("head= "); + if(e==BACKSTOP)printf("BACKSTOP"); + else out(stdout,e); + putchar('\n'); } +#endif + + OPDECODE: +/*lasthead=e; /* DEBUG */ + cycles++; + switch(e) + { + case S: /* S f g x => f x(g x) */ + getarg(arg1); + getarg(arg2); + upleft; + hd[e]=ap(arg1,lastarg); tl[e]=ap(arg2,lastarg); + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case B: /* B f g x => f(g z) */ + getarg(arg1); + getarg(arg2); + upleft; + hd[e]=arg1; tl[e]=ap(arg2,lastarg); + DOWNLEFT; + goto NEXTREDEX; + + case CB: /* CB f g x => g(f z) */ + getarg(arg1); + getarg(arg2); + upleft; + hd[e]=arg2; tl[e]=ap(arg1,lastarg); + DOWNLEFT; + goto NEXTREDEX; + + case C: /* C f g x => f x g */ + getarg(arg1); + getarg(arg2); + upleft; + hd[e]=ap(arg1,lastarg); tl[e]=arg2; + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case Y: /* Y h => self where self=(h self) */ + upleft; + hd[e]=tl[e]; tl[e]=e; + DOWNLEFT; + goto NEXTREDEX; + + L_K: + case K: /* K x y => x */ + getarg(arg1); + upleft; + hd[e]=I; e=tl[e]=arg1; + goto NEXTREDEX; /* could make eager in first arg */ + + L_KI: + case KI: /* KI x y => y */ + upleft; /* lose first arg */ + upleft; + hd[e]=I; e=lastarg; /* ?? */ + goto NEXTREDEX; /* could make eager in 2nd arg */ + + case S1: /* S1 k f g x => k(f x)(g x) */ + getarg(arg1); + getarg(arg2); + getarg(arg3); + upleft; + hd[e]=ap(arg2,lastarg); + hd[e]=ap(arg1,hd[e]); + tl[e]=ap(arg3,lastarg); + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case B1: /* B1 k f g x => k(f(g x)) */ + getarg(arg1); /* Mark Scheevel's new B1 */ + getarg(arg2); + getarg(arg3); + upleft; + hd[e]=arg1; + tl[e]=ap(arg3,lastarg); + tl[e]=ap(arg2,tl[e]); + DOWNLEFT; + goto NEXTREDEX; + + case C1: /* C1 k f g x => k(f x)g */ + getarg(arg1); + getarg(arg2); + getarg(arg3); + upleft; + hd[e]=ap(arg2,lastarg); + hd[e]=ap(arg1,hd[e]); + tl[e]=arg3; + DOWNLEFT; + goto NEXTREDEX; + + case S_p: /* S_p f g x => (f x) : (g x) */ + getarg(arg1); + getarg(arg2); + upleft; + setcell(CONS,ap(arg1,lastarg),ap(arg2,lastarg)); + goto DONE; + + case B_p: /* B_p f g x => f : (g x) */ + getarg(arg1); + getarg(arg2); + upleft; + setcell(CONS,arg1,ap(arg2,lastarg)); + goto DONE; + + case C_p: /* C_p f g x => (f x) : g */ + getarg(arg1); + getarg(arg2); + upleft; + setcell(CONS,ap(arg1,lastarg),arg2); + goto DONE; + + case ITERATE: /* ITERATE f x => x:ITERATE f (f x) */ + getarg(arg1); + upleft; + hold=ap(hd[e],ap(arg1,lastarg)); + setcell(CONS,lastarg,hold); + goto DONE; + + case ITERATE1: /* ITERATE1 f x => [], x=FAIL + => x:ITERATE1 f (f x), otherwise */ + getarg(arg1); + upleft; + if((lastarg=reduce(lastarg))==FAIL) /* ### */ + { hd[e]=I; e=tl[e]=NIL; } + else + { hold=ap(hd[e],ap(arg1,lastarg)); + setcell(CONS,lastarg,hold); } + goto DONE; + + case G_RULE: + case P: /* P x y => x:y */ + getarg(arg1); + upleft; + setcell(CONS,arg1,lastarg); + goto DONE; + + case U: /* U f x => f (HD x) (TL x) + non-strict uncurry */ + getarg(arg1); + upleft; + hd[e]=ap(arg1,ap(HD,lastarg)); + tl[e]=ap(TL,lastarg); + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case Uf: /* Uf f x => f (BODY x) (LAST x) + version of non-strict U for + arbitrary constructors */ + getarg(arg1); + upleft; + if(tag[head(lastarg)]==CONSTRUCTOR) /* be eager if safe */ + hd[e]=ap(arg1,hd[lastarg]), + tl[e]=tl[lastarg]; + else + hd[e]=ap(arg1,ap(BODY,lastarg)), + tl[e]=ap(LAST,lastarg); + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case ATLEAST: /* ATLEAST k f x => f(x-k), isnat x & x>=k + => FAIL, otherwise */ + /* for matching n+k patterns */ + getarg(arg1); + getarg(arg2); + upleft; + lastarg= reduce(lastarg); /* ### */ + if(tag[lastarg]==INT) + { hold = bigsub(lastarg,arg1); + if(poz(hold))hd[e]=arg2,tl[e]=hold; + else hd[e]=I,e=tl[e]=FAIL; } + else hd[e]=I,e=tl[e]=FAIL; + goto NEXTREDEX; + + case U_: /* U_ f (a:b) => f a b + U_ f other => FAIL + U_ is a strict version of U(see above) */ + getarg(arg1); + upleft; + lastarg= reduce(lastarg); /* ### */ + if(lastarg==NIL) + { hd[e]=I; + e=tl[e]=FAIL; + goto NEXTREDEX; } + hd[e]=ap(arg1,hd[lastarg]); + tl[e]=tl[lastarg]; + goto NEXTREDEX; + + case Ug: /* Ug k f (k x1 ... xn) => f x1 ... xn, n>=0 + Ug k f other => FAIL + Ug is a strict version of U for arbitrary constructor k */ + getarg(arg1); + getarg(arg2); + upleft; + lastarg= reduce(lastarg); /* ### */ + if(constr_tag(arg1)!=constr_tag(head(lastarg))) + { hd[e]=I; + e=tl[e]=FAIL; + goto NEXTREDEX; } + if(tag[lastarg]==CONSTRUCTOR) /* case n=0 */ + { hd[e]=I; e=tl[e]=arg2; goto NEXTREDEX; } + hd[e]=hd[lastarg]; + tl[e]=tl[lastarg]; + while(tag[hd[e]]!=CONSTRUCTOR) + /* go back to head of arg3, copying spine */ + { hd[e]=ap(hd[hd[e]],tl[hd[e]]); + DOWNLEFT; } + hd[e]=arg2; /* replace k with f */ + goto NEXTREDEX; + + case MATCH: /* MATCH a f a => f + MATCH a f b => FAIL */ + upleft; + arg1=lastarg=reduce(lastarg); /* ### */ + /* note that MATCH evaluates arg1, usually needless, could have second + version - MATCHEQ, say */ + getarg(arg2); + upleft; + lastarg=reduce(lastarg); /* ### */ + hd[e]=I; + e=tl[e]=compare(arg1,lastarg)?FAIL:arg2; + goto NEXTREDEX; + + case MATCHINT: /* same but 1st arg is integer literal */ + getarg(arg1); + getarg(arg2); + upleft; + lastarg=reduce(lastarg); /* ### */ + hd[e]=I; + e=tl[e]=(tag[lastarg]!=INT||bigcmp(arg1,lastarg))?FAIL:arg2; + /* note no coercion from INT to DOUBLE here */ + goto NEXTREDEX; + + case GENSEQ: /* GENSEQ (i,NIL) a => a:GENSEQ (i,NIL) (a+i) + GENSEQ (i,b) a => [], a>b=sign + => a:GENSEQ (i,b) (a+i), otherwise + where + sign = 1, i>=0 + = -1, otherwise */ + GETARG(arg1); + UPLEFT; + if(tl[arg1]!=NIL&& + (tag[arg1]==AP?compare(lastarg,tl[arg1]):compare(tl[arg1],lastarg))>0) + hd[e]=I, e=tl[e]=NIL; + else hold=ap(hd[e],numplus(lastarg,hd[arg1])), + setcell(CONS,lastarg,hold); + goto DONE; + /* efficiency hack - tag of arg1 encodes sign of step */ + + case MAP: /* MAP f [] => [] + MAP f (a:x) => f a : MAP f x */ + getarg(arg1); + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + hd[e]=I, e=tl[e]=NIL; + else hold=ap(hd[e],tl[lastarg]), + setcell(CONS,ap(arg1,hd[lastarg]),hold); + goto DONE; + + case FLATMAP: /* funny version of map for compiling zf exps + FLATMAP f [] => [] + FLATMAP f (a:x) => FLATMAP f x, f a=FAIL + => f a ++ FLATMAP f x + (FLATMAP was formerly called MAP1) */ + getarg(arg1); + getarg(arg2); + L1:arg2=reduce(arg2); /* ### */ + if(arg2==NIL) + { hd[e]=I; + e=tl[e]=NIL; + goto DONE; } + hold=reduce(hold=ap(arg1,hd[arg2])); + if(hold==FAIL||hold==NIL){ arg2=tl[arg2]; goto L1; } + tl[e]=ap(hd[e],tl[arg2]); + hd[e]=ap(APPEND,hold); + goto NEXTREDEX; + + case FILTER: /* FILTER f [] => [] + FILTER f (a:x) => a : FILTER f x, f a + => FILTER f x, otherwise */ + getarg(arg1); + upleft; + lastarg=reduce(lastarg); /* ### */ + while(lastarg!=NIL&&reduce(ap(arg1,hd[lastarg]))==False) /* ### */ + lastarg=reduce(tl[lastarg]); /* ### */ + if(lastarg==NIL) + hd[e]=I, e=tl[e]=NIL; + else hold=ap(hd[e],tl[lastarg]), + setcell(CONS,hd[lastarg],hold); + goto DONE; + + case LIST_LAST: /* LIST_LAST x => x!(#x-1) */ + upleft; + if((lastarg=reduce(lastarg))==NIL)fn_error("last []"); /* ### */ + while((tl[lastarg]=reduce(tl[lastarg]))!=NIL) /* ### */ + lastarg=tl[lastarg]; + hd[e]=I; e=tl[e]=hd[lastarg]; + goto NEXTREDEX; + + case LENGTH: /* takes length of a list */ + upleft; + { long long n=0; /* problem - may be followed by gc */ + /* cannot make static because of ### below */ + while((lastarg=reduce(lastarg))!=NIL) /* ### */ + lastarg=tl[lastarg],n++; + simpl(sto_word(n)); } + goto DONE; + + case DROP: + getarg(arg1); + upleft; + arg1=tl[hd[e]]=reduce(tl[hd[e]]); /* ### */ + if(tag[arg1]!=INT)word_error("drop"); + { long long n=get_word(arg1); + while(n-- >0) + if((lastarg=reduce(lastarg))==NIL) /* ### */ + { simpl(NIL); goto DONE; } + else lastarg=tl[lastarg]; } + simpl(lastarg); + goto NEXTREDEX; + + case SUBSCRIPT: /* SUBSCRIPT i x => x!i */ + upleft; + upleft; + arg1=tl[hd[e]]=reduce(tl[hd[e]]); /* ### */ + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL)subs_error(); + { long long indx = tag[arg1]==ATOM?arg1:/* small indexes represented directly */ + tag[arg1]==INT?get_word(arg1): + word_error("!"); + /* problem, indx may be followed by gc + - cannot make static, because of ### below */ + if(indx<0)subs_error(); + while(indx) + { lastarg= tl[lastarg]= reduce(tl[lastarg]); /* ### */ + if(lastarg==NIL)subs_error(); + indx--; } + hd[e]= I; + e=tl[e]=hd[lastarg]; /* could be eager in tl[e] */ + goto NEXTREDEX; } + + case FOLDL1: /* FOLDL1 op (a:x) => FOLDL op a x */ + getarg(arg1); + upleft; + if((lastarg=reduce(lastarg))!=NIL) /* ### */ + { hd[e]=ap2(FOLDL,arg1,hd[lastarg]); + tl[e]=tl[lastarg]; + goto NEXTREDEX; } + else fn_error("foldl1 applied to []"); + + case FOLDL: /* FOLDL op r [] => r + FOLDL op r (a:x) => FOLDL op (op r a)^ x + + ^ (FOLDL op) is made strict in 1st param */ + getarg(arg1); + getarg(arg2); + upleft; + while((lastarg=reduce(lastarg))!=NIL) /* ### */ + arg2=reduce(ap2(arg1,arg2,hd[lastarg])), /* ^ ### */ + lastarg=tl[lastarg]; + hd[e]=I, e=tl[e]=arg2; + goto NEXTREDEX; + + case FOLDR: /* FOLDR op r [] => r + FOLDR op r (a:x) => op a (FOLDR op r x) */ + getarg(arg1); + getarg(arg2); + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + hd[e]=I, e=tl[e]=arg2; + else hold=ap(hd[e],tl[lastarg]), + hd[e]=ap(arg1,hd[lastarg]), tl[e]=hold; + goto NEXTREDEX; + + L_READBIN: + case READBIN: /* READBIN streamptr => nextchar : READBIN streamptr + if end of file, READBIN file => NIL + READBIN does no UTF-8 conversion */ + UPLEFT; /* gc insecurity - arg is not a heap object */ + if(lastarg==0) /* special case created by $:- */ + { if(stdinuse=='-')stdin_error(':'); + if(stdinuse) + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + stdinuse=':'; + tl[e]=(word)stdin; } + hold= getc((FILE *)lastarg); + if(hold==EOF) + { fclose((FILE *)lastarg); + hd[e]=I; + e=tl[e]= NIL; + goto DONE; } + setcell(CONS,hold,ap(READBIN,lastarg)); + goto DONE; + + L_READ: + case READ: /* READ streamptr => nextchar : READ streamptr + if end of file, READ file => NIL + does UTF-8 conversion where appropriate */ + UPLEFT; /* gc insecurity - arg is not a heap object */ + if(lastarg==0) /* special case created by $- */ + { if(stdinuse==':')stdin_error('-'); + if(stdinuse) + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + stdinuse='-'; + tl[e]=(word)stdin; } + hold=UTF8?sto_char(fromUTF8((FILE *)lastarg)):getc((FILE *)lastarg); + if(hold==EOF) + { fclose((FILE *)lastarg); + hd[e]=I; + e=tl[e]= NIL; + goto DONE; } + setcell(CONS,hold,ap(READ,lastarg)); + goto DONE; + + L_READVALS: + case READVALS: /* READVALS (t:fil) f => [], EOF from FILE *f + => val : READVALS t f, otherwise + where val is obtained by parsing lines of + f, and taking next legal expr of type t */ + GETARG(arg1); + upleft; + hold=parseline(hd[arg1],(FILE *)lastarg,tl[arg1]); + if(hold==EOF) + { fclose((FILE *)lastarg); + hd[e]=I; + e=tl[e]= NIL; + goto DONE; } + arg2=ap(hd[e],lastarg); + setcell(CONS,hold,arg2); + goto DONE; + + case BADCASE: /* BADCASE cons(oldn,here_info) => BOTTOM */ + UPLEFT; + { extern word sourcemc; + word subject= hd[lastarg]; + /* either datapair(oldn,0) or 0 */ + fprintf(stderr,"\nprogram error: missing case in definition"); + if(subject) /* cannot do patterns - FIX LATER */ + fprintf(stderr," of %s",(char *)hd[subject]); + putc('\n',stderr); + out_here(stderr,tl[lastarg],1); + /* if(sourcemc&&nargs>1) + { int i=2; + fprintf(stderr,"arg%s = ",nargs>2?"s":""); + while(i<=nargs)out(stderr,tl[stackp[-(i++)]]),putc(' ',stderr); + putc('\n',stderr); } /* fix later */ + } + outstats(); + exit(1); + + case GETARGS: /* GETARGS 0 => argv ||`$*' = command line args */ + UPLEFT; + simpl(conv_args()); + goto DONE; + + case CONFERROR: /* CONFERROR error_info => BOTTOM */ + /* if(nargs<1)fprintf(stderr,"\nimpossible event in reduce\n"), + exit(1); */ + UPLEFT; + fprintf(stderr,"\nprogram error: lhs of definition doesn't match rhs"); + /*fprintf(stderr," OF "); + out_formal1(stderr,hd[lastarg]); /* omit - names may have been aliased */ + putc('\n',stderr); + out_here(stderr,tl[lastarg],1); + outstats(); + exit(1); + + case ERROR: /* ERROR error_info => BOTTOM */ + upleft; + if(errtrap)fprintf(stderr,"\n(repeated error)\n"); + else { errtrap=1; + fprintf(stderr,"\nprogram error: "); + s_out=stderr; + print(lastarg); /* ### */ + putc('\n',stderr); } + outstats(); + exit(1); + + case WAIT: /* WAIT pid => <exit_status of child process pid> */ + UPLEFT; + { word *w= &waiting; /* list of terminated pid's and their exit statuses */ + while(*w!=NIL&&hd[*w]!=lastarg)w= &tl[tl[*w]]; + if(*w!=NIL)hold=hd[tl[*w]], + *w=tl[tl[*w]]; /* remove entry */ + else { word status; + while((hold=wait(&status))!=lastarg&&hold!= -1) + waiting=cons(hold,cons(WEXITSTATUS(status),waiting)); + if(hold!= -1)hold=WEXITSTATUS(status); }} + simpl(stosmallint(hold)); + goto DONE; + + L_I: +/* case MONOP: (all strict monadic operators share this code) */ + case I: /* we treat I as strict to avoid I-chains (MOD1) */ + case SEQ: + case FORCE: + case HD: + case TL: + case BODY: + case LAST: + case EXEC: + case FILEMODE: + case FILESTAT: + case GETENV: + case INTEGER: + case NUMVAL: + case TAKE: + case STARTREAD: + case STARTREADBIN: + case NB_STARTREAD: + case COND: + case APPEND: + case AND: + case OR: + case NOT: + case NEG: + case CODE: + case DECODE: + case SHOWNUM: + case SHOWHEX: + case SHOWOCT: + case ARCTAN_FN: /* ...FN are strict functions of one numeric arg */ + case EXP_FN: + case ENTIER_FN: + case LOG_FN: + case LOG10_FN: + case SIN_FN: + case COS_FN: + case SQRT_FN: + downright; /* subtask -- reduce arg */ + goto NEXTREDEX; + + case TRY: /* TRY f g x => TRY(f x)(g x) */ + getarg(arg1); + getarg(arg2); + while(!abnormal(s)) + { UPLEFT; + hd[e]=ap(TRY,arg1=ap(arg1,lastarg)); + arg2=tl[e]=ap(arg2,lastarg); } + DOWNLEFT; + /* DOWNLEFT; DOWNRIGHT; equivalent to:*/ + hold=s,s=e,e=tl[e],tl[s]=hold,mktlptr(s); /* now be strict in arg1 */ + goto NEXTREDEX; + + case FAIL: /* FAIL x => FAIL */ + while(!abnormal(s))hold=s,s=hd[s],hd[hold]=FAIL,tl[hold]=0; + goto DONE; + +/* case DIOP: (all strict diadic operators share this code) */ + case ZIP: + case STEP: + case EQ: + case NEQ: + case PLUS: + case MINUS: + case TIMES: + case INTDIV: + case FDIV: + case MOD: + case GRE: + case GR: + case POWER: + case SHOWSCALED: + case SHOWFLOAT: + case MERGE: + upleft; + downright; /* first subtask -- reduce arg2 */ + goto NEXTREDEX; + + case Ush: /* strict in three args */ + case STEPUNTIL: + upleft; + upleft; + downright; + goto NEXTREDEX; /* first subtask -- reduce arg3 */ + + case Ush1: /* non-strict version of Ush */ + /* Ush1 (k f1...fn) p stuff + => "k"++' ':f1 x1 ...++' ':fn xn, p='\0' + => "(k"++' ':f1 x1 ...++' ':fn xn++")", p='\1' + where xi = LAST(BODY^(n-i) stuff) */ + getarg(arg1); + arg1=reduce(arg1); /* ### */ + getarg(arg2); + arg2=reduce(arg2); /* ### */ + getarg(arg3); + if(tag[arg1]==CONSTRUCTOR) /* don't parenthesise atom */ + { hd[e]=I; + if(suppressed(arg1)) + e=tl[e]=str_conv("<unprintable>"); + else e=tl[e]=str_conv(constr_name(arg1)); + goto DONE; } + hold=arg2?cons(')',NIL):NIL; + while(tag[arg1]!=CONSTRUCTOR) + hold=cons(' ',ap2(APPEND,ap(tl[arg1],ap(LAST,arg3)),hold)), + arg1=hd[arg1],arg3=ap(BODY,arg3); + if(suppressed(arg1)) + { hd[e]=I; e=tl[e]=str_conv("<unprintable>"); goto DONE; } + hold=ap2(APPEND,str_conv(constr_name(arg1)),hold); + if(arg2) + { setcell(CONS,'(',hold); goto DONE; } + else { hd[e]=I; e=tl[e]=hold; goto NEXTREDEX; } + + case MKSTRICT: /* MKSTRICT k f x1 ... xk => f x1 ... xk, xk~=BOT */ + GETARG(arg1); + getarg(arg2); + { word i=arg1; + while(i--) { upleft; } } + lastarg=reduce(lastarg); /* ### */ + while(--arg1) /* go back towards head, copying spine */ + { hd[e]=ap(hd[hd[e]],tl[hd[e]]); + DOWNLEFT;} + hd[e]=arg2; /* overwrite (MKSTRICT k f) with f */ + goto NEXTREDEX; + + case G_ERROR: /* G_ERROR f g toks = (g residue):[], fails(f toks) + = f toks, otherwise */ + GETARG(arg1); + GETARG(arg2); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(!fails(hold)) + { hd[e]=I; e=tl[e]=hold; goto DONE; } + hold=g_residue(lastarg); + setcell(CONS,ap(arg2,hold),NIL); + goto DONE; + + case G_ALT: /* G_ALT f g toks = f toks, !fails(f toks) + = g toks, otherwise */ + GETARG(arg1); + GETARG(arg2); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(!fails(hold)) + { hd[e]=I; e=tl[e]=hold; goto DONE; } + hd[e]=arg2; + DOWNLEFT; + goto NEXTREDEX; + + case G_OPT: /* G_OPT f toks = []:toks, fails(f toks) + = [a]:toks', otherwise + where + a:toks' = f toks */ + GETARG(arg1); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(fails(hold)) + setcell(CONS,NIL,lastarg); + else setcell(CONS,cons(hd[hold],NIL),tl[hold]); + goto DONE; + + case G_STAR: /* G_STAR f toks => []:toks, fails(f toks) + => ((a:FST z):SND z) + where + a:toks' = f toks + z = G_STAR f toks' + */ + GETARG(arg1); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(fails(hold)) + { setcell(CONS,NIL,lastarg); goto DONE; } + arg2=ap(hd[e],tl[hold]); /* called z in above rules */ + tag[e]=CONS;hd[e]=cons(hd[hold],ap(FST,arg2));tl[e]=ap(SND,arg2); + goto DONE; + + /* G_RULE has same action as P */ + + case G_FBSTAR: /* G_FBSTAR f toks + = I:toks, if fails(f toks) + = G_SEQ (G_FBSTAR f) (G_RULE (CB a)) toks', otherwise + where a:toks' = f toks + */ + GETARG(arg1); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(fails(hold)) + { setcell(CONS,I,lastarg); goto DONE; } + hd[e]=ap2(G_SEQ,hd[e],ap(G_RULE,ap(CB,hd[hold]))); tl[e]=tl[hold]; + goto NEXTREDEX; + + case G_SYMB: /* G_SYMB t ((t,s):toks) = t:toks + G_SYMB t toks = FAILURE */ + GETARG(arg1); /* will be in NF */ + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + { hd[e]=I,e=tl[e]=NIL; goto DONE; } + hd[lastarg]=reduce(hd[lastarg]); /* ### */ + hold=ap(FST,hd[lastarg]); + if(compare(arg1,reduce(hold))) /* ### */ + hd[e]=I,e=tl[e]=FAILURE; + else setcell(CONS,arg1,tl[lastarg]); + goto DONE; + + case G_ANY: /* G_ANY ((t,s):toks) = t:toks + G_ANY [] = FAILURE */ + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + hd[e]=I,e=tl[e]=FAILURE; + else setcell(CONS,ap(FST,hd[lastarg]),tl[lastarg]); + goto DONE; + + case G_SUCHTHAT: /* G_SUCHTHAT f ((t,s):toks) = t:toks, f t + G_SUCHTHAT f toks = FAILURE */ + GETARG(arg1); + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + { hd[e]=I,e=tl[e]=FAILURE; goto DONE; } + hold=ap(FST,hd[lastarg]); + hold=reduce(hold); /* ### */ + if(reduce(ap(arg1,hold))==True) /* ### */ + setcell(CONS,hold,tl[lastarg]); + else hd[e]=I,e=tl[e]=FAILURE; + goto DONE; + + + case G_END: /* G_END [] = []:[] + G_END other = FAILURE */ + upleft; + lastarg=reduce(lastarg); + if(lastarg==NIL) + setcell(CONS,NIL,NIL); + else hd[e]=I,e=tl[e]=FAILURE; + goto DONE; + + case G_STATE: /* G_STATE ((t,s):toks) = s:((t,s):toks) + G_STATE [] = FAILURE */ + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==NIL) + hd[e]=I,e=tl[e]=FAILURE; + else setcell(CONS,ap(SND,hd[lastarg]),lastarg); + goto DONE; + + case G_SEQ: /* G_SEQ f g toks = FAILURE, fails(f toks) + = FAILURE, fails(g toks') + = b a:toks'', otherwise + where + a:toks' = f toks + b:toks'' = g toks' */ + GETARG(arg1); + GETARG(arg2); + upleft; + hold=ap(arg1,lastarg); + hold=reduce(hold); /* ### */ + if(fails(hold)) + { hd[e]=I,e=tl[e]=FAILURE; goto DONE; } + arg3=ap(arg2,tl[hold]); + arg3=reduce(arg3); /* ### */ + if(fails(arg3)) + { hd[e]=I,e=tl[e]=FAILURE; goto DONE; } + setcell(CONS,ap(hd[arg3],hd[hold]),tl[arg3]); + goto DONE; + + case G_UNIT: /* G_UNIT toks => I:toks */ + upleft; + tag[e]=CONS,hd[e]=I; + goto DONE; + /* G_UNIT is right multiplicative identity, equivalent (G_RULE I) */ + + case G_ZERO: /* G_ZERO toks => FAILURE */ + upleft; + simpl(FAILURE); + goto DONE; + /* G_ZERO is left additive identity */ + + case G_CLOSE: /* G_CLOSE s f toks = <error s>, fails(f toks') + = <error s>, toks'' ~= NIL + = a, otherwise + where + toks' = G_COUNT toks + a:toks'' = f toks' */ + GETARG(arg1); + GETARG(arg2); + upleft; + arg3=ap(G_COUNT,lastarg); + hold=ap(arg2,arg3); + hold=reduce(hold); /* ### */ + if(fails(hold) /* ||(tl[hold]=reduce(tl[hold]))!=NIL /* ### */ + ) /* suppress to make parsers lazy by default 13/12/90 */ + { fprintf(stderr,"\nPARSE OF %sFAILS WITH UNEXPECTED ", + getstring(arg1,0)); + arg3=reduce(tl[g_residue(arg3)]); + if(arg3==NIL) + fprintf(stderr,"END OF INPUT\n"), + outstats(), + exit(1); + hold=ap(FST,hd[arg3]); + hold=reduce(hold); + fprintf(stderr,"TOKEN \""); + if(hold==OFFSIDE)fprintf(stderr,"offside"); /* not now possible */ + { char *p=getstring(hold,0); + while(*p)fprintf(stderr,"%s",charname(*p++)); } + fprintf(stderr,"\"\n"); + outstats(); + exit(1); } + hd[e]=I,e=tl[e]=hd[hold]; + goto NEXTREDEX; +/* NOTE the atom OFFSIDE differs from every string and is used as a + pseudotoken when implementing the offside rule - see `indent' in prelude */ + + case G_COUNT: /* G_COUNT NIL => NIL + G_COUNT (t:toks) => t:G_COUNT toks */ + /* G_COUNT is an identity operation on lists - its purpose is to mark + last token examined, for syntax error location purposes */ + upleft; + if((lastarg=reduce(lastarg))==NIL) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + setcell(CONS,hd[lastarg],ap(G_COUNT,tl[lastarg])); + goto DONE; + +/* Explanation of %lex combinators. A lex analyser is of type + + lexer == [char] -> [alpha] + + At top level these are of the form (LEX_RPT f) where f is of type + + lexer1 == startcond -> [char] -> (alpha,startcond,[char]) + + A lexer1 is guaranteed to return a triple (if it returns at all...) + and is built using LEX_TRY. + + LEX_TRY [(scstuff,(matcher [],rule))*] :: lexer1 + rule :: [char] -> alpha + matcher :: partial_match -> input -> {(alpha,input') | []} + + partial_match and input are both [char] and [] represents failure. + The other lex combinators - LEX_SEQ, LEX_OR, LEX_CLASS etc., all + create and combine objects of type matcher. + + LEX_RPT1 is a deviant version that labels the input characters + with their lexical state (row,col) using LEX_COUNT - goes with + LEX_TRY1 which feeds the leading state of input to each rule. + +*/ + + case LEX_RPT1: /* LEX_RPT1 f s x => LEX_RPT f s (LEX_COUNT0 x) + i.e. LEX_RPT1 f s => B (LEX_RPT f s) LEX_COUNT0 + */ + GETARG(arg1); + UPLEFT; + hd[e]=ap(B,ap2(LEX_RPT,arg1,lastarg)); tl[e]=LEX_COUNT0; + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case LEX_RPT: /* LEX_RPT f s [] => [] + LEX_RPT f s x => a : LEX_RPT f s' y + where + (a,s',y) = f s x + note that if f returns a result it is + guaranteed to be a triple + */ + GETARG(arg1); + GETARG(arg2); + upleft; + if((lastarg=reduce(lastarg))==NIL) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + hold=ap2(arg1,arg2,lastarg); + arg1=hd[hd[e]]; + hold=reduce(hold); + setcell(CONS,hd[hold],ap2(arg1,hd[tl[hold]],tl[tl[hold]])); + goto DONE; + + case LEX_TRY: + upleft; + tl[e]=reduce(tl[e]); /* ### */ + force(tl[e]); + hd[e]=LEX_TRY_; + DOWNLEFT; + /* falls thru to next case */ + + case LEX_TRY_: + /* LEX_TRY ((scstuff,(f,rule)):alt) s x => LEX_TRY alt s x, if f x = [] + => (rule (rev a),s,y), otherwise + where + (a,y) = f x + LEX_TRY [] s x => BOTTOM + */ + GETARG(arg1); + GETARG(arg2); + upleft; +L2: if(arg1==NIL)lexfail(lastarg); + if(hd[hd[hd[arg1]]]&&!member(hd[hd[hd[arg1]]],arg2)) + { arg1=tl[arg1]; goto L2; } /* hd[scstuff] is 0 or list of startconds */ + hold=ap(hd[tl[hd[arg1]]],lastarg); + if((hold=reduce(hold))==NIL) /* ### */ + { arg1=tl[arg1]; goto L2; } + setcell(CONS,ap(tl[tl[hd[arg1]]],ap(DESTREV,hd[hold])), + cons(tl[hd[hd[arg1]]]?tl[hd[hd[arg1]]]-1:arg2,tl[hold])); + /* tl[scstuff] is 1 + next start condition (0 = no change) */ + goto DONE; + + case LEX_TRY1: + upleft; + tl[e]=reduce(tl[e]); /* ### */ + force(tl[e]); + hd[e]=LEX_TRY1_; + DOWNLEFT; + /* falls thru to next case */ + + case LEX_TRY1_: + /* LEX_TRY1 ((scstuff,(f,rule)):alt) s x => LEX_TRY1 alt s x, if f x = [] + => (rule n (rev a),s,y), otherwise + where + (a,y) = f x + n = lexstate(x) + ||same as LEX_TRY but feeds lexstate to rule + */ + GETARG(arg1); + GETARG(arg2); + upleft; +L3: if(arg1==NIL)lexfail(lastarg); + if(hd[hd[hd[arg1]]]&&!member(hd[hd[hd[arg1]]],arg2)) + { arg1=tl[arg1]; goto L3; } /* hd[scstuff] is 0 or list of startconds */ + hold=ap(hd[tl[hd[arg1]]],lastarg); + if((hold=reduce(hold))==NIL) /* ### */ + { arg1=tl[arg1]; goto L3; } + setcell(CONS,ap2(tl[tl[hd[arg1]]],lexstate(lastarg),ap(DESTREV,hd[hold])), + cons(tl[hd[hd[arg1]]]?tl[hd[hd[arg1]]]-1:arg2,tl[hold])); + /* tl[scstuff] is 1 + next start condition (0 = no change) */ + goto DONE; + + case DESTREV: /* destructive reverse - used only by LEX_TRY */ + GETARG(arg1); /* known to be an explicit list */ + arg2=NIL; /* to hold reversed list */ + while(arg1!=NIL) + { if(tag[hd[arg1]]==STRCONS) /* strip off lex state if present */ + hd[arg1]=tl[hd[arg1]]; + hold=tl[arg1],tl[arg1]=arg2,arg2=arg1,arg1=hold; } + hd[e]=I; e=tl[e]=arg2; + goto DONE; + + case LEX_COUNT0: /* LEX_COUNT0 x => LEX_COUNT (state0,x) */ + upleft; + hd[e]=LEX_COUNT; tl[e]=strcons(0,tl[e]); + DOWNLEFT; + /* falls thru to next case */ + + case LEX_COUNT: /* LEX_COUNT (state,[]) => [] + LEX_COUNT (state,(a:x)) => (state,a):LEX_COUNT(state',a) + where + state == (line_no*256+col_no) + */ + GETARG(arg1); + if((tl[arg1]=reduce(tl[arg1]))==NIL) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + hold=hd[tl[arg1]]; /* the char */ + setcell(CONS,strcons(hd[arg1],hold),ap(LEX_COUNT,arg1)); + if(hold=='\n')hd[arg1]=(hd[arg1]>>8)+1<<8; + else { word col = hd[arg1]&255; + col = hold=='\t'?(col/8+1)*8:col+1; + hd[arg1] = hd[arg1]&(~255)|col; } + tl[arg1]=tl[tl[arg1]]; + goto DONE; + +#define lh(x) (tag[hd[x]]==STRCONS?tl[hd[x]]:hd[x]) + /* hd char of possibly lex-state-labelled string */ + + case LEX_STRING: /* LEX_STRING [] p x => p : x + LEX_STRING (c:s) p (c:x) => LEX_STRING s (c:p) x + LEX_STRING (c:s) p other => [] + */ + GETARG(arg1); + GETARG(arg2); + upleft; + while(arg1!=NIL) + { if((lastarg=reduce(lastarg))==NIL||lh(lastarg)!=hd[arg1]) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + arg1=tl[arg1]; arg2=cons(hd[lastarg],arg2); lastarg=tl[lastarg]; } + tag[e]=CONS; hd[e]=arg2; + goto DONE; + + case LEX_CLASS: /* LEX_CLASS set p (c:x) => (c:p) : x, if c in set + LEX_CLASS set p x => [], otherwise + */ + GETARG(arg1); + GETARG(arg2); + upleft; + if((lastarg=reduce(lastarg))==NIL|| /* ### */ + (hd[arg1]==ANTICHARCLASS?memclass(lh(lastarg),tl[arg1]) + :!memclass(lh(lastarg),arg1)) + ) + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + setcell(CONS,cons(hd[lastarg],arg2),tl[lastarg]); + goto DONE; + + case LEX_DOT: /* LEX_DOT p (c:x) => (c:p) : x + LEX_DOT p [] => [] + */ + GETARG(arg1); + upleft; + if((lastarg=reduce(lastarg))==NIL) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + setcell(CONS,cons(hd[lastarg],arg1),tl[lastarg]); + goto DONE; + + case LEX_CHAR: /* LEX_CHAR c p (c:x) => (c:p) : x + LEX_CHAR c p x => [] + */ + GETARG(arg1); + GETARG(arg2); + upleft; + if((lastarg=reduce(lastarg))==NIL||lh(lastarg)!=arg1) /* ### */ + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + setcell(CONS,cons(arg1,arg2),tl[lastarg]); + goto DONE; + + case LEX_SEQ: /* LEX_SEQ f g p x => [], if f p x = [] + => g q y, otherwise + where + (q,y) = f p x + */ + GETARG(arg1); + GETARG(arg2); + GETARG(arg3); + upleft; + hold=ap2(arg1,arg3,lastarg); + lastarg=NIL; /* anti-dragging measure */ + if((hold=reduce(hold))==NIL) /* ### */ + { hd[e]=I; e=tl[e]; goto DONE; } + hd[e]=ap(arg2,hd[hold]); tl[e]=tl[hold]; + DOWNLEFT; + DOWNLEFT; + goto NEXTREDEX; + + case LEX_OR: /* LEX_OR f g p x => g p x, if f p x = [] + => f p x, otherwise + */ + GETARG(arg1); + GETARG(arg2); + GETARG(arg3); + upleft; + hold=ap2(arg1,arg3,lastarg); + if((hold=reduce(hold))==NIL) /* ### */ + { hd[e]=ap(arg2,arg3); DOWNLEFT; DOWNLEFT; goto NEXTREDEX; } + hd[e]=I; e=tl[e]=hold; + goto DONE; + + case LEX_RCONTEXT: /* LEX_RC f g p x => [], if f p x = [] + => [], if g q y = [] + => f p x, otherwise <-* + where + (q,y) = f p x + + (*) special case g=0 means test for y=[] + */ + GETARG(arg1); + GETARG(arg2); + GETARG(arg3); + upleft; + hold=ap2(arg1,arg3,lastarg); + lastarg=NIL; /* anti-dragging measure */ + if((hold=reduce(hold))==NIL /* ### */ + || (arg2?(reduce(ap2(arg2,hd[hold],tl[hold]))==NIL) /* ### */ + :(tl[hold]=reduce(tl[hold]))!=NIL )) + { hd[e]=I; e=tl[e]; goto DONE; } + hd[e]=I; e=tl[e]=hold; + goto DONE; + + case LEX_STAR: /* LEX_STAR f p x => p : x, if f p x = [] + => LEX_STAR f q y, otherwise + where + (q,y) = f p x + */ + GETARG(arg1); + GETARG(arg2); + upleft; + hold=ap2(arg1,arg2,lastarg); + while((hold=reduce(hold))!=NIL) /* ### */ + arg2=hd[hold],lastarg=tl[hold],hold=ap2(arg1,arg2,lastarg); + tag[e]=CONS; hd[e]=arg2; + goto DONE; + + case LEX_OPT: /* LEX_OPT f p x => p : x, if f p x = [] + => f p x, otherwise + */ + GETARG(arg1); + GETARG(arg2); + upleft; + hold=ap2(arg1,arg2,lastarg); + if((hold=reduce(hold))==NIL) /* ### */ + { tag[e]=CONS; hd[e]=arg2; goto DONE; } + hd[e]=I; e=tl[e]=hold; + goto DONE; + +/* case NUMBER: /* constructor of arity 1 + UPLEFT; /* cannot occur free + goto DONE; */ /* UNUSED*/ + +/* case CONSTRUCTOR: + for(;;){upleft; } /* reapply to args until DONE */ + + default: /* non combinator */ + cycles--; /* oops! */ + if(abnormal(e)) /* silly recursion */ + { fprintf(stderr,"\nBLACK HOLE\n"); + outstats(); + exit(1); } + + switch(tag[e]) + { case STRCONS: e=pn_val(e); /* private name */ + /*if(e==UNDEF||e==FREE) + fprintf(stderr, + "\nimpossible event in reduce - undefined pname\n"), + exit(1); + /* redundant test - remove when sure */ + goto NEXTREDEX; + case DATAPAIR: /* datapair(oldn,0)(fileinfo(filename,0))=>BOTTOM */ + /* kludge for trapping inherited undefined name without + current alias - see code in load_defs */ + upleft; + fprintf(stderr, + "\nUNDEFINED NAME (specified as \"%s\" in %s)\n", + (char *)hd[hd[e]],(char *)hd[lastarg]); + outstats(); + exit(1); + case ID: if(id_val(e)==UNDEF||id_val(e)==FREE) + { fprintf(stderr,"\nUNDEFINED NAME - %s\n",get_id(e)); + outstats(); + exit(1); } + /* setcell(AP,I,id_val(e)); /* overwrites error-info */ + e=id_val(e); /* could be eager in value */ + goto NEXTREDEX; + default: fprintf(stderr,"\nimpossible tag (%d) in reduce\n",tag[e]); + exit(1); + case CONSTRUCTOR: for(;;){upleft; } /* reapply to args until DONE */ + case STARTREADVALS: + /* readvals(0,t) file => READVALS (t:file) streamptr */ + { char *fil; + upleft; + lastarg=reduce(lastarg); /* ### */ + if(lastarg==OFFSIDE) /* special case, represents stdin */ + { if(stdinuse&&stdinuse!='+') + { tag[e]=AP; hd[e]=I; e=tl[e]=NIL; goto DONE; } + stdinuse='+'; + hold=cons(tl[hd[e]],0),lastarg=(word)stdin; } + else + hold=cons(tl[hd[e]],lastarg), + lastarg=(word)fopen(fil=getstring(lastarg,"readvals"),"r"); + if((FILE *)lastarg==NULL) /* cannot open file for reading */ + /* { hd[e]=I; e=tl[e]=NIL; goto DONE; } */ + { fprintf(stderr,"\nreadvals, cannot open: \"%s\"\n",fil); + outstats(); exit(1); } + hd[e]=ap(READVALS,hold); } + DOWNLEFT; + DOWNLEFT; + goto L_READVALS; + case ATOM: /* for(;;){upleft; } */ + /* as above if there are constructors with tag ATOM + and +ve arity. Since there are none we could test + for missing combinators at this point. Thus + /*if(!abnormal(s)) + fprintf(stderr,"\nreduce: unknown combinator "), + out(stderr,e), putc('\n',stderr),exit(1); */ + case INT: + case UNICODE: + case DOUBLE: + case CONS:; /* all fall thru to DONE */ + } + + } /* end of decode switch */ + + DONE: /* sub task completed -- s is either BACKSTOP or a tailpointer */ + + if(s==BACKSTOP) + { /* whole expression now in hnf */ +#ifdef DEBUG + if(debug&02)printf("result= "),out(stdout,e),putchar('\n'); + rdepth--; +#endif + return(e); /* end of reduction */ + /* outchar(hd[e]); + e=tl[e]; + goto NEXTREDEX; + /* above shows how to incorporate printing into m/c */ + } + + /* otherwise deal with return from subtask */ + UPRIGHT; + if(tag[e]==AP) + { /* we have just reduced argn of strict operator -- so now + we must reduce arg(n-1) */ + DOWNLEFT; + DOWNRIGHT; /* there is a faster way to do this - see TRY */ + goto NEXTREDEX; + } + + /* only possible if mktlptr marks the cell rather than the field */ +/* if(e==BACKSTOP) + fprintf(stderr,"\nprogram error: BLACK HOLE2\n"), + outstats(), + exit(1); */ + + /* we are through reducing args of strict operator */ + /* we can merge the following switch with the main one, if desired, + - in this case use the alternate definitions of READY and RESTORE + and replace the following switch by + /* e=READY(e); goto OPDECODE; */ + +#ifdef DEBUG + if(debug&02){ printf("ready("); out(stdout,e); printf(")\n"); } +#endif + switch(e) /* "ready" switch */ + { +/* case READY(MONOP):/* paradigm for execution of strict monadic operator + GETARG(arg1); + hd[e]=I; e=tl[e]=do_monop(arg1); + goto NEXTREDEX; */ + + case READY(I): /* I x => x */ + UPLEFT; + e=lastarg; + goto NEXTREDEX; + + case READY(SEQ): /* SEQ a b => b, a~=BOTTOM */ + UPLEFT; + upleft; + hd[e]=I;e=lastarg; + goto NEXTREDEX; + + case READY(FORCE): /* FORCE x => x, total x */ + UPLEFT; + force(lastarg); + hd[e]=I;e=lastarg; + goto NEXTREDEX; + + case READY(HD): + UPLEFT; + if(lastarg==NIL) + { fprintf(stderr,"\nATTEMPT TO TAKE hd OF []\n"); + outstats(); exit(1); } + hd[e]=I; e=tl[e]=hd[lastarg]; + goto NEXTREDEX; + + case READY(TL): + UPLEFT; + if(lastarg==NIL) + { fprintf(stderr,"\nATTEMPT TO TAKE tl OF []\n"); + outstats(); exit(1); } + hd[e]=I; e=tl[e]=tl[lastarg]; + goto NEXTREDEX; + + case READY(BODY): + /* BODY(k x1 .. xn) => k x1 ... x(n-1) + for arbitrary constructor k */ + UPLEFT; + hd[e]=I; e=tl[e]=hd[lastarg]; + goto NEXTREDEX; + + case READY(LAST): /* LAST(k x1 .. xn) => xn + for arbitrary constructor k */ + UPLEFT; + hd[e]=I; e=tl[e]=tl[lastarg]; + goto NEXTREDEX; + + case READY(TAKE): + GETARG(arg1); + upleft; + if(tag[arg1]!=INT)word_error("take"); + { long long n=get_word(arg1); + if(n<=0||(lastarg=reduce(lastarg))==NIL) /* ### */ + { simpl(NIL); goto DONE; } + setcell(CONS,hd[lastarg],ap2(TAKE,sto_word(n-1),tl[lastarg])); } + goto DONE; + + case READY(FILEMODE): /* FILEMODE string => string' + (see filemode in manual) */ + UPLEFT; + if(!stat(getstring(lastarg,"filemode"),&buf)) + { mode_t mode=buf.st_mode; + word d=S_ISDIR(mode)?'d':'-'; + word perm= buf.st_uid==geteuid()?(mode&0700)>>6: + buf.st_gid==getegid()?(mode&070)>>3: + mode&07; + word r=perm&04?'r':'-',w=perm&02?'w':'-',x=perm&01?'x':'-'; + setcell(CONS,d,cons(r,cons(w,cons(x,NIL)))); + } + else hd[e]=I,e=tl[e]=NIL; + goto DONE; + + case READY(FILESTAT): /* FILESTAT string => ((inode,dev),mtime) */ + UPLEFT; + /* Notes: + Non-existent file has conventional ((inode,dev),mtime) of ((0,-1),0) + We assume time_t can be stored in int field, this may not port */ + if(!stat(getstring(lastarg,"filestat"),&buf)) + setcell(CONS,cons(sto_word(buf.st_ino), + sto_word(buf.st_dev) ), + sto_word(buf.st_mtime) ); + else setcell(CONS,cons(stosmallint(0), + stosmallint(-1) ), + stosmallint(0) ); + goto DONE; + + case READY(GETENV): /* GETENV string => string' + (see man (2) getenv) */ + UPLEFT; + { char *a = getstring(lastarg,"getenv"); + unsigned char *p = getenv(a); + hold = NIL; + if(p){ word i; + unsigned char *q=p, *r=p; + if(UTF8) + { while(*r) /* compress to Latin-1 in situ */ + if(*r>127) /* start of multibyte */ + if((*r==194||*r==195)&&r[1]>=128&&r[1]<=191) /* Latin-1 */ + *q= *r==194?r[1]:r[1]+64, q++, r+=2; + else getenv_error(a), + /* or silently accept errors here? */ + *q++=*r++; + else *q++=*r++; + *q='\0'; + } + /* convert p to list */ + i = strlen(p); + while(i--)hold=cons(p[i],hold); + } + } + hd[e]=I; e=tl[e]=hold; + goto DONE; + + case READY(EXEC): /* EXEC string + fork off a process to execute string as a + shell command, returning (via pipes) the + triple (stdout,stderr,exit_status) + convention: if fork fails, exit status is -1 */ + UPLEFT; + { word pid=(-1),fd[2],fd_a[2]; + char *cp=getstring(lastarg,"system"); + /* pipe(fd) should return 0, -1 means fail */ + /* fd_a is 2nd pipe, for error messages */ + if(pipe(fd)==(-1)||pipe(fd_a)==(-1)||(pid=fork())) + { /* parent (reader) */ + FILE *fp,*fp_a; + if(pid!= -1) + close(fd[1]), + close(fd_a[1]), + fp=(FILE *)fdopen(fd[0],"r"), + fp_a=(FILE *)fdopen(fd_a[0],"r"); + if(pid== -1||!fp||!fp_a) + setcell(CONS,NIL,cons(piperrmess(pid),sto_word(-1))); else + setcell(CONS,ap(READ,fp),cons(ap(READ,fp_a),ap(WAIT,pid))); + } + else { /* child (writer) */ + word in; + static char *shell="/bin/sh"; + dup2(fd[1],1); /* so pipe replaces stdout */ + dup2(fd_a[1],2); /* 2nd pipe replaces stderr */ + close(fd[1]); + close(fd[0]); + close(fd_a[1]); + close(fd_a[0]); + fclose(stdin); /* anti side-effect measure */ + execl(shell,shell,"-c",cp,(char *)0); + } + } + goto DONE; + + case READY(NUMVAL): /* NUMVAL numeral => number */ + UPLEFT; + { word x=lastarg; + word base=10; + while(x!=NIL) + hd[x]=reduce(hd[x]), /* ### */ + x=tl[x]=reduce(tl[x]); /* ### */ + while(lastarg!=NIL&&isspace(hd[lastarg]))lastarg=tl[lastarg]; + x=lastarg; + if(x!=NIL&&hd[x]=='-')x=tl[x]; + if(hd[x]=='0'&&tl[x]!=NIL) + switch(tolower(hd[tl[x]])) + { case 'o': + base=8; + x=tl[tl[x]]; + while(x!=NIL&&isodigit(hd[x]))x=tl[x]; + break; + case 'x': + base=16; + x=tl[tl[x]]; + while(x!=NIL&&isxdigit(hd[x]))x=tl[x]; + break; + default: goto L; + } + else L: while(x!=NIL&&isdigit(hd[x]))x=tl[x]; + if(x==NIL) + hd[e]=I,e=tl[e]=strtobig(lastarg,base); + else { char *p=linebuf; + double d; char junk=0; + x=lastarg; + while(x!=NIL&&p-linebuf<BUFSIZE-1) *p++ = hd[x], x=tl[x]; + *p++ ='\0'; + if(p-linebuf>60||sscanf(linebuf,"%lf%c",&d,&junk)!=1||junk) + { fprintf(stderr,"\nbad arg for numval: \"%s\"\n",linebuf); + outstats(); + exit(1); } + else hd[e]=I,e=tl[e]=sto_dbl(d); } + goto DONE; } + + case READY(STARTREAD): /* STARTREAD filename => READ streamptr */ + UPLEFT; + { char *fil; + lastarg = (word)fopen(fil=getstring(lastarg,"read"),"r"); + if((FILE *)lastarg==NULL) /* cannot open file for reading */ + /* { hd[e]=I; e=tl[e]=NIL; goto DONE; } + /* could just return empty contents */ + { fprintf(stderr,"\nread, cannot open: \"%s\"\n",fil); + outstats(); exit(1); } + hd[e]=READ; + DOWNLEFT; } + goto L_READ; + + case READY(STARTREADBIN): /* STARTREADBIN filename => READBIN streamptr */ + UPLEFT; + { char *fil; + lastarg = (word)fopen(fil=getstring(lastarg,"readb"),"r"); + if((FILE *)lastarg==NULL) /* cannot open file for reading */ + /* { hd[e]=I; e=tl[e]=NIL; goto DONE; } + /* could just return empty contents */ + { fprintf(stderr,"\nreadb, cannot open: \"%s\"\n",fil); + outstats(); exit(1); } + hd[e]=READBIN; + DOWNLEFT; } + goto L_READBIN; + + case READY(TRY): /* TRY FAIL y => y + TRY other y => other */ + GETARG(arg1); + UPLEFT; + if(arg1==FAIL) + { hd[e]=I; e=lastarg; goto NEXTREDEX; } + if(S<=(hold=head(arg1))&&hold<=ERROR) + /* function - other than unsaturated constructor */ + goto DONE;/* nb! else may take premature decision(interacts with MOD1)*/ + hd[e]=I; + e=tl[e]=arg1; + goto NEXTREDEX; + + case READY(COND): /* COND True => K + COND False => KI */ + UPLEFT; + hd[e]=I; + if(lastarg==True) + { e=tl[e]=K; goto L_K; } + else { e=tl[e]=KI; goto L_KI; } + /* goto OPDECODE; /* to speed up we have set extra labels */ + + /* alternative rules /* COND True x => K x + COND False x => I */ + + case READY(APPEND): /* APPEND NIL y => y + APPEND (a:x) y => a:APPEND x y */ + GETARG(arg1); + upleft; + if(arg1==NIL) + { hd[e]=I,e=lastarg; goto NEXTREDEX; } + setcell(CONS,hd[arg1],ap2(APPEND,tl[arg1],lastarg)); + goto DONE; + + case READY(AND): /* AND True => I + AND False => K False */ + UPLEFT; + if(lastarg==True){ e=I; goto L_I; } + else { hd[e]=K,DOWNLEFT; goto L_K; } + + case READY(OR): /* OR True => K True + OR False => I */ + UPLEFT; + if(lastarg==True){ hd[e]=K; DOWNLEFT; goto L_K; } + else { e=I; goto L_I; } + + /* alternative rules ?? /* AND True y => y + AND False y => False + OR True y => True + OR False y => y */ + + case READY(NOT): /* NOT True => False + NOT False => True */ + UPLEFT; + hd[e]=I; e=tl[e]=lastarg==True?False:True; + goto DONE; + + case READY(NEG): /* NEG x => -x, if x is a number */ + UPLEFT; + if(tag[lastarg]==INT)simpl(bignegate(lastarg)); + else setdbl(e,-get_dbl(lastarg)); + goto DONE; + + case READY(CODE): /* miranda char to int type-conversion */ + UPLEFT; + simpl(make(INT,get_char(lastarg),0)); + goto DONE; + + case READY(DECODE): /* int to char type conversion */ + UPLEFT; + if(tag[lastarg]==DOUBLE)word_error("decode"); + long long val=get_word(lastarg); + if(val<0||val>UMAX) + { fprintf(stderr,"\nCHARACTER OUT-OF-RANGE decode(%d)\n",val); + outstats(); + exit(1); } + hd[e]=I; e=tl[e]=sto_char(val); + goto DONE; + + case READY(INTEGER): /* predicate on numbers */ + UPLEFT; + hd[e]=I; e=tl[e]=tag[lastarg]==INT?True:False; + goto NEXTREDEX; + + case READY(SHOWNUM): /* SHOWNUM number => numeral */ + UPLEFT; + if(tag[lastarg]==DOUBLE) + { double x=get_dbl(lastarg); +#ifndef RYU + sprintf(linebuf,"%.16g",x); + char *p=linebuf; + while isdigit(*p)p++; /* add .0 to false integer */ + if(!*p)*p++='.',*p++='0',*p='\0'; + hd[e]=I; e=tl[e]=str_conv(linebuf); } +#else + d2s_buffered(x,linebuf); + arg1=str_conv(linebuf); + if(*linebuf=='.')arg1=cons('0',arg1); + if(*linebuf=='-'&&linebuf[1]=='.')arg1=cons('-',cons('0',tl[arg1])); + hd[e]=I; e=tl[e]=arg1; } +#endif + else simpl(bigtostr(lastarg)); + goto DONE; + + case READY(SHOWHEX): + UPLEFT; + if(tag[lastarg]==DOUBLE) + { sprintf(linebuf,"%a",get_dbl(lastarg)); + hd[e]=I; e=tl[e]=str_conv(linebuf); } + else simpl(bigtostrx(lastarg)); + goto DONE; + + case READY(SHOWOCT): + UPLEFT; + if(tag[lastarg]==DOUBLE)word_error("showoct"); + else simpl(bigtostr8(lastarg)); + goto DONE; + + /* paradigm for strict monadic arithmetic fns */ + case READY(ARCTAN_FN): /* atan */ + UPLEFT; + errno=0; /* to clear */ + setdbl(e,atan(force_dbl(lastarg))); + if(errno)math_error("atan"); + goto DONE; + + case READY(EXP_FN): /* exp */ + UPLEFT; + errno=0; /* to clear */ + setdbl(e,exp(force_dbl(lastarg))); + if(errno)math_error("exp"); + goto DONE; + + case READY(ENTIER_FN): /* floor */ + UPLEFT; + if(tag[lastarg]==INT)simpl(lastarg); + else simpl(dbltobig(get_dbl(lastarg))); + goto DONE; + + case READY(LOG_FN): /* log */ + UPLEFT; + if(tag[lastarg]==INT)setdbl(e,biglog(lastarg)); + else { errno=0; /* to clear */ + fa=force_dbl(lastarg); + setdbl(e,log(fa)); + if(errno)math_error("log"); } + goto DONE; + + case READY(LOG10_FN): /* log10 */ + UPLEFT; + if(tag[lastarg]==INT)setdbl(e,biglog10(lastarg)); + else { errno=0; /* to clear */ + fa=force_dbl(lastarg); + setdbl(e,log10(fa)); + if(errno)math_error("log10"); } + goto DONE; + + case READY(SIN_FN): /* sin */ + UPLEFT; + errno=0; /* to clear */ + setdbl(e,sin(force_dbl(lastarg))); + if(errno)math_error("sin"); + goto DONE; + + case READY(COS_FN): /* cos */ + UPLEFT; + errno=0; /* to clear */ + setdbl(e,cos(force_dbl(lastarg))); + if(errno)math_error("cos"); + goto DONE; + + case READY(SQRT_FN): /* sqrt */ + UPLEFT; + fa=force_dbl(lastarg); + if(fa<0.0)math_error("sqrt"); + setdbl(e,sqrt(fa)); + goto DONE; + +/* case READY(DIOP):/* paradigm for execution of strict diadic operator + RESTORE(e); /* do not write modified form of operator back into graph + GETARG(arg1); + GETARG(arg2); + hd[e]=I; e=tl[e]=diop(arg1,arg2); + goto NEXTREDEX; */ + +/* case READY(EQUAL): /* UNUSED + RESTORE(e); + GETARG(arg1); + GETARG(arg2); + if(isap(arg1)&&hd[arg1]!=NUMBER&&isap(arg2)&&hd[arg2]!=NUMBER) + { /* recurse on components + hd[e]=ap2(EQUAL,tl[arg1],tl[arg2]); + hd[e]=ap3(EQUAL,hd[arg1],hd[arg2],hd[e]); + tl[e]=False; + } + else { hd[e]=I; e=tl[e]= (eqatom(arg1,arg2)?True:False); } + goto NEXTREDEX; */ + + case READY(ZIP): /* ZIP (a:x) (b:y) => (a,b) : ZIP x y + ZIP x y => [] */ + RESTORE(e); + GETARG(arg1); + GETARG(arg2); + if(arg1==NIL||arg2==NIL) + { hd[e]=I; e=tl[e]=NIL; goto DONE; } + setcell(CONS,cons(hd[arg1],hd[arg2]),ap2(ZIP,tl[arg1],tl[arg2])); + goto DONE; + + case READY(EQ): /* EQ x x => True + EQ x y => False + see definition of function "compare" above */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + hd[e]=I; e=tl[e]=compare(arg1,lastarg)?False:True; /* ### */ + goto DONE; + + case READY(NEQ): /* NEQ x x => False + NEQ x y => True + see definition of function "compare" above */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + hd[e]=I; e=tl[e]=compare(arg1,lastarg)?True:False; /* ### */ + goto DONE; + + case READY(GR): + RESTORE(e); + GETARG(arg1); + UPLEFT; + hd[e]=I; e=tl[e]=compare(arg1,lastarg)>0?True:False; /* ### */ + goto DONE; + + case READY(GRE): + RESTORE(e); + GETARG(arg1); + UPLEFT; + hd[e]=I; e=tl[e]=compare(arg1,lastarg)>=0?True:False; /* ### */ + goto DONE; + + case READY(PLUS): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE) + setdbl(e,get_dbl(arg1)+force_dbl(lastarg)); else + if(tag[lastarg]==DOUBLE) + setdbl(e,bigtodbl(arg1)+get_dbl(lastarg)); + else simpl(bigplus(arg1,lastarg)); + goto DONE; + + case READY(MINUS): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE) + setdbl(e,get_dbl(arg1)-force_dbl(lastarg)); else + if(tag[lastarg]==DOUBLE) + setdbl(e,bigtodbl(arg1)-get_dbl(lastarg)); + else simpl(bigsub(arg1,lastarg)); + goto DONE; + + case READY(TIMES): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE) + setdbl(e,get_dbl(arg1)*force_dbl(lastarg)); else + if(tag[lastarg]==DOUBLE) + setdbl(e,bigtodbl(arg1)*get_dbl(lastarg)); + else simpl(bigtimes(arg1,lastarg)); + goto DONE; + + case READY(INTDIV): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE||tag[lastarg]==DOUBLE)word_error("div"); + if(bigzero(lastarg))div_error(); /* build into bigmod ? */ + simpl(bigdiv(arg1,lastarg)); + goto DONE; + + case READY(FDIV): + RESTORE(e); + GETARG(arg1); + UPLEFT; + /* experiment, suppressed + if(tag[lastarg]==INT&&tag[arg1]==INT&&!bigzero(lastarg)) + { extern int b_rem; + int d = bigdiv(arg1,lastarg); + if(bigzero(b_rem)){ simpl(d); goto DONE; } + } /* makes a/b integer if a, b integers dividing exactly */ + fa=force_dbl(arg1); + fb=force_dbl(lastarg); + if(fb==0.0)div_error(); + setdbl(e,fa/fb); + goto DONE; + + case READY(MOD): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE||tag[lastarg]==DOUBLE)word_error("mod"); + if(bigzero(lastarg))div_error(); /* build into bigmod ? */ + simpl(bigmod(arg1,lastarg)); + goto DONE; + + case READY(POWER): + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[lastarg]==DOUBLE) + { fa=force_dbl(arg1); + if(fa<0.0)errno=EDOM,math_error("^"); + fb=get_dbl(lastarg); }else + if(tag[arg1]==DOUBLE) + fa=get_dbl(arg1),fb=bigtodbl(lastarg); else + if(neg(lastarg)) + fa=bigtodbl(arg1),fb=bigtodbl(lastarg); + else { simpl(bigpow(arg1,lastarg)); + goto DONE; } + errno=0; /* to clear */ + setdbl(e,pow(fa,fb)); + if(errno)math_error("power"); + goto DONE; + + case READY(SHOWSCALED): /* SHOWSCALED precision number => numeral */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE) + word_error("showscaled"); + arg1=getsmallint(arg1); + (void)sprintf(linebuf,"%.*e",arg1,force_dbl(lastarg)); + hd[e]=I; e=tl[e]=str_conv(linebuf); + goto DONE; + + case READY(SHOWFLOAT): /* SHOWFLOAT precision number => numeral */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(tag[arg1]==DOUBLE) + word_error("showfloat"); + arg1=getsmallint(arg1); + (void)sprintf(linebuf,"%.*f",arg1,force_dbl(lastarg)); + hd[e]=I; e=tl[e]=str_conv(linebuf); + goto DONE; + +#define coerce_dbl(x) tag[x]==DOUBLE?(x):sto_dbl(bigtodbl(x)) + + case READY(STEP): /* STEP i a => GENSEQ (i,NIL) a */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + hd[e]=ap(GENSEQ,cons(arg1,NIL)); + goto NEXTREDEX; + + case READY(MERGE): /* MERGE [] y => y + MERGE (a:x) [] => a:x + MERGE (a:x) (b:y) => a:MERGE x (b:y), if a<=b + => b:MERGE (a:x) y, otherwise */ + RESTORE(e); + GETARG(arg1); + UPLEFT; + if(arg1==NIL)simpl(lastarg); else + if(lastarg==NIL)simpl(arg1); else + if(compare(hd[arg1]=reduce(hd[arg1]), + hd[lastarg]=reduce(hd[lastarg]))<=0) /* ### */ + setcell(CONS,hd[arg1],ap2(MERGE,tl[arg1],lastarg)); + else setcell(CONS,hd[lastarg],ap2(MERGE,tl[lastarg],arg1)); + goto DONE; + + case READY(STEPUNTIL): /* STEPUNTIL i a b => GENSEQ (i,b) a */ + RESTORE(e); + GETARG(arg1); + GETARG(arg2); + UPLEFT; + hd[e]=ap(GENSEQ,cons(arg1,arg2)); + if(tag[arg1]==INT?poz(arg1):get_dbl(arg1)>=0.0) + tag[tl[hd[e]]]=AP; /* hack to record sign of step - see GENSEQ */ + goto NEXTREDEX; + + case READY(Ush): + /* Ush (k f1...fn) p (k x1...xn) + => "k"++' ':f1 x1 ...++' ':fn xn, p='\0' + => "(k"++' ':f1 x1 ...++' ':fn xn++")", p='\1' + Ush (k f1...fn) p other => FAIL */ + RESTORE(e); + GETARG(arg1); + GETARG(arg2); + GETARG(arg3); + if(constr_tag(head(arg1))!=constr_tag(head(arg3))) + { hd[e]=I; + e=tl[e]=FAIL; + goto DONE; } /* result is string, so cannot be more args */ + if(tag[arg1]==CONSTRUCTOR) /* don't parenthesise atom */ + { hd[e]=I; + if(suppressed(arg1)) + e=tl[e]=str_conv("<unprintable>"); + else e=tl[e]=str_conv(constr_name(arg1)); + goto DONE; } + hold=arg2?cons(')',NIL):NIL; + while(tag[arg1]!=CONSTRUCTOR) + hold=cons(' ',ap2(APPEND,ap(tl[arg1],tl[arg3]),hold)), + arg1=hd[arg1],arg3=hd[arg3]; + if(suppressed(arg1)) + { hd[e]=I; e=tl[e]=str_conv("<unprintable>"); goto DONE; } + hold=ap2(APPEND,str_conv(constr_name(arg1)),hold); + if(arg2) + { setcell(CONS,'(',hold); goto DONE; } + else { hd[e]=I; e=tl[e]=hold; goto NEXTREDEX; } + + default: fprintf(stderr,"\nimpossible event in reduce ("), + out(stderr,e),fprintf(stderr,")\n"), + exit(1); + return(0); /* proforma only - unreachable */ + } /* end of "ready" switch */ + +} /* end of reduce */ + +memclass(c,x) /* is char c in list x (may include ranges) */ +{ while(x!=NIL) + { if(hd[x]==DOTDOT) + { x=tl[x]; + if(hd[x]<=c&&c<=hd[tl[x]])return(1); + x=tl[x]; } + else if(c==hd[x])return(1); + x=tl[x]; } + return(0); +} + +lexfail(x) /* x is known to be a non-empty string (see LEX_RPT) */ +{ word i=24; + fprintf(stderr,"\nLEX FAILS WITH UNRECOGNISED INPUT: \""); + while(i--&&x!=NIL&&0<=lh(x)&&lh(x)<=255) + fprintf(stderr,"%s",charname(lh(x))), + x=tl[x]; + fprintf(stderr,"%s\"\n",x==NIL?"":"..."); + outstats(); + exit(1); +} + +lexstate(x) /* extracts initial state info from list of chars labelled + by LEX_COUNT - x is evaluated and known to be non-empty */ +{ x = hd[hd[x]]; /* count field of first char */ + return(cons(sto_word(x>>8),stosmallint(x&255))); +} + +piperrmess(pid) +word pid; +{ return(str_conv(pid== -1?"cannot create process\n":"cannot open pipe\n")); +} + +g_residue(toks2) /* remainder of token stream from last token examined */ +word toks2; +{ word toks1 = NIL; + if(tag[toks2]!=CONS) + { if(tag[toks2]==AP&&hd[toks2]==I&&tl[toks2]==NIL) + return(cons(NIL,NIL)); + return(cons(NIL,toks2)); /*no tokens examined, whole grammar is `error'*/ + /* fprintf(stderr,"\nimpossible event in g_residue\n"), + exit(1); /* grammar fn must have examined >=1 tokens */ } + while(tag[tl[toks2]]==CONS)toks1=cons(hd[toks2],toks1),toks2=tl[toks2]; + if(tl[toks2]==NIL||tag[tl[toks2]]==AP&&hd[tl[toks2]]==I&&tl[tl[toks2]]==NIL) + { toks1=cons(hd[toks2],toks1); + return(cons(ap(DESTREV,toks1),NIL)); } + return(cons(ap(DESTREV,toks1),toks2)); +} + +numplus(x,y) +word x,y; +{ if(tag[x]==DOUBLE) + return(sto_dbl(get_dbl(x)+force_dbl(y))); + if(tag[y]==DOUBLE) + return(sto_dbl(bigtodbl(x)+get_dbl(y))); + return(bigplus(x,y)); +} + +fn_error(s) +char *s; +{ fprintf(stderr,"\nprogram error: %s\n",s); + outstats(); + exit(1); } + +getenv_error(char *a) +{ fprintf(stderr, + "program error: getenv(%s): illegal characters in result string\n",a); + outstats(); + exit(1); } + +subs_error() +{ fn_error("subscript out of range"); +} + +div_error() +{ fn_error("attempt to divide by zero"); +} +/* other arithmetic exceptions signal-trapped by fpe_error - see STEER */ + +math_error(s) +char *s; +{ fprintf(stderr,"\nmath function %serror (%s)\n", + errno==EDOM?"domain ":errno==ERANGE?"range ":"",s); + outstats(); + exit(1); +} + +word_error(s) +char *s; +{ fprintf(stderr, + "\nprogram error: fractional number where integer expected (%s)\n",s); + outstats(); + exit(1); +} + +char *stdname(c) +word c; +{ return c==':' ? "$:-" : c=='-' ? "$-" : "$+"; } + +stdin_error(c) +word c; +{ if(stdinuse==c) + fprintf(stderr,"program error: duplicate use of %s\n",stdname(c)); + else fprintf(stderr,"program error: simultaneous use of %s and %s\n", + stdname(c), stdname(stdinuse)); + outstats(); + exit(1); +} + +#ifdef BSDCLOCK +#include <sys/times.h> +#include <unistd.h> +#ifndef CLK_TCK +#define CLK_TCK sysconf(_SC_CLK_TCK) +#endif +#else +/* this is ANSII C, POSIX */ +#include <time.h> +clock_t start, end; +#endif + +initclock() +{ +#ifndef BSDCLOCK +start=clock(); +#endif +} + +out_here(f,h,nl) /* h is fileinfo(scriptname,line_no) */ +FILE *f; +word h,nl; +{ extern word errs; + if(tag[h]!=FILEINFO) + { fprintf(stderr,"(impossible event in outhere)\n"); return; } + fprintf(f,"(line %3d of \"%s\")",tl[h],(char *)hd[h]); + if(nl)putc('\n',f); else putc(' ',f); + if(compiling&&!errs)errs=h; /* relevant only when called from steer.c */ +} /* `soft' error, set errs rather than errline, so not saved in dump */ + +outstats() +{ extern long claims,nogcs; + extern word atcount; + extern long long cellcount; +#ifdef BSDCLOCK + struct tms buffer; +#endif +#ifdef HISTO + if(sourcemc)printhisto(); +#endif + if(!atcount)return; +#ifdef BSDCLOCK + times(&buffer); +#else + end=clock(); +#endif + printf("||"); + printf("reductions = %lld, cells claimed = %lld, ", + cycles,cellcount+claims); + printf("no of gc's = %ld, cpu = %0.2f",nogcs, +#ifdef BSDCLOCK + buffer.tms_utime/(CLK_TCK*1.0)); +#else + ((double) (end - start)) / CLOCKS_PER_SEC); +#endif + putchar('\n'); +#ifdef DEBUG + printf("||maxr_depth=%d\n",maxrdepth); +#endif +} + +/* end of MIRANDA REDUCE */ + diff --git a/new/rules.y b/new/rules.y new file mode 100644 index 0000000..e44698b --- /dev/null +++ b/new/rules.y @@ -0,0 +1,1686 @@ +/* Miranda token declarations and syntax rules for "YACC" */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +/* miranda symbols */ + +%token VALUE EVAL WHERE IF TO LEFTARROW COLONCOLON COLON2EQ + TYPEVAR NAME CNAME CONST DOLLAR2 OFFSIDE ELSEQ + ABSTYPE WITH DIAG EQEQ FREE INCLUDE EXPORT TYPE + OTHERWISE SHOWSYM PATHNAME BNF LEX ENDIR ERRORSY ENDSY + EMPTYSY READVALSY LEXDEF CHARCLASS ANTICHARCLASS LBEGIN + +%right ARROW +%right PLUSPLUS ':' MINUSMINUS +%nonassoc DOTDOT +%right VEL +%right '&' +%nonassoc '>' GE '=' NE LE '<' +%left '+' '-' +%left '*' '/' REM DIV +%right '^' +%left '.' /* fiddle to make '#' behave */ +%left '!' +%right INFIXNAME INFIXCNAME +%token CMBASE /* placeholder to start combinator values - see combs.h */ + +%{ +/* the following definition has to be kept in line with the token declarations + above */ +char *yysterm[]= { + 0, + "VALUE", + "EVAL", + "where", + "if", + "&>", + "<-", + "::", + "::=", + "TYPEVAR", + "NAME", + "CONSTRUCTOR-NAME", + "CONST", + "$$", + "OFFSIDE", + "OFFSIDE =", + "abstype", + "with", + "//", + "==", + "%free", + "%include", + "%export", + "type", + "otherwise", + "show", + "PATHNAME", + "%bnf", + "%lex", + "%%", + "error", + "end", + "empty", + "readvals", + "NAME", + "`char-class`", + "`char-class`", + "%%begin", + "->", + "++", + "--", + "..", + "\\/", + ">=", + "~=", + "<=", + "mod", + "div", + "$NAME", + "$CONSTRUCTOR"}; + +%} + +/* Miranda syntax rules */ +/* the associated semantic actions perform the compilation */ + +%{ +#include "data.h" +#include "lex.h" +extern word nill,k_i,Void; +extern word message,standardout; +extern word big_one; +#define isltmess_t(t) (islist_t(t)&&tl[t]==message) +#define isstring_t(t) (islist_t(t)&&tl[t]==char_t) +extern word SYNERR,errs,echoing,gvars; +extern word listdiff_fn,indent_fn,outdent_fn; +extern word polyshowerror; +word lastname=0; +word suppressids=NIL; +word idsused=NIL; +word tvarscope=0; +word includees=NIL,embargoes=NIL,exportfiles=NIL,freeids=NIL,exports=NIL; +word lexdefs=NIL,lexstates=NIL,inlex=0,inexplist=0; +word inbnf=0,col_fn=0,fnts=NIL,eprodnts=NIL,nonterminals=NIL,sreds=0; +word ihlist=0,ntspecmap=NIL,ntmap=NIL,lasth=0; +word obrct=0; + +void evaluate(x) +word x; +{ extern word debug; + word t; + t=type_of(x); + if(t==wrong_t)return; + lastexp=x; + x=codegen(x); + if(polyshowerror)return; + if(process()) + /* setup new process for each evaluation */ + { (void)signal(SIGINT,(sighandler)dieclean); + /* if interrupted will flush output etc before going */ + compiling=0; + resetgcstats(); + output(isltmess_t(t)?x: + cons(ap(standardout,isstring_t(t)?x + :ap(mkshow(0,0,t),x)),NIL)); + (void)signal(SIGINT,SIG_IGN);/* otherwise could do outstats() twice */ + putchar('\n'); + outstats(); + exit(0); } +} + +void obey(x) /* like evaluate but no fork, no stats, no extra '\n' */ +word x; +{ word t=type_of(x); + x=codegen(x); + if(polyshowerror)return; + compiling=0; + output(isltmess_t(t)?x: + cons(ap(standardout,isstring_t(t)?x:ap(mkshow(0,0,t),x)),NIL)); +} + +int isstring(x) +word x; +{ return(x==NILS||tag[x]==CONS&&is_char(hd[x])); +} + +word compose(x) /* used in compiling 'cases' */ +word x; +{ word y=hd[x]; + if(hd[y]==OTHERWISE)y=tl[y]; /* OTHERWISE was just a marker - lose it */ + else y=tag[y]==LABEL?label(hd[y],ap(tl[y],FAIL)): + ap(y,FAIL); /* if all guards false result is FAIL */ + x = tl[x]; + if(x!=NIL) + { while(tl[x]!=NIL)y=label(hd[hd[x]],ap(tl[hd[x]],y)), x=tl[x]; + y=ap(hd[x],y); + /* first alternative has no label - label of enclosing rhs applies */ + } + return(y); +} + +word starts(x) /* x is grammar rhs - returns list of nonterminals in start set */ +word x; +{ L: switch(tag[x]) + { case ID: return(cons(x,NIL)); + case LABEL: + case LET: + case LETREC: x=tl[x]; goto L; + case AP: switch(hd[x]) + { case G_SYMB: + case G_SUCHTHAT: + case G_RULE: return(NIL); + case G_OPT: + case G_FBSTAR: + case G_STAR: x=tl[x]; goto L; + default: if(hd[x]==outdent_fn) + { x=tl[x]; goto L; } + if(tag[hd[x]]==AP) + if(hd[hd[x]]==G_ERROR) + { x=tl[hd[x]]; goto L; } + if(hd[hd[x]]==G_SEQ) + { if(eprod(tl[hd[x]])) + return(UNION(starts(tl[hd[x]]),starts(tl[x]))); + x=tl[hd[x]]; goto L; } else + if(hd[hd[x]]==G_ALT) + return(UNION(starts(tl[hd[x]]),starts(tl[x]))); + else + if(hd[hd[x]]==indent_fn) + { x=tl[x]; goto L; } + } + default: return(NIL); + } +} + +int eprod(x) /* x is grammar rhs - does x admit empty production? */ +word x; +{ L: switch(tag[x]) + { case ID: return(member(eprodnts,x)); + case LABEL: + case LET: + case LETREC: x=tl[x]; goto L; + case AP: switch(hd[x]) + { case G_SUCHTHAT: + case G_ANY: + case G_SYMB: return(0); + case G_RULE: return(1); + case G_OPT: + case G_FBSTAR: + case G_STAR: return(1); + default: if(hd[x]==outdent_fn) + { x=tl[x]; goto L; } + if(tag[hd[x]]==AP) + if(hd[hd[x]]==G_ERROR) + { x=tl[hd[x]]; goto L; } + if(hd[hd[x]]==G_SEQ) + return(eprod(tl[hd[x]])&&eprod(tl[x])); else + if(hd[hd[x]]==G_ALT) + return(eprod(tl[hd[x]])||eprod(tl[x])); + else + if(hd[hd[x]]==indent_fn) + { x=tl[x]; goto L; } + } + default: return(x==G_STATE||x==G_UNIT); + /* G_END is special case, unclear whether it counts as an e-prodn. + decide no for now, sort this out later */ + } +} + +word add_prod(d,ps,hr) +word d,ps,hr; +{ word p,n=dlhs(d); + for(p=ps;p!=NIL;p=tl[p]) + if(dlhs(hd[p])==n) + if(dtyp(d)==undef_t&&dval(hd[p])==UNDEF) + { dval(hd[p])=dval(d); return(ps); } else + if(dtyp(d)!=undef_t&&dtyp(hd[p])==undef_t) + { dtyp(hd[p])=dtyp(d); return(ps); } + else + errs=hr, + printf( + "%ssyntax error: conflicting %s of nonterminal \"%s\"\n", + echoing?"\n":"", + dtyp(d)==undef_t?"definitions":"specifications", + get_id(n)), + acterror(); + return(cons(d,ps)); +} +/* clumsy - this algorithm is quadratic in number of prodns - fix later */ + +word getloc(nt,prods) /* get here info for nonterminal */ +word nt,prods; +{ while(prods!=NIL&&dlhs(hd[prods])!=nt)prods=tl[prods]; + if(prods!=NIL)return(hd[dval(hd[prods])]); + return(0); /* should not happen, but just in case */ +} + +void findnt(nt) /* set errs to here info of undefined nonterminal */ +word nt; +{ word p=ntmap; + while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p]; + if(p!=NIL) + { errs=tl[hd[p]]; return; } + p=ntspecmap; + while(p!=NIL&&hd[hd[p]]!=nt)p=tl[p]; + if(p!=NIL)errs=tl[hd[p]]; +} + +#define isap2(fn,x) (tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==(fn)) +#define firstsymb(term) tl[hd[term]] + +void binom(rhs,x) +/* performs the binomial optimisation on rhs of nonterminal x + x: x alpha1| ... | x alphaN | rest ||need not be in this order + ==> + x: rest (alpha1|...|alphaN)* +*/ +word rhs,x; +{ word *p= &tl[rhs]; /* rhs is of form label(hereinf, stuff) */ + word *lastp=0,*holdrhs,suffix,alpha=NIL; + if(tag[*p]==LETREC)p = &tl[*p]; /* ignore trailing `where defs' */ + if(isap2(G_ERROR,*p))p = &tl[hd[*p]]; + holdrhs=p; + while(isap2(G_ALT,*p)) + if(firstsymb(tl[hd[*p]])==x) + alpha=cons(tl[tl[hd[*p]]],alpha), + *p=tl[*p],p = &tl[*p]; + else lastp=p,p = &tl[tl[*p]]; + /* note each (G_ALT a b) except the outermost is labelled */ + if(lastp&&firstsymb(*p)==x) + alpha=cons(tl[*p],alpha), + *lastp=tl[hd[*lastp]]; + if(alpha==NIL)return; + suffix=hd[alpha],alpha=tl[alpha]; + while(alpha!=NIL) + suffix=ap2(G_ALT,hd[alpha],suffix), + alpha=tl[alpha]; + *holdrhs=ap2(G_SEQ,*holdrhs,ap(G_FBSTAR,suffix)); +} +/* should put some labels on the alpha's - fix later */ + +word getcol_fn() +{ extern char *dicp,*dicq; + if(!col_fn) + strcpy(dicp,"bnftokenindentation"), + dicq=dicp+20, + col_fn=name(); + return(col_fn); +} + +void startbnf() +{ ntspecmap=ntmap=nonterminals=NIL; + if(fnts==0)col_fn=0; /* reinitialise, a precaution */ +} + +word ih_abstr(x) /* abstract inherited attributes from grammar rule */ +word x; +{ word ih=ihlist; + while(ih!=NIL) /* relies on fact that ihlist is reversed */ + x=lambda(hd[ih],x),ih=tl[ih]; + return(x); +} + +int can_elide(x) /* is x of the form $1 applied to ih attributes in order? */ +word x; +{ word ih; + if(ihlist) + for(ih=ihlist;ih!=NIL&&tag[x]==AP;ih=tl[ih],x=hd[x]) + if(hd[ih]!=tl[x])return(0); + return(x==mkgvar(1)); +} + +int e_re(x) /* does regular expression x match empty string ? */ +{ L: if(tag[x]==AP) + { if(hd[x]==LEX_STAR||hd[x]==LEX_OPT)return(1); + if(hd[x]==LEX_STRING)return(tl[x]==NIL); + if(tag[hd[x]]!=AP)return(0); + if(hd[hd[x]]==LEX_OR) + { if(e_re(tl[hd[x]]))return(1); + x=tl[x]; goto L; } else + if(hd[hd[x]]==LEX_SEQ) + { if(!e_re(tl[hd[x]]))return(0); + x=tl[x]; goto L; } else + if(hd[hd[x]]==LEX_RCONTEXT) + { x=tl[hd[x]]; goto L; } + } + return(0); +} + +%} + +%% + +entity: /* the entity to be parsed is either a definition script or an + expression (the latter appearing as a command line) */ + + error| + + script + = { lastname=0; /* outstats(); */ }| + /* statistics not usually wanted after compilation */ + +/* MAGIC exp '\n' script + = { lastexp=$2; }| /* change to magic scripts 19.11.2013 */ + + VALUE exp + = { lastexp=$2; }| /* next line of `$+' */ + + EVAL exp + = { if(!SYNERR&&yychar==0) + { evaluate($2); } + }| + + EVAL exp COLONCOLON + /* boring problem - how to make sure no junk chars follow here? + likewise TO case -- trick used above doesn't work, yychar is + here always -1 Why? Too fiddly to bother with just now */ + = { word t=type_of($2); + if(t!=wrong_t) + { lastexp=$2; + if(tag[$2]==ID&&id_type($2)==wrong_t)t=wrong_t; + out_type(t); + putchar('\n'); } + }| + + EVAL exp TO + = { FILE *fil=NULL,*efil; + word t=type_of($2); + char *f=token(),*ef; + if(f)keep(f); ef=token(); /* wasteful of dic space, FIX LATER */ + if(f){ fil= fopen(f,$3?"a":"w"); + if(fil==NULL) + printf("cannot open \"%s\" for writing\n",f); } + else printf("filename missing after \"&>\"\n"); + if(ef) + { efil= fopen(ef,$3?"a":"w"); + if(efil==NULL) + printf("cannot open \"%s\" for writing\n",ef); } + if(t!=wrong_t)$2=codegen(lastexp=$2); + if(polyshowerror)return; + if(t!=wrong_t&&fil!=NULL&&(!ef||efil)) + { word pid;/* launch a concurrent process to perform task */ + sighandler oldsig; + oldsig=signal(SIGINT,SIG_IGN); /* ignore interrupts */ + if(pid=fork()) + { /* "parent" */ + if(pid==-1)perror("cannot create process"); + else printf("process %d\n",pid); + fclose(fil); + if(ef)fclose(efil); + (void)signal(SIGINT,oldsig); }else + { /* "child" */ + (void)signal(SIGQUIT,SIG_IGN); /* and quits */ +#ifndef SYSTEM5 + (void)signal(SIGTSTP,SIG_IGN); /* and stops */ +#endif + close(1); dup(fileno(fil)); /* subvert stdout */ + close(2); dup(fileno(ef?efil:fil)); /* subvert stderr */ + /* FUNNY BUG - if redirect stdout stderr to same file by two + calls to freopen, their buffers get conflated - whence do + by subverting underlying file descriptors, as above + (fix due to Martin Guy) */ + /* formerly used dup2, but not present in system V */ + fclose(stdin); + /* setbuf(stdout,NIL); + /* not safe to change buffering of stream already in use */ + /* freopen would have reset the buffering automatically */ + lastexp = NIL; /* what else should we set to NIL? */ + /*atcount= 1; */ + compiling= 0; + resetgcstats(); + output(isltmess_t(t)?$2: + cons(ap(standardout,isstring_t(t)?$2: + ap(mkshow(0,0,t),$2)),NIL)); + putchar('\n'); + outstats(); + exit(0); } } }; + +script: + /* empty */| + defs; + +exp: + op | /* will later suppress in favour of (op) in arg */ + e1; + +op: + '~' + = { $$ = NOT; }| + '#' + = { $$ = LENGTH; }| + diop; + +diop: + '-' + = { $$ = MINUS; }| + diop1; + +diop1: + '+' + = { $$ = PLUS; }| + PLUSPLUS + = { $$ = APPEND; }| + ':' + = { $$ = P; }| + MINUSMINUS + = { $$ = listdiff_fn; }| + VEL + = { $$ = OR; }| + '&' + = { $$ = AND; }| + relop | + '*' + = { $$ = TIMES; }| + '/' + = { $$ = FDIV; }| + DIV + = { $$ = INTDIV; }| + REM + = { $$ = MOD; }| + '^' + = { $$ = POWER; }| + '.' + = { $$ = B; }| + '!' + = { $$ = ap(C,SUBSCRIPT); }| + INFIXNAME| + INFIXCNAME; + +relop: + '>' + = { $$ = GR; }| + GE + = { $$ = GRE; }| + eqop + = { $$ = EQ; }| + NE + = { $$ = NEQ; }| + LE + = { $$ = ap(C,GRE); }| + '<' + = { $$ = ap(C,GR); }; + +eqop: + EQEQ| /* silently accept for benefit of Haskell users */ + '='; + +rhs: + cases WHERE ldefs + = { $$ = block($3,compose($1),0); }| + exp WHERE ldefs + = { $$ = block($3,$1,0); }| + exp| + cases + = { $$ = compose($1); }; + +cases: + exp ',' if exp + = { $$ = cons(ap2(COND,$4,$1),NIL); }| + exp ',' OTHERWISE + = { $$ = cons(ap(OTHERWISE,$1),NIL); }| + cases reindent ELSEQ alt + = { $$ = cons($4,$1); + if(hd[hd[$1]]==OTHERWISE) + syntax("\"otherwise\" must be last case\n"); }; + +alt: + here exp + = { errs=$1, + syntax("obsolete syntax, \", otherwise\" missing\n"); + $$ = ap(OTHERWISE,label($1,$2)); }| + here exp ',' if exp + = { $$ = label($1,ap2(COND,$5,$2)); }| + here exp ',' OTHERWISE + = { $$ = ap(OTHERWISE,label($1,$2)); }; + +if: + /* empty */ + = { extern word strictif; + if(strictif)syntax("\"if\" missing\n"); }| + IF; + +indent: + /* empty */ + = { if(!SYNERR){layout(); setlmargin();} + }; +/* note that because of yacc's one symbol look ahead, indent must usually be + invoked one symbol earlier than the non-terminal to which it applies + - see `production:' for an exception */ + +outdent: + separator + = { unsetlmargin(); }; + +separator: + OFFSIDE | ';' ; + +reindent: + /* empty */ + = { if(!SYNERR) + { unsetlmargin(); layout(); setlmargin(); } + }; + +liste: /* NB - returns list in reverse order */ + exp + = { $$ = cons($1,NIL); }| + liste ',' exp /* left recursive so as not to eat YACC stack */ + = { $$ = cons($3,$1); }; + +e1: + '~' e1 %prec '=' + = { $$ = ap(NOT,$2); }| + e1 PLUSPLUS e1 + = { $$ = ap2(APPEND,$1,$3); }| + e1 ':' e1 + = { $$ = cons($1,$3); }| + e1 MINUSMINUS e1 + = { $$ = ap2(listdiff_fn,$1,$3); }| + e1 VEL e1 + = { $$ = ap2(OR,$1,$3); }| + e1 '&' e1 + = { $$ = ap2(AND,$1,$3); }| + reln | + e2; + +es1: /* e1 or presection */ + '~' e1 %prec '=' + = { $$ = ap(NOT,$2); }| + e1 PLUSPLUS e1 + = { $$ = ap2(APPEND,$1,$3); }| + e1 PLUSPLUS + = { $$ = ap(APPEND,$1); }| + e1 ':' e1 + = { $$ = cons($1,$3); }| + e1 ':' + = { $$ = ap(P,$1); }| + e1 MINUSMINUS e1 + = { $$ = ap2(listdiff_fn,$1,$3); }| + e1 MINUSMINUS + = { $$ = ap(listdiff_fn,$1); }| + e1 VEL e1 + = { $$ = ap2(OR,$1,$3); }| + e1 VEL + = { $$ = ap(OR,$1); }| + e1 '&' e1 + = { $$ = ap2(AND,$1,$3); }| + e1 '&' + = { $$ = ap(AND,$1); }| + relsn | + es2; + +e2: + '-' e2 %prec '-' + = { $$ = ap(NEG,$2); }| + '#' e2 %prec '.' + = { $$ = ap(LENGTH,$2); }| + e2 '+' e2 + = { $$ = ap2(PLUS,$1,$3); }| + e2 '-' e2 + = { $$ = ap2(MINUS,$1,$3); }| + e2 '*' e2 + = { $$ = ap2(TIMES,$1,$3); }| + e2 '/' e2 + = { $$ = ap2(FDIV,$1,$3); }| + e2 DIV e2 + = { $$ = ap2(INTDIV,$1,$3); } | + e2 REM e2 + = { $$ = ap2(MOD,$1,$3); }| + e2 '^' e2 + = { $$ = ap2(POWER,$1,$3); } | + e2 '.' e2 + = { $$ = ap2(B,$1,$3); }| + e2 '!' e2 + = { $$ = ap2(SUBSCRIPT,$3,$1); }| + e3; + +es2: /* e2 or presection */ + '-' e2 %prec '-' + = { $$ = ap(NEG,$2); }| + '#' e2 %prec '.' + = { $$ = ap(LENGTH,$2); }| + e2 '+' e2 + = { $$ = ap2(PLUS,$1,$3); }| + e2 '+' + = { $$ = ap(PLUS,$1); }| + e2 '-' e2 + = { $$ = ap2(MINUS,$1,$3); }| + e2 '-' + = { $$ = ap(MINUS,$1); }| + e2 '*' e2 + = { $$ = ap2(TIMES,$1,$3); }| + e2 '*' + = { $$ = ap(TIMES,$1); }| + e2 '/' e2 + = { $$ = ap2(FDIV,$1,$3); }| + e2 '/' + = { $$ = ap(FDIV,$1); }| + e2 DIV e2 + = { $$ = ap2(INTDIV,$1,$3); } | + e2 DIV + = { $$ = ap(INTDIV,$1); } | + e2 REM e2 + = { $$ = ap2(MOD,$1,$3); }| + e2 REM + = { $$ = ap(MOD,$1); }| + e2 '^' e2 + = { $$ = ap2(POWER,$1,$3); } | + e2 '^' + = { $$ = ap(POWER,$1); } | + e2 '.' e2 + = { $$ = ap2(B,$1,$3); }| + e2 '.' + = { $$ = ap(B,$1); }| + e2 '!' e2 + = { $$ = ap2(SUBSCRIPT,$3,$1); }| + e2 '!' + = { $$ = ap2(C,SUBSCRIPT,$1); }| + es3; + +e3: + comb INFIXNAME e3 + = { $$ = ap2($2,$1,$3); }| + comb INFIXCNAME e3 + = { $$ = ap2($2,$1,$3); }| + comb; + +es3: /* e3 or presection */ + comb INFIXNAME e3 + = { $$ = ap2($2,$1,$3); }| + comb INFIXNAME + = { $$ = ap($2,$1); }| + comb INFIXCNAME e3 + = { $$ = ap2($2,$1,$3); }| + comb INFIXCNAME + = { $$ = ap($2,$1); }| + comb; + +comb: + comb arg + = { $$ = ap($1,$2); }| + arg; + +reln: + e2 relop e2 + = { $$ = ap2($2,$1,$3); }| + reln relop e2 + = { word subject; + subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1]; + $$ = ap2(AND,$1,ap2($2,subject,$3)); + }; /* EFFICIENCY PROBLEM - subject gets re-evaluated (and + retypechecked) - fix later */ + +relsn: /* reln or presection */ + e2 relop e2 + = { $$ = ap2($2,$1,$3); }| + e2 relop + = { $$ = ap($2,$1); }| + reln relop e2 + = { word subject; + subject = hd[hd[$1]]==AND?tl[tl[$1]]:tl[$1]; + $$ = ap2(AND,$1,ap2($2,subject,$3)); + }; /* EFFICIENCY PROBLEM - subject gets re-evaluated (and + retypechecked) - fix later */ + +arg: + { if(!SYNERR)lexstates=NIL,inlex=1; } + LEX lexrules ENDIR + = { inlex=0; lexdefs=NIL; + if(lexstates!=NIL) + { word echoed=0; + for(;lexstates!=NIL;lexstates=tl[lexstates]) + { if(!echoed)printf(echoing?"\n":""),echoed=1; + if(!(tl[hd[lexstates]]&1)) + printf("warning: lex state %s is never entered\n", + get_id(hd[hd[lexstates]])); else + if(!(tl[hd[lexstates]]&2)) + printf("warning: lex state %s has no associated rules\n", + get_id(hd[hd[lexstates]])); } + } + if($3==NIL)syntax("%lex with no rules\n"); + else tag[$3]=LEXER; + /* result is lex-list, in reverse order, of items of the form + cons(scstuff,cons(matcher,rhs)) + where scstuff is of the form + cons(0-or-list-of-startconditions,1+newstartcondition) + */ + $$ = $3; }| + NAME | + CNAME | + CONST | + READVALSY + = { $$ = readvals(0,0); }| + SHOWSYM + = { $$ = show(0,0); }| + DOLLAR2 + = { $$ = lastexp; + if(lastexp==UNDEF) + syntax("no previous expression to substitute for $$\n"); }| + '[' ']' + = { $$ = NIL; }| + '[' exp ']' + = { $$ = cons($2,NIL); }| + '[' exp ',' exp ']' + = { $$ = cons($2,cons($4,NIL)); }| + '[' exp ',' exp ',' liste ']' + = { $$ = cons($2,cons($4,reverse($6))); }| + '[' exp DOTDOT exp ']' + = { $$ = ap3(STEPUNTIL,big_one,$4,$2); }| + '[' exp DOTDOT ']' + = { $$ = ap2(STEP,big_one,$2); }| + '[' exp ',' exp DOTDOT exp ']' + = { $$ = ap3(STEPUNTIL,ap2(MINUS,$4,$2),$6,$2); }| + '[' exp ',' exp DOTDOT ']' + = { $$ = ap2(STEP,ap2(MINUS,$4,$2),$2); }| + '[' exp '|' qualifiers ']' + = { $$ = SYNERR?NIL:compzf($2,$4,0); }| + '[' exp DIAG qualifiers ']' + = { $$ = SYNERR?NIL:compzf($2,$4,1); }| + '(' op ')' /* RSB */ + = { $$ = $2; }| + '(' es1 ')' /* presection or parenthesised e1 */ + = { $$ = $2; }| + '(' diop1 e1 ')' /* postsection */ + = { $$ = (tag[$2]==AP&&hd[$2]==C)?ap(tl[$2],$3): /* optimisation */ + ap2(C,$2,$3); }| + '(' ')' + = { $$ = Void; }| /* the void tuple */ + '(' exp ',' liste ')' + = { if(tl[$4]==NIL)$$=pair($2,hd[$4]); + else { $$=pair(hd[tl[$4]],hd[$4]); + $4=tl[tl[$4]]; + while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4]; + $$ = tcons($2,$$); } + /* representation of the tuple (a1,...,an) is + tcons(a1,tcons(a2,...pair(a(n-1),an))) */ + }; + +lexrules: + lexrules lstart here re indent { if(!SYNERR)inlex=2; } + ARROW exp lpostfix { if(!SYNERR)inlex=1; } outdent + = { if($9<0 && e_re($4)) + errs=$3, + syntax("illegal lex rule - lhs matches empty\n"); + $$ = cons(cons(cons($2,1+$9),cons($4,label($3,$8))),$1); }| + lexdefs + = { $$ = NIL; }; + +lstart: + /* empty */ + = { $$ = 0; }| + '<' cnames '>' + = { word ns=NIL; + for(;$2!=NIL;$2=tl[$2]) + { word *x = &lexstates,i=1; + while(*x!=NIL&&hd[hd[*x]]!=hd[$2])i++,x = &tl[*x]; + if(*x == NIL)*x = cons(cons(hd[$2],2),NIL); + else tl[hd[*x]] |= 2; + ns = add1(i,ns); } + $$ = ns; }; + +cnames: + CNAME + = { $$=cons($1,NIL); }| + cnames CNAME + = { if(member($1,$2)) + printf("%ssyntax error: repeated name \"%s\" in start conditions\n", + echoing?"\n":"",get_id($2)), + acterror(); + $$ = cons($2,$1); }; + +lpostfix: + /* empty */ + = { $$ = -1; }| + LBEGIN CNAME + = { word *x = &lexstates,i=1; + while(*x!=NIL&&hd[hd[*x]]!=$2)i++,x = &tl[*x]; + if(*x == NIL)*x = cons(cons($2,1),NIL); + else tl[hd[*x]] |= 1; + $$ = i; + }| + LBEGIN CONST + = { if(!isnat($2)||get_word($2)!=0) + syntax("%begin not followed by IDENTIFIER or 0\n"); + $$ = 0; }; + +lexdefs: + lexdefs LEXDEF indent '=' re outdent + = { lexdefs = cons(cons($2,$5),lexdefs); }| + /* empty */ + = { lexdefs = NIL; }; + +re: /* regular expression */ + re1 '|' re + { $$ = ap2(LEX_OR,$1,$3); }| + re1; + +re1: + lterm '/' lterm + { $$ = ap2(LEX_RCONTEXT,$1,$3); }| + lterm '/' + { $$ = ap2(LEX_RCONTEXT,$1,0); }| + lterm; + +lterm: + lfac lterm + { $$ = ap2(LEX_SEQ,$1,$2); }| + lfac; + +lfac: + lunit '*' + { if(e_re($1)) + syntax("illegal regular expression - arg of * matches empty\n"); + $$ = ap(LEX_STAR,$1); }| + lunit '+' + { $$ = ap2(LEX_SEQ,$1,ap(LEX_STAR,$1)); }| + lunit '?' + { $$ = ap(LEX_OPT,$1); }| + lunit; + +lunit: + '(' re ')' + = { $$ = $2; }| + CONST + = { if(!isstring($1)) + printf("%ssyntax error - unexpected token \"", + echoing?"\n":""), + out(stdout,$1),printf("\" in regular expression\n"), + acterror(); + $$ = $1==NILS?ap(LEX_STRING,NIL): + tl[$1]==NIL?ap(LEX_CHAR,hd[$1]): + ap(LEX_STRING,$1); + }| + CHARCLASS + = { if($1==NIL) + syntax("empty character class `` cannot match\n"); + $$ = tl[$1]==NIL?ap(LEX_CHAR,hd[$1]):ap(LEX_CLASS,$1); }| + ANTICHARCLASS + = { $$ = ap(LEX_CLASS,cons(ANTICHARCLASS,$1)); }| + '.' + = { $$ = LEX_DOT; }| + name + = { word x=lexdefs; + while(x!=NIL&&hd[hd[x]]!=$1)x=tl[x]; + if(x==NIL) + printf( + "%ssyntax error: undefined lexeme %s in regular expression\n", + echoing?"\n":"", + get_id($1)), + acterror(); + else $$ = tl[hd[x]]; }; + +name: NAME|CNAME; + +qualifiers: + exp + = { $$ = cons(cons(GUARD,$1),NIL); }| + generator + = { $$ = cons($1,NIL); }| + qualifiers ';' generator + = { $$ = cons($3,$1); }| + qualifiers ';' exp + = { $$ = cons(cons(GUARD,$3),$1); }; + +generator: + e1 ',' generator + = { /* fix syntax to disallow patlist on lhs of iterate generator */ + if(hd[$3]==GENERATOR) + { word e=tl[tl[$3]]; + if(tag[e]==AP&&tag[hd[e]]==AP&& + (hd[hd[e]]==ITERATE||hd[hd[e]]==ITERATE1)) + syntax("ill-formed generator\n"); } + $$ = cons(REPEAT,cons(genlhs($1),$3)); idsused=NIL; }| + generator1; + +generator1: + e1 LEFTARROW exp + = { $$ = cons(GENERATOR,cons(genlhs($1),$3)); idsused=NIL; }| + e1 LEFTARROW exp ',' exp DOTDOT + = { word p = genlhs($1); idsused=NIL; + $$ = cons(GENERATOR, + cons(p,ap2(irrefutable(p)?ITERATE:ITERATE1, + lambda(p,$5),$3))); + }; + +defs: + def| + defs def; + +def: + v act2 indent '=' here rhs outdent + = { word l = $1, r = $6; + word f = head(l); + if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */ + while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l]; + r = label($5,r); /* to help locate type errors */ + declare(l,r),lastname=l; }| + + spec + = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]]; + while(h!=NIL&&!SYNERR)specify(hd[h],t,hr),h=tl[h]; + $$ = cons(nill,NIL); }| + + ABSTYPE here typeforms indent WITH lspecs outdent + = { extern word TABSTRS; + extern char *dicp,*dicq; + word x=reverse($6),ids=NIL,tids=NIL; + while(x!=NIL&&!SYNERR) + specify(hd[hd[x]],cons(tl[tl[hd[x]]],NIL),hd[tl[hd[x]]]), + ids=cons(hd[hd[x]],ids),x=tl[x]; + /* each id in specs has its id_type set to const(t,NIL) as a way + of flagging that t is an abstract type */ + x=reverse($3); + while(x!=NIL&&!SYNERR) + { word shfn; + decltype(hd[x],abstract_t,undef_t,$2); + tids=cons(head(hd[x]),tids); + /* check for presence of showfunction */ + (void)strcpy(dicp,"show"); + (void)strcat(dicp,get_id(hd[tids])); + dicq = dicp+strlen(dicp)+1; + shfn=name(); + if(member(ids,shfn)) + t_showfn(hd[tids])=shfn; + x=tl[x]; } + TABSTRS = cons(cons(tids,ids),TABSTRS); + $$ = cons(nill,NIL); }| + + typeform indent act1 here EQEQ type act2 outdent + = { word x=redtvars(ap($1,$6)); + decltype(hd[x],synonym_t,tl[x],$4); + $$ = cons(nill,NIL); }| + + typeform indent act1 here COLON2EQ construction act2 outdent + = { word rhs = $6, r_ids = $6, n=0; + while(r_ids!=NIL)r_ids=tl[r_ids],n++; + while(rhs!=NIL&&!SYNERR) + { word h=hd[rhs],t=$1,stricts=NIL,i=0; + while(tag[h]==AP) + { if(tag[tl[h]]==AP&&hd[tl[h]]==strict_t) + stricts=cons(i,stricts),tl[h]=tl[tl[h]]; + t=ap2(arrow_t,tl[h],t),h=hd[h],i++; } + if(tag[h]==ID) + declconstr(h,--n,t); + /* warning - type not yet in reduced form */ + else { stricts=NIL; + if(echoing)putchar('\n'); + printf("syntax error: illegal construct \""); + out_type(hd[rhs]); + printf("\" on right of ::=\n"); + acterror(); } /* can this still happen? check later */ + if(stricts!=NIL) /* ! operators were present */ + { word k = id_val(h); + while(stricts!=NIL) + k=ap2(MKSTRICT,i-hd[stricts],k), + stricts=tl[stricts]; + id_val(h)=k; /* overwrite id_val of original constructor */ + } + r_ids=cons(h,r_ids); + rhs = tl[rhs]; } + if(!SYNERR)decltype($1,algebraic_t,r_ids,$4); + $$ = cons(nill,NIL); }| + + indent setexp EXPORT parts outdent + = { inexplist=0; + if(exports!=NIL) + errs=$2, + syntax("multiple %export statements are illegal\n"); + else { if($4==NIL&&exportfiles==NIL&&embargoes!=NIL) + exportfiles=cons(PLUS,NIL); + exports=cons($2,$4); } /* cons(hereinfo,identifiers) */ + $$ = cons(nill,NIL); }| + + FREE here '{' specs '}' + = { if(freeids!=NIL) + errs=$2, + syntax("multiple %free statements are illegal\n"); else + { word x=reverse($4); + while(x!=NIL&&!SYNERR) + { specify(hd[hd[x]],tl[tl[hd[x]]],hd[tl[hd[x]]]); + freeids=cons(head(hd[hd[x]]),freeids); + if(tl[tl[hd[x]]]==type_t) + t_class(hd[freeids])=free_t; + else id_val(hd[freeids])=FREE; /* conventional value */ + x=tl[x]; } + fil_share(hd[files])=0; /* parameterised scripts unshareable */ + freeids=alfasort(freeids); + for(x=freeids;x!=NIL;x=tl[x]) + hd[x]=cons(hd[x],cons(datapair(get_id(hd[x]),0), + id_type(hd[x]))); + /* each element of freeids is of the form + cons(id,cons(original_name,type)) */ + } + $$ = cons(nill,NIL); }| + + INCLUDE bindings modifiers outdent + /* fiddle - 'indent' done by yylex() on reading fileid */ + = { extern char *dicp; + extern word CLASHES,BAD_DUMP; + includees=cons(cons($1,cons($3,$2)),includees); + /* $1 contains file+hereinfo */ + $$ = cons(nill,NIL); }| + + here BNF { startbnf(); inbnf=1;} names outdent productions ENDIR + /* fiddle - `indent' done by yylex() while processing directive */ + = { word lhs=NIL,p=$6,subjects,body,startswith=NIL,leftrecs=NIL; + ihlist=inbnf=0; + nonterminals=UNION(nonterminals,$4); + for(;p!=NIL;p=tl[p]) + if(dval(hd[p])==UNDEF)nonterminals=add1(dlhs(hd[p]),nonterminals); + else lhs=add1(dlhs(hd[p]),lhs); + nonterminals=setdiff(nonterminals,lhs); + if(nonterminals!=NIL) + errs=$1, + member($4,hd[nonterminals])||findnt(hd[nonterminals]), + printf("%sfatal error in grammar, ",echoing?"\n":""), + printf("undefined nonterminal%s: ", + tl[nonterminals]==NIL?"":"s"), + printlist("",nonterminals), + acterror(); else + { /* compute list of nonterminals admitting empty prodn */ + eprodnts=NIL; + L:for(p=$6;p!=NIL;p=tl[p]) + if(!member(eprodnts,dlhs(hd[p]))&&eprod(dval(hd[p]))) + { eprodnts=cons(dlhs(hd[p]),eprodnts); goto L; } + /* now compute startswith reln between nonterminals + (performing binomial transformation en route) + and use to detect unremoved left recursion */ + for(p=$6;p!=NIL;p=tl[p]) + if(member(lhs=starts(dval(hd[p])),dlhs(hd[p]))) + binom(dval(hd[p]),dlhs(hd[p])), + startswith=cons(cons(dlhs(hd[p]),starts(dval(hd[p]))), + startswith); + else startswith=cons(cons(dlhs(hd[p]),lhs),startswith); + startswith=tclos(sortrel(startswith)); + for(;startswith!=NIL;startswith=tl[startswith]) + if(member(tl[hd[startswith]],hd[hd[startswith]])) + leftrecs=add1(hd[hd[startswith]],leftrecs); + if(leftrecs!=NIL) + errs=getloc(hd[leftrecs],$6), + printf("%sfatal error in grammar, ",echoing?"\n":""), + printlist("irremovable left recursion: ",leftrecs), + acterror(); + if($4==NIL) /* implied start symbol */ + $4=cons(dlhs(hd[lastlink($6)]),NIL); + fnts=1; /* fnts is flag indicating %bnf in use */ + if(tl[$4]==NIL) /* only one start symbol */ + subjects=getfname(hd[$4]), + body=ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]); + else + { body=subjects=Void; + while($4!=NIL) + subjects=pair(getfname(hd[$4]),subjects), + body=pair( + ap2(G_CLOSE,str_conv(get_id(hd[$4])),hd[$4]), + body), + $4=tl[$4]; + } + declare(subjects,label($1,block($6,body, 0))); + }}; + +setexp: + here + = { $$=$1; + inexplist=1; }; /* hack to fix lex analyser */ + +bindings: + /* empty */ + = { $$ = NIL; }| + '{' bindingseq '}' + = { $$ = $2; }; + +bindingseq: + bindingseq binding + = { $$ = cons($2,$1); }| + binding + = { $$ = cons($1,NIL); }; + +binding: + NAME indent '=' exp outdent + = { $$ = cons($1,$4); }| + typeform indent act1 EQEQ type act2 outdent + = { word x=redtvars(ap($1,$5)); + word arity=0,h=hd[x]; + while(tag[h]==AP)arity++,h=hd[h]; + $$ = ap(h,make_typ(arity,0,synonym_t,tl[x])); + }; + +modifiers: + /* empty */ + = { $$ = NIL; }| + negmods + = { word a,b,c=0; + for(a=$1;a!=NIL;a=tl[a]) + for(b=tl[a];b!=NIL;b=tl[b]) + { if(hd[hd[a]]==hd[hd[b]])c=hd[hd[a]]; + if(tl[hd[a]]==tl[hd[b]])c=tl[hd[a]]; + if(c)break; } + if(c)printf( + "%ssyntax error: conflicting aliases (\"%s\")\n", + echoing?"\n":"", + get_id(c)), + acterror(); + }; + +negmods: + negmods negmod + = { $$ = cons($2,$1); }| + negmod + = { $$ = cons($1,NIL); }; + +negmod: + NAME '/' NAME + = { $$ = cons($1,$3); }| + CNAME '/' CNAME + = { $$ = cons($1,$3); }| + '-' NAME + = { $$ = cons(make_pn(UNDEF),$2); }/*| + '-' CNAME */; /* no - cannot suppress constructors selectively */ + +here: + /* empty */ + = { extern word line_no; + lasth = $$ = fileinfo(get_fil(current_file),line_no); + /* (script,line_no) for diagnostics */ + }; + +act1: + /* empty */ + = { tvarscope=1; }; + +act2: + /* empty */ + = { tvarscope=0; idsused= NIL; }; + +ldefs: + ldef + = { $$ = cons($1,NIL); + dval($1) = tries(dlhs($1),cons(dval($1),NIL)); + if(!SYNERR&&get_ids(dlhs($1))==NIL) + errs=hd[hd[tl[dval($1)]]], + syntax("illegal lhs for local definition\n"); + }| + ldefs ldef + = { if(dlhs($2)==dlhs(hd[$1]) /*&&dval(hd[$1])!=UNDEF*/) + { $$ = $1; + if(!fallible(hd[tl[dval(hd[$1])]])) + errs=hd[dval($2)], + printf("%ssyntax error: \ +unreachable case in defn of \"%s\"\n",echoing?"\n":"",get_id(dlhs($2))), + acterror(); + tl[dval(hd[$1])]=cons(dval($2),tl[dval(hd[$1])]); } + else if(!SYNERR) + { word ns=get_ids(dlhs($2)),hr=hd[dval($2)]; + if(ns==NIL) + errs=hr, + syntax("illegal lhs for local definition\n"); + $$ = cons($2,$1); + dval($2)=tries(dlhs($2),cons(dval($2),NIL)); + while(ns!=NIL&&!SYNERR) /* local nameclash check */ + { nclashcheck(hd[ns],$1,hr); + ns=tl[ns]; } + /* potentially quadratic - fix later */ + } + }; + +ldef: + spec + = { errs=hd[tl[$1]]; + syntax("`::' encountered in local defs\n"); + $$ = cons(nill,NIL); }| + typeform here EQEQ + = { errs=$2; + syntax("`==' encountered in local defs\n"); + $$ = cons(nill,NIL); }| + typeform here COLON2EQ + = { errs=$2; + syntax("`::=' encountered in local defs\n"); + $$ = cons(nill,NIL); }| + v act2 indent '=' here rhs outdent + = { word l = $1, r = $6; + word f = head(l); + if(tag[f]==ID&&!isconstructor(f)) /* fnform defn */ + while(tag[l]==AP)r=lambda(tl[l],r),l=hd[l]; + r = label($5,r); /* to help locate type errors */ + $$ = defn(l,undef_t,r); }; + +vlist: + v + = { $$ = cons($1,NIL); }| + vlist ',' v /* left recursive so as not to eat YACC stack */ + = { $$ = cons($3,$1); }; /* reverse order, NB */ + +v: + v1 | + v1 ':' v + = { $$ = cons($1,$3); }; + +v1: + v1 '+' CONST /* n+k pattern */ + = { if(!isnat($3)) + syntax("inappropriate use of \"+\" in pattern\n"); + $$ = ap2(PLUS,$3,$1); }| + '-' CONST + = { /* if(tag[$2]==DOUBLE) + $$ = cons(CONST,sto_dbl(-get_dbl($2))); else */ + if(tag[$2]==INT) + $$ = cons(CONST,bignegate($2)); else + syntax("inappropriate use of \"-\" in pattern\n"); }| + v2 INFIXNAME v1 + = { $$ = ap2($2,$1,$3); }| + v2 INFIXCNAME v1 + = { $$ = ap2($2,$1,$3); }| + v2; + +v2: + v3 | + v2 v3 + = { $$ = ap(hd[$1]==CONST&&tag[tl[$1]]==ID?tl[$1]:$1,$2); }; + /* repeated name apparatus may have wrapped CONST around leading id + - not wanted */ + +v3: + NAME + = { if(sreds&&member(gvars,$1))syntax("illegal use of $num symbol\n"); + /* cannot use grammar variable in a binding position */ + if(memb(idsused,$1))$$ = cons(CONST,$1); + /* picks up repeated names in a template */ + else idsused= cons($1,idsused); } | + CNAME | + CONST + = { if(tag[$1]==DOUBLE) + syntax("use of floating point literal in pattern\n"); + $$ = cons(CONST,$1); }| + '[' ']' + = { $$ = nill; }| + '[' vlist ']' + = { word x=$2,y=nill; + while(x!=NIL)y = cons(hd[x],y), x = tl[x]; + $$ = y; }| + '(' ')' + = { $$ = Void; }| + '(' v ')' + = { $$ = $2; }| + '(' v ',' vlist ')' + = { if(tl[$4]==NIL)$$=pair($2,hd[$4]); + else { $$=pair(hd[tl[$4]],hd[$4]); + $4=tl[tl[$4]]; + while($4!=NIL)$$=tcons(hd[$4],$$),$4=tl[$4]; + $$ = tcons($2,$$); } + /* representation of the tuple (a1,...,an) is + tcons(a1,tcons(a2,...pair(a(n-1),an))) */ + }; + +type: + type1 | + type ARROW type + = { $$ = ap2(arrow_t,$1,$3); }; + +type1: + type2 INFIXNAME type1 + = { $$ = ap2($2,$1,$3); }| + type2; + +type2: + /* type2 argtype /* too permissive - fix later */ + /* = { $$ = ap($1,$2); }| */ + tap| + argtype; + +tap: + NAME argtype + = { $$ = ap($1,$2); }| + tap argtype + = { $$ = ap($1,$2); }; + +argtype: + NAME + = { $$ = transtypeid($1); }| + /* necessary while prelude not meta_tchecked (for prelude)*/ + typevar + = { if(tvarscope&&!memb(idsused,$1)) + printf("%ssyntax error: unbound type variable ",echoing?"\n":""), + out_type($1),putchar('\n'),acterror(); + $$ = $1; }| + '(' typelist ')' + = { $$ = $2; }| + '[' type ']' /* at release one was `typelist' */ + = { $$ = ap(list_t,$2); }| + '[' type ',' typel ']' + = { syntax( + "tuple-type with missing parentheses (obsolete syntax)\n"); }; + +typelist: + /* empty */ + = { $$ = void_t; }| /* voidtype */ + type | + type ',' typel + = { word x=$3,y=void_t; + while(x!=NIL)y = ap2(comma_t,hd[x],y), x = tl[x]; + $$ = ap2(comma_t,$1,y); }; + +typel: + type + = { $$ = cons($1,NIL); }| + typel ',' type /* left recursive so as not to eat YACC stack */ + = { $$ = cons($3,$1); }; + +parts: /* returned in reverse order */ + parts NAME + = { $$ = add1($2,$1); }| + parts '-' NAME + = { $$ = $1; embargoes=add1($3,embargoes); }| + parts PATHNAME + = { $$ = $1; }| /*the pathnames are placed on exportfiles in yylex*/ + parts '+' + = { $$ = $1; + exportfiles=cons(PLUS,exportfiles); }| + NAME + = { $$ = add1($1,NIL); }| + '-' NAME + = { $$ = NIL; embargoes=add1($2,embargoes); }| + PATHNAME + = { $$ = NIL; }| + '+' + = { $$ = NIL; + exportfiles=cons(PLUS,exportfiles); }; + +specs: /* returns a list of cons(id,cons(here,type)) + in reverse order of appearance */ + specs spec + = { word x=$1,h=hd[$2],t=tl[$2]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + $$ = x; }| + spec + = { word x=NIL,h=hd[$1],t=tl[$1]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + $$ = x; }; + +spec: + typeforms indent here COLONCOLON ttype outdent + = { $$ = cons($1,cons($3,$5)); }; + /* hack: `typeforms' includes `namelist' */ + +lspecs: /* returns a list of cons(id,cons(here,type)) + in reverse order of appearance */ + lspecs lspec + = { word x=$1,h=hd[$2],t=tl[$2]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + $$ = x; }| + lspec + = { word x=NIL,h=hd[$1],t=tl[$1]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + $$ = x; }; + +lspec: + namelist indent here {inbnf=0;} COLONCOLON type outdent + = { $$ = cons($1,cons($3,$6)); }; + +namelist: + NAME ',' namelist + = { $$ = cons($1,$3); }| + NAME + = { $$ = cons($1,NIL); }; + +typeforms: + typeforms ',' typeform act2 + = { $$ = cons($3,$1); }| + typeform act2 + = { $$ = cons($1,NIL); }; + +typeform: + CNAME typevars + = { syntax("upper case identifier out of context\n"); }| + NAME typevars /* warning if typevar is repeated */ + = { $$ = $1; + idsused=$2; + while($2!=NIL) + $$ = ap($$,hd[$2]),$2 = tl[$2]; + }| + typevar INFIXNAME typevar + = { if(eqtvar($1,$3)) + syntax("repeated type variable in typeform\n"); + idsused=cons($1,cons($3,NIL)); + $$ = ap2($2,$1,$3); }| + typevar INFIXCNAME typevar + = { syntax("upper case identifier cannot be used as typename\n"); }; + +ttype: + type| + TYPE + = { $$ = type_t; }; + +typevar: + '*' + = { $$ = mktvar(1); }| + TYPEVAR; + +typevars: + /* empty */ + = { $$ = NIL; }| + typevar typevars + = { if(memb($2,$1)) + syntax("repeated type variable on lhs of type def\n"); + $$ = cons($1,$2); }; + +construction: + constructs + = { extern word SGC; /* keeps track of sui-generis constructors */ + if( tl[$1]==NIL && tag[hd[$1]]!=ID ) + /* 2nd conjunct excludes singularity types */ + SGC=cons(head(hd[$1]),SGC); + }; + +constructs: + construct + = { $$ = cons($1,NIL); }| + constructs '|' construct + = { $$ = cons($3,$1); }; + +construct: + field here INFIXCNAME field + = { $$ = ap2($3,$1,$4); + id_who($3)=$2; }| + construct1; + +construct1: + '(' construct ')' + = { $$ = $2; }| + construct1 field1 + = { $$ = ap($1,$2); }| + here CNAME + = { $$ = $2; + id_who($2)=$1; }; + +field: + type| + argtype '!' + = { $$ = ap(strict_t,$1); }; + +field1: + argtype '!' + = { $$ = ap(strict_t,$1); }| + argtype; + +names: /* used twice - for bnf list, and for inherited attr list */ + /* empty */ + = { $$ = NIL; }| + names NAME + = { if(member($1,$2)) + printf("%ssyntax error: repeated identifier \"%s\" in %s list\n", + echoing?"\n":"",get_id($2),inbnf?"bnf":"attribute"), + acterror(); + $$ = inbnf?add1($2,$1):cons($2,$1); + }; + +productions: + lspec + = { word h=reverse(hd[$1]),hr=hd[tl[$1]],t=tl[tl[$1]]; + inbnf=1; + $$=NIL; + while(h!=NIL&&!SYNERR) + ntspecmap=cons(cons(hd[h],hr),ntspecmap), + $$=add_prod(defn(hd[h],t,UNDEF),$$,hr), + h=tl[h]; + }| + production + = { $$ = cons($1,NIL); }| + productions lspec + = { word h=reverse(hd[$2]),hr=hd[tl[$2]],t=tl[tl[$2]]; + inbnf=1; + $$=$1; + while(h!=NIL&&!SYNERR) + ntspecmap=cons(cons(hd[h],hr),ntspecmap), + $$=add_prod(defn(hd[h],t,UNDEF),$$,hr), + h=tl[h]; + }| + productions production + = { $$ = add_prod($2,$1,hd[dval($2)]); }; + +production: + NAME params ':' indent grhs outdent + /* found by experiment that indent must follow ':' here */ + = { $$ = defn($1,undef_t,$5); }; + +params: /* places inherited attributes, if any, on ihlist */ + /* empty */ + = { ihlist=0; }| + { inbnf=0; } '(' names ')' + = { inbnf=1; + if($3==NIL)syntax("unexpected token ')'\n"); + ihlist=$3; } + +grhs: + here phrase + = { $$ = label($1,$2); }; + +phrase: + error_term + = { $$ = ap2(G_ERROR,G_ZERO,$1); }| + phrase1 + = { $$=hd[$1], $1=tl[$1]; + while($1!=NIL) + $$=label(hd[$1],$$),$1=tl[$1], + $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1]; + }| + phrase1 '|' error_term + = { $$=hd[$1], $1=tl[$1]; + while($1!=NIL) + $$=label(hd[$1],$$),$1=tl[$1], + $$=ap2(G_ALT,hd[$1],$$),$1=tl[$1]; + $$ = ap2(G_ERROR,$$,$3); }; + /* we right rotate G_ALT's to facilitate left factoring (see trans) */ + +phrase1: + term + = { $$=cons($1,NIL); }| + phrase1 '|' here term + = { $$ = cons($4,cons($3,$1)); }; + +term: + count_factors + = { word n=0,f=$1,rule=Void; + /* default value of a production is () */ + /* rule=mkgvar(sreds); /* formerly last symbol */ + if(f!=NIL&&hd[f]==G_END)sreds++; + if(ihlist)rule=ih_abstr(rule); + while(n<sreds)rule=lambda(mkgvar(++n),rule); + sreds=0; + rule=ap(G_RULE,rule); + while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f]; + $$ = rule; }| + count_factors {inbnf=2;} indent '=' here rhs outdent + = { if($1!=NIL&&hd[$1]==G_END)sreds++; + if(sreds==1&&can_elide($6)) + inbnf=1,sreds=0,$$=hd[$1]; /* optimisation */ + else + { word f=$1,rule=label($5,$6),n=0; + inbnf=1; + if(ihlist)rule=ih_abstr(rule); + while(n<sreds)rule=lambda(mkgvar(++n),rule); + sreds=0; + rule=ap(G_RULE,rule); + while(f!=NIL)rule=ap2(G_SEQ,hd[f],rule),f=tl[f]; + $$ = rule; } + }; + +error_term: + ERRORSY + = { word rule = ap(K,Void); /* default value of a production is () */ + if(ihlist)rule=ih_abstr(rule); + $$ = rule; }| + ERRORSY { inbnf=2,sreds=2; } indent '=' here rhs outdent + = { word rule = label($5,$6); + if(ihlist)rule=ih_abstr(rule); + $$ = lambda(pair(mkgvar(1),mkgvar(2)),rule); + inbnf=1,sreds=0; }; + +count_factors: + EMPTYSY + = { sreds=0; $$=NIL; }| + EMPTYSY factors + = { syntax("unexpected token after empty\n"); + sreds=0; $$=NIL; }| + { obrct=0; } factors + = { word f=$2; + if(obrct) + syntax(obrct>0?"unmatched { in grammar rule\n": + "unmatched } in grammar rule\n"); + for(sreds=0;f!=NIL;f=tl[f])sreds++; + if(hd[$2]==G_END)sreds--; + $$ = $2; }; + +factors: + factor + = { $$ = cons($1,NIL); }| + factors factor + = { if(hd[$1]==G_END) + syntax("unexpected token after end\n"); + $$ = cons($2,$1); }; + +factor: + unit| + '{' unit '}' + = { $$ = ap(outdent_fn,ap2(indent_fn,getcol_fn(),$2)); }| + '{' unit + = { obrct++; + $$ = ap2(indent_fn,getcol_fn(),$2); }| + unit '}' + = { if(--obrct<0)syntax("unmatched `}' in grammar rule\n"); + $$ = ap(outdent_fn,$1); } ; + +unit: + symbol| + symbol '*' + = { $$ = ap(G_STAR,$1); }| + symbol '+' + = { $$ = ap2(G_SEQ,$1,ap2(G_SEQ,ap(G_STAR,$1),ap(G_RULE,ap(C,P)))); }| + symbol '?' + = { $$ = ap(G_OPT,$1); }; + +symbol: + NAME + = { extern word NEW; + nonterminals=newadd1($1,nonterminals); + if(NEW)ntmap=cons(cons($1,lasth),ntmap); }| + ENDSY + = { $$ = G_END; }| + CONST + = { if(!isstring($1)) + printf("%ssyntax error: illegal terminal ",echoing?"\n":""), + out(stdout,$1),printf(" (should be string-const)\n"), + acterror(); + $$ = ap(G_SYMB,$1); }| + '^' + = { $$=G_STATE; }| + {inbnf=0;} '[' exp {inbnf=1;} ']' + = { $$ = ap(G_SUCHTHAT,$3); }| + '-' + = { $$ = G_ANY; }; + +%% +/* end of MIRANDA RULES */ + diff --git a/new/steer.c b/new/steer.c new file mode 100644 index 0000000..27c238d --- /dev/null +++ b/new/steer.c @@ -0,0 +1,2208 @@ +/* MIRANDA STEER */ +/* initialisation routines and assorted routines for I/O etc */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +/* this stuff is to get the time-last-modified of files */ +#include <sys/types.h> +#include <sys/stat.h> +/* #include <sys/wait.h> /* seems not needed, oct 05 */ +struct stat buf; /* see man(2) stat - gets file status */ + +#include "data.h" +#include "lex.h" +#include <float.h> +word nill,Void; +word main_id; /* change to magic scripts 19.11.2013 */ +word message,standardout; +word diagonalise,concat,indent_fn,outdent_fn,listdiff_fn; +word shownum1,showbool,showchar,showlist,showstring,showparen,showpair, + showvoid,showfunction,showabstract,showwhat; + +char PRELUDE[pnlim+10],STDENV[pnlim+9]; + /* if anyone complains, elasticate these buffers! */ + +#define DFLTSPACE 2500000 +#define DFLTDICSPACE 100000 +/* default values for size of heap, dictionary */ +word SPACELIMIT=DFLTSPACE,DICSPACE=DFLTDICSPACE; + +#ifdef CYGWIN +#define EDITOR "joe +!" +#else +#define EDITOR "vi +!" +#endif +/* The name of whatever is locally considered to be the default editor - the + user will be able to override this using the `/editor' command. + It is also overriden by shell/environment variable EDITOR if present */ + +extern FILE *s_out; +word UTF8=0, UTF8OUT=0; +extern char *vdate, *host; +extern word version, ND; + +char *mkabsolute(char *), *strvers(word); +void fpe_error(void); + +char *editor=NULL; +word okprel=0; /* set to 1 when prelude loaded */ +word nostdenv=0; /* if set to 1 mira does not load stdenv at startup */ +/* to allow a NOSTDENV directive _in_the_script_ we would need to + (i) replace isltmess() test in rules by eg is this a list of thing, + where thing is algebraic type originally defined in STDENV + (ii) arrange to pick up <stdenv> when current script not loaded + not implemented */ +word baded=0; /* see fixeditor() */ +char *miralib=NULL; +char *mirahdr,*lmirahdr; +char *promptstr="Miranda "; +char *obsuffix="x"; +FILE *s_in=NULL; +word commandmode=0; /* true only when reading command-level expressions */ +word atobject=0,atgc=0,atcount=0,debug=0; +word magic=0; /* set to 1 means script will start with UNIX magic string */ +word making=0; /* set only for mira -make */ +word mkexports=0; /* set only for mira -exports */ +word mksources=0; /* set only for mira -sources */ +word make_status=0; /* exit status of -make */ +word compiling=1; +/* there are two types of MIRANDA process - compiling (the main process) and +subsidiary processes launched for each evaluation - the above flag tells +us which kind of process we are in */ +word ideep=0; /* depth of %include we are at, see mkincludes() */ +word SYNERR=0; +word initialising=1; +word primenv=NIL; +char *current_script; +word lastexp=UNDEF; /* value of `$$' */ +word echoing=0,listing=0,verbosity; +word strictif=1,rechecking=0; +word errline=0; /* records position of last error, for editor */ +word errs=0; /* secondary error location, in inserted script, if relevant */ +word *cstack; +extern word c; +extern char *dicp,*dicq; +char linebuf[BUFSIZE]; /* used for assorted purposes */ + /* NB cannot share with linebuf in lex.c, or !! goes wrong */ +static char ebuf[pnlim]; +word col; +char home_rc[pnlim+8]; +char lib_rc[pnlim+8]; +char *rc_error=NULL; +#define badval(x) (x<1||x>478000000) + +#include <setjmp.h> /* for longjmp() - see man (3) setjmp */ +jmp_buf env; + +#ifdef sparc8 +#include <ieeefp.h> +fp_except commonmask = FP_X_INV|FP_X_OFL|FP_X_DZ; /* invalid|ovflo|divzero */ +#endif + +main(argc,argv) /* system initialisation, followed by call to YACC */ +word argc; +char *argv[]; +{ word manonly=0; + char *home, *prs; + word okhome_rc; /* flags valid HOME/.mirarc file present */ + char *argv0=argv[0]; + char *initscript; + word badlib=0; + extern word ARGC; extern char **ARGV; + extern word newtyps,algshfns; + char *progname=rindex(argv[0],'/'); + cstack= &manonly; +/* used to indicate the base of the C stack for garbage collection purposes */ + verbosity=isatty(0); +/*if(isatty(1))*/ setbuf(stdout,NULL); /* for unbuffered tty output */ + if(home=getenv("HOME")) + { strcpy(home_rc,home); + if(strcmp(home_rc,"/")==0)home_rc[0]=0; /* root is special case */ + strcat(home_rc,"/.mirarc"); + okhome_rc=rc_read(home_rc); } +/*setup policy: + if valid HOME/.mirarc found look no further, otherwise try + <miralib>/.mirarc + Complaints - if any .mirarc contained bad data, `announce' complains about + the last such looked at. */ + UTF8OUT=UTF8=utf8test(); + while(argc>1&&argv[1][0]=='-') /* strip off flags */ + { if(strcmp(argv[1],"-stdenv")==0)nostdenv=1; else + if(strcmp(argv[1],"-count")==0)atcount=1; else + if(strcmp(argv[1],"-list")==0)listing=1; else + if(strcmp(argv[1],"-nolist")==0)listing=0; else + if(strcmp(argv[1],"-nostrictif")==0)strictif=0; else + if(strcmp(argv[1],"-gc")==0)atgc=1; else + if(strcmp(argv[1],"-object")==0)atobject=1; else + if(strcmp(argv[1],"-lib")==0) + { argc--,argv++; + if(argc==1)missparam("lib"); else miralib=argv[1]; + } else + if(strcmp(argv[1],"-dic")==0) + { argc--,argv++; + if(argc==1)missparam("dic"); else + if(sscanf(argv[1],"%d",&DICSPACE)!=1||badval(DICSPACE)) + fprintf(stderr,"mira: bad value after flag \"-dic\"\n"),exit(1); + } else + if(strcmp(argv[1],"-heap")==0) + { argc--,argv++; + if(argc==1)missparam("heap"); else + if(sscanf(argv[1],"%d",&SPACELIMIT)!=1||badval(SPACELIMIT)) + fprintf(stderr,"mira: bad value after flag \"-heap\"\n"),exit(1); + } else + if(strcmp(argv[1],"-editor")==0) + { argc--,argv++; + if(argc==1)missparam("editor"); + else editor=argv[1],fixeditor(); + } else + if(strcmp(argv[1],"-hush")==0)verbosity=0; else + if(strcmp(argv[1],"-nohush")==0)verbosity=1; else + if(strcmp(argv[1],"-exp")==0||strcmp(argv[1],"-log")==0) + fprintf(stderr,"mira: obsolete flag \"%s\"\n" + "use \"-exec\" or \"-exec2\", see manual\n", + argv[1]),exit(1); else + if(strcmp(argv[1],"-exec")==0) /* replaces -exp 26.11.2019 */ + ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; else + if(strcmp(argv[1],"-exec2")==0) /* version of -exec for debugging CGI scripts */ + { if(argc<=2)fprintf(stderr,"incorrect use of -exec2 flag, missing filename\n"),exit(1); + char *logfilname, *p=strrchr(argv[2],'/'); + FILE *fil=NULL; + if(!p)p=argv[2]; /* p now holds last component of prog name */ + if(logfilname=malloc((strlen(p)+9))) + sprintf(logfilname,"miralog/%s",p), + fil=fopen(logfilname,"a"); + else mallocfail("logfile name"); + /* process requires write permission on local directory "miralog" */ + if(fil)dup2(fileno(fil),2); /* redirect stderr to log file */ + else fprintf(stderr,"could not open %s\n",logfilname); + ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; } else + if(strcmp(argv[1],"-man")==0){ manonly=1; break; } else + if(strcmp(argv[1],"-version")==0)v_info(0),exit(0); else + if(strcmp(argv[1],"-V")==0)v_info(1),exit(0); else + if(strcmp(argv[1],"-make")==0) making=1,verbosity=0; else + if(strcmp(argv[1],"-exports")==0) making=mkexports=1,verbosity=0; else + if(strcmp(argv[1],"-sources")==0) making=mksources=1,verbosity=0; else + if(strcmp(argv[1],"-UTF-8")==0) UTF8=1; else + if(strcmp(argv[1],"-noUTF-8")==0) UTF8=0; else + fprintf(stderr,"mira: unknown flag \"%s\"\n",argv[1]),exit(1); + argc--,argv++; } + if(argc>2&&!magic&&!making)fprintf(stderr,"mira: too many args\n"),exit(1); + if(!miralib) /* no -lib flag */ + { char *m; + /* note search order */ + if((m=getenv("MIRALIB")))miralib=m; else + if(checkversion(m="/usr/lib/miralib"))miralib=m; else + if(checkversion(m="/usr/local/lib/miralib"))miralib=m; else + if(checkversion(m="miralib"))miralib=m; else + badlib=1; + } + if(badlib) + { fprintf(stderr,"fatal error: miralib version %s not found\n", + strvers(version)); + libfails(); + exit(1); + } + if(!okhome_rc) + { if(rc_error==lib_rc)rc_error=NULL; + (void)strcpy(lib_rc,miralib); + (void)strcat(lib_rc,"/.mirarc"); + rc_read(lib_rc); } + if(editor==NULL) /* .mirarc was absent or unreadable */ + { editor=getenv("EDITOR"); + if(editor==NULL)editor=EDITOR; + else strcpy(ebuf,editor),editor=ebuf,fixeditor(); } + if(prs=getenv("MIRAPROMPT"))promptstr=prs; + if(getenv("RECHECKMIRA")&&!rechecking)rechecking=1; + if(getenv("NOSTRICTIF"))strictif=0; + setupdic(); /* used by mkabsolute */ + s_in=stdin; + s_out=stdout; + miralib=mkabsolute(miralib); /* protection against "/cd" */ + if(manonly)manaction(),exit(0); + (void)strcpy(PRELUDE,miralib); (void)strcat(PRELUDE,"/prelude"); + /* convention - change spelling of "prelude" at each release */ + (void)strcpy(STDENV,miralib); + (void)strcat(STDENV,"/stdenv.m"); + mira_setup(); + if(verbosity)announce(); + files=NIL; + undump(PRELUDE),okprel=1; + mkprivate(fil_defs(hd[files])); + files=NIL; /* don't wish unload() to unsetids on prelude */ + if(!nostdenv) + { undump(STDENV); + while(files!=NIL) /* stdenv may have %include structure */ + primenv=alfasort(append1(primenv,fil_defs(hd[files]))), + files=tl[files]; + primenv=alfasort(primenv); + newtyps=files=NIL; /* don't wish unload() to unsetids */ } + if(!magic)rc_write(); + echoing = verbosity&listing; + initialising=0; + if(mkexports) + { /* making=1, to say if recompiling, also to undump as for %include */ + word f,argcount=argc-1; + extern word exports,freeids; + char *s; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) /* where do error messages go?? */ + { word x=NIL; + s=addextn(1,*++argv); + if(s==dicp)keep(dicp); + undump(s); /* bug, recompile messages goto stdout - FIX LATER */ + if(files==NIL||ND!=NIL)continue; + if(argcount!=1)printf("%s\n",s); + if(exports!=NIL)x=exports; + /* true (if ever) only if just recompiled */ + else for(f=files;f!=NIL;f=tl[f])x=append1(fil_defs(hd[f]),x); + /* method very clumsy, because exports not saved in dump */ + if(freeids!=NIL) + { word f=freeids; + while(f!=NIL) + { word n=findid((char *)hd[hd[tl[hd[f]]]]); + id_type(n)=tl[tl[hd[f]]]; + id_val(n)=the_val(hd[hd[f]]); + hd[f]=n; + f=tl[f]; } + f=freeids=typesfirst(freeids); + printf("\t%%free {\n"); + while(f!=NIL) + putchar('\t'), + report_type(hd[f]), + putchar('\n'), + f=tl[f]; + printf("\t}\n"); } + for(x=typesfirst(alfasort(x));x!=NIL;x=tl[x]) + { putchar('\t'); + report_type(hd[x]); + putchar('\n'); } } + exit(0); } + if(mksources){ extern word oldfiles; + char *s; + word f,x=NIL; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) + if(stat((s=addextn(1,*++argv)),&buf)==0) + { if(s==dicp)keep(dicp); + undump(s); + for(f=files==NIL?oldfiles:files;f!=NIL;f=tl[f]) + if(!member(x,(word)get_fil(hd[f]))) + x=cons((word)get_fil(hd[f]),x), + printf("%s\n",get_fil(hd[f])); + } + exit(0); } + if(making){ extern word oldfiles; + char *s; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) /* where do error messages go?? */ + { s=addextn(1,*++argv); + if(s==dicp)keep(dicp); + undump(s); + if(ND!=NIL||files==NIL&&oldfiles!=NIL) + { if(make_status==1)make_status=0; + make_status=strcons(s,make_status); } + /* keep list of source files with error-dumps */ + } + if(tag[make_status]==STRCONS) + { word h=0,maxw=0,w,n; + printf("errors or undefined names found in:-\n"); + while(make_status) /* reverse to get original order */ + { h=strcons(hd[make_status],h); + w=strlen((char *)hd[h]); + if(w>maxw)maxw=w; + make_status=tl[make_status]; } + maxw++;n=78/maxw;w=0; + while(h) + printf("%*s%s",maxw,(char *)hd[h],(++w%n)?"":"\n"), + h=tl[h]; + if(w%n)printf("\n"); + make_status=1; } + exit(make_status); } + initscript= argc==1?"script.m":magic?argv[1]:addextn(1,argv[1]); + if(initscript==dicp)keep(dicp); +#if sparc8 + fpsetmask(commonmask); +#elif defined sparc + ieee_handler("set","common",(sighandler)fpe_error); +#endif +#if !defined sparc | sparc8 + (void)signal(SIGFPE,(sighandler)fpe_error); /* catch arithmetic overflow */ +#endif + (void)signal(SIGTERM,(sighandler)exit); /* flush buffers if killed */ + commandloop(initscript); + /* parameter is file given as argument */ +} + +word vstack[4]; /* record of miralib versions looked at */ +char *mstack[4]; /* and where found */ +word mvp=0; + +checkversion(m) +/* returns 1 iff m is directory with .version containing our version number */ +char *m; +{ word v1,read=0,r=0; + FILE *f=fopen(strcat(strcpy(linebuf,m),"/.version"),"r"); + if(f&&fscanf(f,"%u",&v1)==1)r= v1==version, read=1; + if(f)fclose(f); + if(read&&!r)mstack[mvp]=m,vstack[mvp++]=v1; + return r; +} + +libfails() +{ word i=0; + fprintf(stderr,"found"); + for(;i<mvp;i++)fprintf(stderr,"\tversion %s at: %s\n", + strvers(vstack[i]),mstack[i]); +} + +char *strvers(v) +{ static char vbuf[12]; + if(v<0||v>999999)return "\?\?\?"; + snprintf(vbuf,12,"%.3f",v/1000.0); + return vbuf; +} + +char *mkabsolute(m) /* make sure m is an absolute pathname */ +char *m; +{ if(m[0]=='/')return(m); + if(!getcwd(dicp,pnlim))fprintf(stderr,"panic: cwd too long\n"),exit(1); + (void)strcat(dicp,"/"); + (void)strcat(dicp,m); + m=dicp; + dicp=dicq+=strlen(dicp)+1; + dic_check(); + return(m); +} + +missparam(s) +char *s; +{ fprintf(stderr,"mira: missing param after flag \"-%s\"\n",s); + exit(1); } + +word oldversion=0; +#define colmax 400 +#define spaces(s) for(j=s;j>0;j--)putchar(' ') + +announce() +{ extern char *vdate; + word w,j; +/*clrscr(); /* clear screen on start up */ + w=(twidth()-50)/2; + printf("\n\n"); + spaces(w); printf(" T h e M i r a n d a S y s t e m\n\n"); + spaces(w+5-strlen(vdate)/2); + printf(" version %s last revised %s\n\n",strvers(version),vdate); + spaces(w); printf("Copyright Research Software Ltd 1985-2019\n\n"); + spaces(w); printf(" World Wide Web: http://miranda.org.uk\n\n\n"); + if(SPACELIMIT!=DFLTSPACE) + printf("(%d cells)\n",SPACELIMIT); + if(!strictif)printf("(-nostrictif : deprecated!)\n"); +/*printf("\t\t\t\t%dbit platform\n",__WORDSIZE); /* */ + if(oldversion<1999) /* pre release two */ + printf("\ +WARNING:\n\ +a new release of Miranda has been installed since you last used\n\ +the system - please read the `CHANGES' section of the /man pages !!!\n\n"); + else + if(version>oldversion) + printf("a new version of Miranda has been installed since you last\n"), + printf("used the system - see under `CHANGES' in the /man pages\n\n"); + if(version<oldversion) + printf("warning - this is an older version of Miranda than the one\n"), + printf("you last used on this machine!!\n\n"); + if(rc_error) + printf("warning: \"%s\" contained bad data (ignored)\n",rc_error); +} + + +rc_read(rcfile) /* get settings of system parameters from setup file */ +char *rcfile; +{ FILE *in; + char z[20]; + word h,d,v,s,r=0; + oldversion=version; /* default assumption */ + in=fopen(rcfile,"r"); + if(in==NULL||fscanf(in,"%19s",z)!=1) + return(0); /* file not present, or not readable */ + if(strncmp(z,"hdve",4)==0 /* current .mirarc format */ + ||strcmp(z,"lhdve")==0) /* alternative format used at release one */ + { char *z1 = &z[3]; + if(z[0]=='l')listing=1,z1++; + while(*++z1)if(*z1=='l')listing=1; else + if(*z1=='s') /* ignore */; else + if(*z1=='r')rechecking=2; else + rc_error=rcfile; + if(fscanf(in,"%d%d%d%*c",&h,&d,&v)!=3||!getln(in,pnlim-1,ebuf) + ||badval(h)||badval(d)||badval(v))rc_error=rcfile; + else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1, + oldversion=v; } else + if(strcmp(z,"ehdsv")==0) /* versions before 550 */ + { if(fscanf(in,"%19s%d%d%d%d",ebuf,&h,&d,&s,&v)!=5 + ||badval(h)||badval(d)||badval(v))rc_error=rcfile; + else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1, + oldversion=v; } else + if(strcmp(z,"ehds")==0) /* versions before 326, "s" was stacklimit (ignore) */ + { if(fscanf(in,"%s%d%d%d",ebuf,&h,&d,&s)!=4 + ||badval(h)||badval(d))rc_error=rcfile; + else editor=ebuf,SPACELIMIT=h,DICSPACE=d,r=1, + oldversion=1; } + else rc_error=rcfile; /* unrecognised format */ + if(editor)fixeditor(); + fclose(in); + return(r); +} + +fixeditor() +{ if(strcmp(editor,"vi")==0)editor="vi +!"; else + if(strcmp(editor,"pico")==0)editor="pico +!"; else + if(strcmp(editor,"nano")==0)editor="nano +!"; else + if(strcmp(editor,"joe")==0)editor="joe +!"; else + if(strcmp(editor,"jpico")==0)editor="jpico +!"; else + if(strcmp(editor,"vim")==0)editor="vim +!"; else + if(strcmp(editor,"gvim")==0)editor="gvim +! % &"; else + if(strcmp(editor,"emacs")==0)editor="emacs +! % &"; + else { char *p=rindex(editor,'/'); + if(p==0)p=editor; else p++; + if(strcmp(p,"vi")==0)strcat(p," +!"); + } + if(rindex(editor,'&'))rechecking=2; + listing=badeditor(); +} + +badeditor() /* does editor know how to open file at line? */ +{ char *p=index(editor,'!'); + while(p&&p[-1]=='\\')p=index(p+1,'!'); + return (baded = !p); +} + +getln(in,n,s) /* reads line (<=n chars) from in into s - returns 1 if ok */ +FILE *in; /* the newline is discarded, and the result '\0' terminated */ +word n; +char *s; +{ while(n--&&(*s=getc(in))!='\n')s++; + if(*s!='\n'||n<0)return(0); + *s='\0'; + return(1); +} /* what a pain that `fgets' doesn't do it right !! */ + +rc_write() +{ FILE *out=fopen(home_rc,"w"); + if(out==NULL) + { fprintf(stderr,"warning: cannot write to \"%s\"\n",home_rc); + return; } + fprintf(out,"hdve"); + if(listing)fputc('l',out); + if(rechecking==2)fputc('r',out); + fprintf(out," %d %d %d %s\n",SPACELIMIT,DICSPACE,version,editor); + fclose(out); +} + +word lastid=0; /* first inscope identifier of immediately preceding command */ +word rv_expr=0; + +commandloop(initscript) +char* initscript; +{ word ch; + word reset(); + extern word cook_stdin,polyshowerror; + char *lb; + if(setjmp(env)==0) /* returns here if interrupted, 0 means first time thru */ + { if(magic){ undump(initscript); /* was loadfile() changed 26.11.2019 + to allow dump of magic scripts in ".m"*/ + if(files==NIL||ND!=NIL||id_val(main_id)==UNDEF) + /* files==NIL=>script absent or has syntax errors + ND!=NIL=>script has type errors or undefined names + all reported by undump() or loadfile() on new compile */ + { if(files!=NIL&&ND==NIL&&id_val(main_id)==UNDEF) + fprintf(stderr,"%s: main not defined\n",initscript); + fprintf(stderr,"mira: incorrect use of \"-exec\" flag\n"); + exit(1); } + magic=0; obey(main_id); exit(0); } + /* was obey(lastexp), change to magic scripts 19.11.2013 */ + (void)signal(SIGINT,(sighandler)reset); + undump(initscript); + if(verbosity)printf("for help type /h\n"); } + for(;;) + { resetgcstats(); + if(verbosity)printf("%s",promptstr); + ch = getchar(); + if(rechecking&&src_update())loadfile(current_script); + /* modified behaviour for `2-window' mode */ + while(ch==' '||ch=='\t')ch=getchar(); + switch(ch) + { case '?': ch=getchar(); + if(ch=='?') + { word x; char *aka=NULL; + if(!token()&&!lastid) + { printf("\7identifier needed after `\?\?'\n"); + ch=getchar(); /* '\n' */ + break; } + if(getchar()!='\n'){ xschars(); break; } + if(baded){ ed_warn(); break; } + if(dicp[0])x=findid(dicp); + else printf("??%s\n",get_id(lastid)),x=lastid; + if(x==NIL||id_type(x)==undef_t) + { diagnose(dicp[0]?dicp:get_id(lastid)); + lastid=0; + break; } + if(id_who(x)==NIL) + { /* nb - primitives have NIL who field */ + printf("%s -- primitive to Miranda\n", + dicp[0]?dicp:get_id(lastid)); + lastid=0; + break; } + lastid=x; + x=id_who(x); /* get here info */ + if(tag[x]==CONS)aka=(char *)hd[hd[x]],x=tl[x]; + if(aka)printf("originally defined as \"%s\"\n", + aka); + editfile((char *)hd[x],tl[x]); + break; } + ungetc(ch,stdin); + (void)token(); + lastid=0; + if(dicp[0]=='\0') + { if(getchar()!='\n')xschars(); + else allnamescom(); + break; } + while(dicp[0])finger(dicp),(void)token(); + ch=getchar(); + break; + case ':': /* add (silently) as kindness to Hugs users */ + case '/': (void)token(); + lastid=0; + command(ch); + break; + case '!': if(!(lb=rdline()))break; /* rdline returns NULL on failure */ + lastid=0; + if(*lb) + { /*system(lb); */ /* always gives /bin/sh */ + static char *shell=NULL; + sighandler oldsig; + word pid; + if(!shell) + { shell=getenv("SHELL"); + if(!shell)shell="/bin/sh"; } + oldsig= signal(SIGINT,SIG_IGN); + if(pid=fork()) + { /* parent */ + if(pid==-1) + perror("UNIX error - cannot create process"); + while(pid!=wait(0)); + (void)signal(SIGINT,oldsig); } + else execl(shell,shell,"-c",lb,(char *)0); + if(src_update())loadfile(current_script); } + else printf( + "No previous shell command to substitute for \"!\"\n"); + break; + case '|': /* lines beginning "||" are comments */ + if((ch=getchar())!='|') + printf("\7unknown command - type /h for help\n"); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + case '\n': break; + case EOF: if(verbosity)printf("\nmiranda logout\n"); + exit(0); + default: ungetc(ch,stdin); + lastid=0; + tl[hd[cook_stdin]]=0; /* unset type of $+ */ + rv_expr=0; + c = EVAL; + echoing=0; + polyshowerror=0; /* gets set by wrong use of $+, readvals */ + commandmode=1; + yyparse(); + if(SYNERR)SYNERR=0; + else if(c!='\n') /* APPARENTLY NEVER TRUE */ + { printf("syntax error\n"); + while(c!='\n'&&c!=EOF) + c=getchar(); /* swallow syntax errors */ + } + commandmode=0; + echoing=verbosity&listing; +}}} + +parseline(t,f,fil) /* parses next valid line of f at type t, returns EOF + if none found. See READVALS in reduce.c */ +word t; +FILE *f; +word fil; +{ word t1,ch; + lastexp=UNDEF; + for(;;) + { ch=getc(f); + while(ch==' '||ch=='\t'||ch=='\n')ch=getc(f); + if(ch=='|') + { ch=getc(f); + if(ch=='|') /* leading comment */ + { while((ch=getc(f))!='\n'&&ch!=EOF); + if(ch!=EOF)continue; } + else ungetc(ch,f); } + if(ch==EOF)return(EOF); + ungetc(ch,f); + c = VALUE; + echoing=0; + commandmode=1; + s_in=f; + yyparse(); + s_in=stdin; + if(SYNERR)SYNERR=0,lastexp=UNDEF; else + if((t1=type_of(lastexp))==wrong_t)lastexp=UNDEF; else + if(!subsumes(instantiate(t1),t)) + { printf("data has wrong type :: "), out_type(t1), + printf("\nshould be :: "), out_type(t), putc('\n',stdout); + lastexp=UNDEF; } + if(lastexp!=UNDEF)return(codegen(lastexp)); + if(isatty(fileno(f)))printf("please re-enter data:\n"); + else { if(fil)fprintf(stderr,"readvals: bad data in file \"%s\"\n", + getstring(fil,0)); + else fprintf(stderr,"bad data in $+ input\n"); + outstats(); exit(1); } +}} + +ed_warn() +{ printf( +"The currently installed editor command, \"%s\", does not\n\ +include a facility for opening a file at a specified line number. As a\n\ +result the `\?\?' command and certain other features of the Miranda system\n\ +are disabled. See manual section 31/5 on changing the editor for more\n\ +information.\n",editor); +} + +time_t fm_time(f) /* time last modified of file f */ +char *f; +{ return(stat(f,&buf)==0?buf.st_mtime:0); + /* non-existent file has conventional mtime of 0 */ +} /* WARNING - we assume time_t can be stored in an int field + - this may not port */ + +#define same_file(x,y) (hd[fil_inodev(x)]==hd[fil_inodev(y)]&& \ + tl[fil_inodev(x)]==tl[fil_inodev(y)]) +#define inodev(f) (stat(f,&buf)==0?datapair(buf.st_ino,buf.st_dev):\ + datapair(0,-1)) + +word oldfiles=NIL; /* most recent set of sources, in case of interrupted or + failed compilation */ +src_update() /* any sources modified ? */ +{ word ft,f=files==NIL?oldfiles:files; + while(f!=NIL) + { if((ft=fm_time(get_fil(hd[f])))!=fil_time(hd[f])) + { if(ft==0)unlinkx(get_fil(hd[f])); /* tidy up after eg `!rm %' */ + return(1); } + f=tl[f]; } + return(0); +} + +word loading; +char *unlinkme; /* if set, is name of partially created obfile */ + +reset() /* interrupt catcher - see call to signal in commandloop */ +{ extern word lineptr,ATNAMES,current_id; + extern word blankerr,collecting/* ,*dstack,*stackp */; + /*if(!making) /* see note below + (void)signal(SIGINT,SIG_IGN); /* dont interrupt me while I'm tidying up */ +/*if(magic)exit(0); *//* signal now not set to reset in magic scripts */ + if(collecting)gcpatch(); + if(loading) + { if(!blankerr) + printf("\n<<compilation interrupted>>\n"); + if(unlinkme)unlink(unlinkme); + /* stackp=dstack; /* add if undump() made interruptible later*/ + oldfiles=files,unload(),current_id=ATNAMES=loading=SYNERR=lineptr=0; + if(blankerr)blankerr=0,makedump(); } + /* magic script cannot be literate so no guard needed on makedump */ + else printf("<<interrupt>>\n"); /* VAX, SUN, ^C does not cause newline */ + reset_state(); /* see LEX */ + if(collecting)collecting=0,gc(); /* to mark stdenv etc as wanted */ + if(making&&!make_status)make_status=1; +#ifdef SYSTEM5 + else (void)signal(SIGINT,(sighandler)reset);/*ready for next interrupt*//*see note*/ +#endif + /* during mira -make blankerr is only use of reset */ + longjmp(env,1); +}/* under BSD and Linux installed signal remains installed after interrupt + and further signals blocked until handler returns */ + +#define checkeol if(getchar()!='\n')break; + +word lose; + +normal(f) /* s has ".m" suffix */ +char *f; +{ word n=strlen(f); + return n>=2&&strcmp(f+n-2,".m")==0; +} + +v_info(word full) +{ printf("%s last revised %s\n",strvers(version),vdate); + if(!full)return; + printf("%s",host); + printf("XVERSION %u\n",XVERSION); +} + + +command(c) +word c; +{ char *t; + word ch,ch1; + switch(dicp[0]) + { + case 'a': if(is("a")||is("aux")) + { checkeol; +/* if(verbosity)clrscr(); */ + (void)strcpy(linebuf,miralib); + (void)strcat(linebuf,"/auxfile"); + filecopy(linebuf); + return; } + case 'c': if(is("count")) + { checkeol; atcount=1; return; } + if(is("cd")) + { char *d=token(); + if(!d)d=getenv("HOME"); + else d=addextn(0,d); + checkeol; + if(chdir(d)==-1)printf("cannot cd to %s\n",d); + else if(src_update())undump(current_script); + /* alternative: keep old script and recompute pathname + wrt new directory - LOOK INTO THIS LATER */ + return; } + case 'd': if(is("dic")) + { extern char *dic; + if(!token()) + { lose=getchar(); /* to eat \n */ + printf("%d chars",DICSPACE); + if(DICSPACE!=DFLTDICSPACE) + printf(" (default=%d)",DFLTDICSPACE); + printf(" %d in use\n",dicq-dic); + return; } + checkeol; + printf( + "sorry, cannot change size of dictionary while in use\n"); + printf( + "(/q and reinvoke with flag: mira -dic %s ... )\n",dicp); + return; } + case 'e': if(is("e")||is("edit")) + { char *mf=0; + if(t=token())t=addextn(1,t); + else t=current_script; + checkeol; + if(stat(t,&buf)) /* new file */ + { if(!lmirahdr) /* lazy initialisation */ + { dicp=dicq; + (void)strcpy(dicp,getenv("HOME")); + if(strcmp(dicp,"/")==0) + dicp[0]=0; /* root is special case */ + (void)strcat(dicp,"/.mirahdr"); + lmirahdr=dicp; + dicq=dicp=dicp+strlen(dicp)+1; } /* ovflo check? */ + if(!stat(lmirahdr,&buf))mf=lmirahdr; + if(!mf&&!mirahdr) /* lazy initialisation */ + { dicp=dicq; + (void)strcpy(dicp,miralib); + (void)strcat(dicp,"/.mirahdr"); + mirahdr=dicp; + dicq=dicp=dicp+strlen(dicp)+1; } + if(!mf&&!stat(mirahdr,&buf))mf=mirahdr; + /*if(mf)printf("mf=%s\n",mf); /* DEBUG*/ + if(mf&&t!=current_script) + { printf("open new script \"%s\"? [ny]",t); + ch1=ch=getchar(); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + /*eat rest of line */ + if(ch1!='y'&&ch1!='Y')return; } + if(mf)filecp(mf,t); } + editfile(t,strcmp(t,current_script)==0?errline: + errs&&strcmp(t,(char *)hd[errs])==0?tl[errs]: + geterrlin(t)); + return; } + if(is("editor")) + { char *hold=linebuf,*h; + if(!getln(stdin,pnlim-1,hold))break; /*reject if too long*/ + if(!*hold) + { /* lose=getchar(); /* to eat newline */ + printf("%s\n",editor); + return; } + h=hold+strlen(hold); /* remove trailing white space */ + while(h[-1]==' '||h[-1]=='\t')*--h='\0'; + if(*hold=='"'||*hold=='\'') + { printf("please type name of editor without quotation marks\n"); + return; } + printf("change editor to: \"%s\"? [ny]",hold); + ch1=ch=getchar(); + while(ch!='\n'&&ch!=EOF)ch=getchar(); /* eat rest of line */ + if(ch1!='y'&&ch1!='Y') + { printf("editor not changed\n"); + return; } + (void)strcpy(ebuf,hold); + editor=ebuf; + fixeditor(); /* reads "vi" as "vi +!" etc */ + echoing=verbosity&listing; + rc_write(); + printf("editor = %s\n",editor); + return; } + case 'f': if(is("f")||is("file")) + { char *t=token(); + checkeol; + if(t)t=addextn(1,t),keep(t); + /* could get multiple copies of filename in dictionary + - FIX LATER */ + if(t)errs=errline=0; /* moved here from reset() */ + if(t)if(strcmp(t,current_script)||files==NIL&&okdump(t)) + { extern word CLASHES; + CLASHES=NIL; /* normally done by load_script */ + undump(t); /* does not always call load_script */ + if(CLASHES!=NIL)/* pathological case, recompile */ + loadfile(t); } + else loadfile(t); /* force recompilation */ + else printf("%s%s\n",current_script, + files==NIL?" (not loaded)":""); + return; } + if(is("files")) /* info about internal state, not documented */ + { word f=files; + checkeol; + for(;f!=NIL;f=tl[f]) + printf("(%s,%d,%d)",get_fil(hd[f]),fil_time(hd[f]), + fil_share(hd[f])),printlist("",fil_defs(hd[f])); + return; } /* DEBUG */ + if(is("find")) + { word i=0; + while(token()) + { word x=findid(dicp),y,f; + i++; + if(x!=NIL) + { char *n=get_id(x); + for(y=primenv;y!=NIL;y=tl[y]) + if(tag[hd[y]]==ID) + if(hd[y]==x||getaka(hd[y])==n) + finger(get_id(hd[y])); + for(f=files;f!=NIL;f=tl[f]) + for(y=fil_defs(hd[f]);y!=NIL;y=tl[y]) + if(tag[hd[y]]==ID) + if(hd[y]==x||getaka(hd[y])==n) + finger(get_id(hd[y])); } + } + ch=getchar(); /* '\n' */ + if(i==0)printf("\7identifier needed after `/find'\n"); + return; } + case 'g': if(is("gc")) + { checkeol; atgc=1; return; } + case 'h': if(is("h")||is("help")) + { checkeol; +/* if(verbosity)clrscr(); */ + (void)strcpy(linebuf,miralib); + (void)strcat(linebuf,"/helpfile"); + filecopy(linebuf); + return; } + if(is("heap")) + { word x; + if(!token()) + { lose=getchar(); /* to eat \n */ + printf("%d cells",SPACELIMIT); + if(SPACELIMIT!=DFLTSPACE) + printf(" (default=%d)",DFLTSPACE); + printf("\n"); + return; } + checkeol; + if(sscanf(dicp,"%d",&x)!=1||badval(x)) + { printf("illegal value (heap unchanged)\n"); return; } + if(x<trueheapsize()) + printf("sorry, cannot shrink heap to %d at this time\n",x); + else { if(x!=SPACELIMIT) + SPACELIMIT=x,resetheap(); + printf("heaplimit = %d cells\n",SPACELIMIT), + rc_write(); } + return; } + if(is("hush")) + { checkeol; echoing=verbosity=0; return; } + case 'l': if(is("list")) + { checkeol; listing=1; echoing=verbosity&listing; + rc_write(); return; } + case 'm': if(is("m")||is("man")) + { checkeol; manaction(); return; } + if(is("miralib")) + { checkeol; printf("%s\n",miralib); return; } + case 'n': /* if(is("namebuckets")) + { int i,x; + extern int namebucket[]; + checkeol; + for(i=0;i<128;i++) + if(x=namebucket[i]) + { printf("%d:",i); + while(x) + putchar(' '),out(stdout,hd[x]),x=tl[x]; + putchar('\n'); } + return; } /* DEBUG */ + if(is("nocount")) + { checkeol; atcount=0; return; } + if(is("nogc")) + { checkeol; atgc=0; return; } + if(is("nohush")) + { checkeol; echoing=listing; verbosity=1; return; } + if(is("nolist")) + { checkeol; echoing=listing=0; rc_write(); return; } + if(is("norecheck")) + { checkeol; rechecking=0; rc_write(); return; } +/* case 'o': if(is("object")) + { checkeol; atobject=1; return; } /* now done by flag -object */ + case 'q': if(is("q")||is("quit")) + { checkeol; if(verbosity)printf("miranda logout\n"); exit(0); } + case 'r': if(is("recheck")) + { checkeol; rechecking=2; rc_write(); return; } + case 's': if(is("s")||is("settings")) + { checkeol; + printf("*\theap %d\n",SPACELIMIT); + printf("*\tdic %d\n",DICSPACE); + printf("*\teditor = %s\n",editor); + printf("*\t%slist\n",listing?"":"no"); + printf("*\t%srecheck\n",rechecking?"":"no"); + if(!strictif) + printf("\t-nostrictif (deprecated!)\n"); + if(atcount)printf("\tcount\n"); + if(atgc)printf("\tgc\n"); + if(UTF8)printf("\tUTF-8 i/o\n"); + if(!verbosity)printf("\thush\n"); + if(debug)printf("\tdebug 0%o\n",debug); + printf("\n* items remembered between sessions\n"); + return; } + case 'v': if(is("v")||is("version")) + { checkeol; + v_info(0); + return; } + case 'V': if(is("V")) + { checkeol; + v_info(1); + return; } + default: printf("\7unknown command \"%c%s\"\n",c,dicp); + printf("type /h for help\n"); + while((ch=getchar())!='\n'&&ch!=EOF); + return; + } /* end of switch statement */ + xschars(); +} + +manaction() +{ sprintf(linebuf,"\"%s/menudriver\" \"%s/manual\"",miralib,miralib); + system(linebuf); +} /* put quotes around both pathnames to allow for spaces in miralib 8.5.06 */ + +editfile(t,line) +char *t; +word line; +{ char *ebuf=linebuf; + char *p=ebuf,*q=editor; + word tdone=0; + if(line==0)line=1; /* avoids warnings in some versions of vi */ + while(*p++ = *q++) + if(p[-1]=='\\'&&(q[0]=='!'||q[0]=='%'))p[-1]= *q++; else + if(p[-1]=='!') + (void) + sprintf(p-1,"%d",line), + p+=strlen(p); else + if(p[-1]=='%')p[-1]='"',*p='\0', /* quote filename 9.5.06 */ + (void)strncat(p,t,BUFSIZE+ebuf-p), + p+=strlen(p), + *p++ = '"',*p='\0', + tdone=1; + if(!tdone) + p[-1] = ' ', + *p++ = '"',*p='\0', /* quote filename 9.5.06 */ + (void)strncat(p,t,BUFSIZE+ebuf-p), + p+=strlen(p), + *p++ = '"',*p='\0'; + /* printf("%s\n",ebuf); /* DEBUG */ + system(ebuf); + if(src_update())loadfile(current_script); + return; +} + +xschars() +{ word ch; + printf("\7extra characters at end of command\n"); + while((ch=getchar())!='\n'&&ch!=EOF); +} + +reverse(x) /* x is a cons list */ +word x; +{ word y = NIL; + while(x!=NIL)y = cons(hd[x],y), x = tl[x]; + return(y); +} + +shunt(x,y) /* equivalent to append(reverse(x),y) */ +word x,y; +{ while(x!=NIL)y = cons(hd[x],y), x = tl[x]; + return(y); +} + +char *presym[] = + {"abstype","div","if","mod","otherwise","readvals","show","type","where", + "with", 0}; +word presym_n[] = + { 21, 8, 15, 8, 15, 31, 23, 22, 15, + 21 }; + +#include <ctype.h> + +filequote(p) /* write p to stdout with <quotes> if appropriate */ +char *p; /* p is a pathname */ +{ static mlen=0; + if(!mlen)mlen=(rindex(PRELUDE,'/')-PRELUDE)+1; + if(strncmp(p,PRELUDE,mlen)==0) + printf("<%s>",p+mlen); + else printf("\"%s\"",p); +} /* PRELUDE is a convenient string with the miralib prefix */ + +finger(n) /* find info about name stored at dicp */ +char *n; +{ word x,line; + char *s; + x=findid(n); + if(x!=NIL&&id_type(x)!=undef_t) + { if(id_who(x)!=NIL) + s=(char *)hd[line=get_here(x)],line=tl[line]; + if(!lastid)lastid=x; + report_type(x); + if(id_who(x)==NIL)printf(" ||primitive to Miranda\n"); + else { char *aka=getaka(x); + if(aka==get_id(x))aka=NULL; /* don't report alias to self */ + if(id_val(x)==UNDEF&&id_type(x)!=wrong_t) + printf(" ||(UNDEFINED) specified in "); else + if(id_val(x)==FREE) + printf(" ||(FREE) specified in "); else + if(id_type(x)==type_t&&t_class(x)==free_t) + printf(" ||(free type) specified in "); else + printf(" ||%sdefined in ", + id_type(x)==type_t + && t_class(x)==abstract_t?"(abstract type) ": + id_type(x)==type_t + && t_class(x)==algebraic_t?"(algebraic type) ": + id_type(x)==type_t + && t_class(x)==placeholder_t?"(placeholder type) ": + id_type(x)==type_t + && t_class(x)==synonym_t?"(synonym type) ": + ""); + filequote(s); + if(baded||rechecking)printf(" line %d",line); + if(aka)printf(" (as \"%s\")\n",aka); + else putchar('\n'); + } + if(atobject)printf("%s = ",get_id(x)), + out(stdout,id_val(x)),putchar('\n'); + return; } + diagnose(n); +} + +diagnose(n) +char *n; +{ word i=0; + if(isalpha(n[0])) + while(n[i]&&okid(n[i]))i++; + if(n[i]){ printf("\"%s\" -- not an identifier\n",n); return; } + for(i=0;presym[i];i++) + if(strcmp(n,presym[i])==0) + { printf("%s -- keyword (see manual, section %d)\n",n,presym_n[i]); + return; } + printf("identifier \"%s\" not in scope\n",n); +} + +static word sorted=0; /* flag to avoid repeatedly sorting fil_defs */ +static word leftist; /* flag to alternate bias of padding in justification */ +word words[colmax]; /* max plausible size of screen */ + +allnamescom() +{ word s; + word x=ND; + word y=x,z=0; + leftist=0; + namescom(make_fil(nostdenv?0:STDENV,0,0,primenv)); + if(files==NIL)return; else s=tl[files]; + while(s!=NIL)namescom(hd[s]),s=tl[s]; + namescom(hd[files]); + sorted=1; + /* now print warnings, if any */ + /*if(ND!=NIL&&id_type(hd[ND])==type_t) + { printf("ILLEGAL EXPORT LIST - MISSING TYPENAME%s: ",tl[ND]==NIL?"":"S"); + printlist("",ND); + return; } /* install if incomplete export list is escalated to error */ + while(x!=NIL&&id_type(hd[x])==undef_t)x=tl[x]; + while(y!=NIL&&id_type(hd[y])!=undef_t)y=tl[y]; + if(x!=NIL) + { printf("WARNING, SCRIPT CONTAINS TYPE ERRORS: "); + for(;x!=NIL;x=tl[x]) + if(id_type(hd[x])!=undef_t) + { if(!z)z=1; else putchar(','); + out(stdout,hd[x]); } + printf(";\n"); } + if(y!=NIL) + { printf("%s UNDEFINED NAMES: ",z?"AND":"WARNING, SCRIPT CONTAINS"); + z=0; + for(;y!=NIL;y=tl[y]) + if(id_type(hd[y])==undef_t) + { if(!z)z=1; else putchar(','); + out(stdout,hd[y]); } + printf(";\n"); } +} +/* There are two kinds of entry in ND + undefined names: val=UNDEF, type=undef_t + type errors: val=UNDEF, type=wrong_t +*/ + +#define tolerance 3 + /* max number of extra spaces we are willing to insert */ + +namescom(l) /* l is an element of `files' */ +word l; +{ word n=fil_defs(l),col=0,undefs=NIL,wp=0; + word scrwd = twidth(); + if(!sorted&&n!=primenv) /* primenv already sorted */ + fil_defs(l)=n=alfasort(n); /* also removes pnames */ + if(n==NIL)return; /* skip empty files */ + if(get_fil(l))filequote(get_fil(l)); + else printf("primitive:"); + printf("\n"); + while(n!=NIL) + { if(id_type(hd[n])==wrong_t||id_val(hd[n])!=UNDEF) + { word w=strlen(get_id(hd[n])); + if(col+w<scrwd)col += (col!=0); else + if(wp&&col+w>=scrwd) + { word i,r,j; + if(wp>1)i=(scrwd-col)/(wp-1),r=(scrwd-col)%(wp-1); + if(i+(r>0)>tolerance)i=r=0; + if(leftist) + for(col=0;col<wp;) + { printf("%s",get_id(words[col])); + if(++col<wp) + spaces(1+i+(r-- >0)); } + else + for(r=wp-1-r,col=0;col<wp;) + { printf("%s",get_id(words[col])); + if(++col<wp) + spaces(1+i+(r-- <=0)); } + leftist=!leftist,wp=0,col=0,putchar('\n'); } + col+=w; + words[wp++]=hd[n]; } + else undefs=cons(hd[n],undefs); /* undefined but have good types */ + n = tl[n]; } + if(wp) + for(col=0;col<wp;) + printf("%s",get_id(words[col])),putc(++col==wp?'\n':' ',stdout); + if(undefs==NIL)return; + undefs=reverse(undefs); + printlist("SPECIFIED BUT NOT DEFINED: ",undefs); +} + +word detrop=NIL; /* list of unused local definitions */ +word rfl=NIL; /* list of include components containing type orphans */ +word bereaved; /* typenames referred to in exports and not exported */ +word ld_stuff=NIL; + /* list of list of files, to be unloaded if mkincludes interrupted */ + +loadfile(t) +char *t; +{ extern word fileq; + extern word current_id,includees,embargoes,exportfiles,freeids,exports; + extern word fnts,FBS,disgusting,nextpn; + word h=NIL; /* location of %export directive, if present */ + loading=1; + errs=errline=0; + current_script=t; + oldfiles=NIL; + unload(); + if(stat(t,&buf)) + { if(initialising){ fprintf(stderr,"panic: %s not found\n",t); exit(1); } + if(verbosity)printf("new file %s\n",t); + if(magic)fprintf(stderr,"mira -exec %s%s\n",t,": no such file"),exit(1); + if(making&&ideep==0)printf("mira -make %s%s\n",t,": no such file"); + else oldfiles=cons(make_fil(t,0,0,NIL),NIL); + /* for correct record of sources */ + loading=0; + return; } + if(!openfile(t)) + { if(initialising){ fprintf(stderr,"panic: cannot open %s\n",t); exit(1); } + printf("cannot open %s\n",t); + oldfiles=cons(make_fil(t,0,0,NIL),NIL); + loading=0; + return; } + files = cons(make_fil(t,fm_time(t),1,NIL),NIL); + current_file = hd[files],tl[hd[fileq]] = current_file; + if(initialising&&strcmp(t,PRELUDE)==0)privlib(); else + if(initialising||nostdenv==1) + if(strcmp(t,STDENV)==0)stdlib(); + c = ' '; + col = 0; + s_in = (FILE *)hd[hd[fileq]]; + adjust_prefix(t); +/*if(magic&&!initialising) + { if(!(getc(s_in)=='#'&&getc(s_in)=='!')) + { files=NIL; return; } + while(getc(s_in)!='\n'); + commandmode=1; + c=MAGIC; } + else /* change to magic scripts 19.11.2013 */ + commandmode = 0; + if(verbosity||making)printf("compiling %s\n",t); + nextpn=0; /* lose pnames */ + embargoes=detrop= + fnts=rfl=bereaved=ld_stuff=exportfiles=freeids=exports=includees=FBS=NIL; + yyparse(); + if(!SYNERR&&exportfiles!=NIL) + { /* check pathnames in exportfiles have unique bindings */ + word s,i,count; + for(s=exportfiles;s!=NIL;s=tl[s]) + if(hd[s]==PLUS) /* add current script (less freeids) to exports */ + { for(i=fil_defs(hd[files]);i!=NIL;i=tl[i]) + if(isvariable(hd[i])&&!isfreeid(hd[i])) + tl[exports]=add1(hd[i],tl[exports]); + } else + /* pathnames are expanded to their contents in mkincludes */ + { for(count=0,i=includees;i!=NIL;i=tl[i]) + if(!strcmp((char *)hd[hd[hd[i]]],(char *)hd[s])) + hd[s]=hd[hd[hd[i]]]/*sharing*/,count++; + if(count!=1) + SYNERR=1, + printf("illegal fileid \"%s\" in export list (%s)\n", + (char *)hd[s], + count?"ambiguous":"not %included in script"); + } + if(SYNERR) + sayhere(hd[exports],1), + printf("compilation abandoned\n"); + } + if(!SYNERR&&includees!=NIL) + files=append1(files,mkincludes(includees)),includees=NIL; + ld_stuff=NIL; + if(!SYNERR&!disgusting) + { if(verbosity||making&&!mkexports&&!mksources) + printf("checking types in %s\n",t); + checktypes(); + /* printf("typecheck complete\n"); /* DEBUG */ } + if(!SYNERR&&exports!=NIL) + if(ND!=NIL)exports=NIL; else /* skip check, cannot be %included */ + { /* check exports all present and close under type info */ + word e,u=NIL,n=NIL,c=NIL; + h=hd[exports]; exports=tl[exports]; + for(e=embargoes;e!=NIL;e=tl[e]) + { if(id_type(hd[e])==undef_t)u=cons(hd[e],u),ND=add1(hd[e],ND); else + if(!member(exports,hd[e]))n=cons(hd[e],n); } + if(embargoes!=NIL) + exports=setdiff(exports,embargoes); + exports=alfasort(exports); + for(e=exports;e!=NIL;e=tl[e]) + if(id_type(hd[e])==undef_t)u=cons(hd[e],u),ND=add1(hd[e],ND); else + if(id_type(hd[e])==type_t&&t_class(hd[e])==algebraic_t) + c=shunt(t_info(hd[e]),c); /* constructors */ + if(exports==NIL)printf("warning, export list has void contents\n"); + else exports=append1(alfasort(c),exports); + if(n!=NIL) + { printf("redundant entr%s in export list:",tl[n]==NIL?"y":"ies"); + while(n!=NIL)printf(" -%s",get_id(hd[n])),n=tl[n]; n=1; /* flag */ + putchar('\n'); } + if(u!=NIL)exports=NIL, + printlist("undefined names in export list: ",u); + if(u!=NIL)sayhere(h,1),h=NIL; else + if(exports==NIL||n!=NIL)out_here(stderr,h,1),h=NIL; + /* for warnings call out_here not sayhere, so errinfo not saved in dump */ + } + if(!SYNERR&&ND==NIL&&(exports!=NIL||tl[files]!=NIL)) + { /* find out if script can create type orphans when %included */ + word e1,t; + word r=NIL; /* collect list of referenced typenames */ + word e=NIL; /* and list of exported typenames */ + if(exports!=NIL) + for(e1=exports;e1!=NIL;e1=tl[e1]) + { if((t=id_type(hd[e1]))==type_t) + if(t_class(hd[e1])==synonym_t) + r=UNION(r,deps(t_info(hd[e1]))); + else e=cons(hd[e1],e); + else r=UNION(r,deps(t)); } else + for(e1=fil_defs(hd[files]);e1!=NIL;e1=tl[e1]) + { if((t=id_type(hd[e1]))==type_t) + if(t_class(hd[e1])==synonym_t) + r=UNION(r,deps(t_info(hd[e1]))); + else e=cons(hd[e1],e); + else r=UNION(r,deps(t)); } + for(e1=freeids;e1!=NIL;e1=tl[e1]) + if((t=id_type(hd[hd[e1]]))==type_t) + if(t_class(hd[hd[e1]])==synonym_t) + r=UNION(r,deps(t_info(hd[hd[e1]]))); + else e=cons(hd[hd[e1]],e); + else r=UNION(r,deps(t)); + /*printlist("r: ",r); /* DEBUG */ + for(;r!=NIL;r=tl[r]) + if(!member(e,hd[r]))bereaved=cons(hd[r],bereaved); + /*printlist("bereaved: ",bereaved); /* DEBUG */ + } + if(exports!=NIL&&bereaved!=NIL) + { extern word newtyps; + word b=intersection(bereaved,newtyps); + /*printlist("newtyps",newtyps); /* DEBUG */ + if(b!=NIL) + /*ND=b; /* to escalate to type error, see also allnamescom */ + printf("warning, export list is incomplete - missing typename%s: ", + tl[b]==NIL?"":"s"), + printlist("",b); + if(b!=NIL&&h!=NIL)out_here(stdout,h,1); /* sayhere(h,1) for error */ + } + if(!SYNERR&&detrop!=NIL) + { word gd=detrop; + while(detrop!=NIL&&tag[dval(hd[detrop])]==LABEL)detrop=tl[detrop]; + if(detrop!=NIL) + printf("warning, script contains unused local definitions:-\n"); + while(detrop!=NIL) + { out_here(stdout,hd[hd[tl[dval(hd[detrop])]]],0), putchar('\t'); + out_pattern(stdout,dlhs(hd[detrop])), putchar('\n'); + detrop=tl[detrop]; + while(detrop!=NIL&&tag[dval(hd[detrop])]==LABEL) + detrop=tl[detrop]; } + while(gd!=NIL&&tag[dval(hd[gd])]!=LABEL)gd=tl[gd]; + if(gd!=NIL) + printf("warning, grammar contains unused nonterminals:-\n"); + while(gd!=NIL) + { out_here(stdout,hd[dval(hd[gd])],0), putchar('\t'); + out_pattern(stdout,dlhs(hd[gd])), putchar('\n'); + gd=tl[gd]; + while(gd!=NIL&&tag[dval(hd[gd])]!=LABEL)gd=tl[gd]; } + /* note, usual rhs is tries(pat,list(label(here,exp))) + grammar rhs is label(here,...) */ + } + if(!SYNERR) + { word x; extern word lfrule,polyshowerror; + /* we invoke the code generator */ + lfrule=0; + for(x=fil_defs(hd[files]);x!=NIL;x=tl[x]) + if(id_type(hd[x])!=type_t) + { current_id=hd[x]; + polyshowerror=0; + id_val(hd[x])=codegen(id_val(hd[x])); + if(polyshowerror)id_val(hd[x])=UNDEF; + /* nb - one remaining class of typerrs trapped in codegen, + namely polymorphic show or readvals */ + } + current_id=0; + if(lfrule&&(verbosity||making)) + printf("grammar optimisation: %d common left factors found\n",lfrule); + if(initialising&&ND!=NIL) + { fprintf(stderr,"panic: %s contains errors\n",okprel?"stdenv":"prelude"); + exit(1); } + if(initialising)makedump(); else + if(normal(t)) /* file ends ".m", formerly if(!magic) */ + fixexports(),makedump(),unfixexports(); + /* changed 26.11.2019 to allow dump of magic scripts ending ".m" */ + if(!errline&&errs&&(char *)hd[errs]==current_script) + errline=tl[errs]; /* soft error (posn not saved in dump) */ + ND=alfasort(ND); + /* we could sort and remove pnames from each defs component immediately + after makedump(), instead of doing this in namescom */ + loading=0; + return; } + /* otherwise syntax error found */ + if(initialising) + { fprintf(stderr,"panic: cannot compile %s\n",okprel?"stdenv":"prelude"); exit(1); } + oldfiles=files; + unload(); + if(normal(t)&&SYNERR!=2)makedump(); /* make syntax error dump */ + /* allow dump of magic script in ".m", was if(!magic&&) 26.11.2019 */ + SYNERR=0; + loading=0; +} + +isfreeid(x) +{ return(id_type(x)==type_t?t_class(x)==free_t:id_val(x)==FREE); } + +word internals=NIL; /* used by fix/unfixexports, list of names not exported */ +#define paint(x) id_val(x)=ap(EXPORT,id_val(x)) +#define unpainted(x) (tag[id_val(x)]!=AP||hd[id_val(x)]!=EXPORT) +#define unpaint(x) id_val(x)=tl[id_val(x)] + +fixexports() +{ extern exports,exportfiles,embargoes,freeids; + word e=exports,f; + /* printlist("exports: ",e); /* DEBUG */ + for(;e!=NIL;e=tl[e])paint(hd[e]); + internals=NIL; + if(exports==NIL&&exportfiles==NIL&&embargoes==NIL) /*no %export in script*/ + { for(e=freeids;e!=NIL;e=tl[e]) + internals=cons(privatise(hd[hd[e]]),internals); + for(f=tl[files];f!=NIL;f=tl[f]) + for(e=fil_defs(hd[f]);e!=NIL;e=tl[e]) + { if(tag[hd[e]]==ID) + internals=cons(privatise(hd[e]),internals); }} + else for(f=files;f!=NIL;f=tl[f]) + for(e=fil_defs(hd[f]);e!=NIL;e=tl[e]) + { if(tag[hd[e]]==ID&&unpainted(hd[e])) + internals=cons(privatise(hd[e]),internals); } + /* optimisation, need not do this to `silent' components - fix later */ + /*printlist("internals: ",internals); /* DEBUG */ + for(e=exports;e!=NIL;e=tl[e])unpaint(hd[e]); +} /* may not be interrupt safe, re unload() */ + +unfixexports() +{ /*printlist("internals: ",internals); /* DEBUG */ + word i=internals; + if(mkexports)return; /* in this case don't want internals restored */ + while(i!=NIL) /* lose */ + publicise(hd[i]),i=tl[i]; + internals=NIL; +} /* may not be interrupt safe, re unload() */ + +privatise(x) /* change id to pname, and return new id holding it as value */ +word x; +{ extern word namebucket[],*pnvec; + word n = make_pn(x),h=namebucket[hash(get_id(x))],i; + if(id_type(x)==type_t) + t_info(x)=cons(datapair(getaka(x),0),get_here(x)); + /* to assist identification of danging type refs - see typesharing code + in mkincludes */ + /* assumption - nothing looks at the t_info after compilation */ + if(id_val(x)==UNDEF) /* name specified but not defined */ + id_val(x)= ap(datapair(getaka(x),0),get_here(x)); + /* this will generate sensible error message on attempt to use value + see reduction rule for DATAPAIR */ + pnvec[i=hd[n]]=x; + tag[n]=ID;hd[n]=hd[x]; + tag[x]=STRCONS;hd[x]=i; + while(hd[h]!=x)h=tl[h]; + hd[h]=n; + return(n); +} /* WARNING - dependent on internal representation of ids and pnames */ +/* nasty problem - privatisation can screw AKA's */ + +publicise(x) /* converse of the above, applied to the new id */ +word x; +{ extern word namebucket[]; + word i=id_val(x),h=namebucket[hash(get_id(x))]; + tag[i]=ID,hd[i]=hd[x]; + /* WARNING - USES FACT THAT tl HOLDS VALUE FOR BOTH ID AND PNAME */ + if(tag[tl[i]]==AP&&tag[hd[tl[i]]]==DATAPAIR) + tl[i]=UNDEF; /* undo kludge, see above */ + while(hd[h]!=x)h=tl[h]; + hd[h]=i; + return(i); +} + +static sigflag=0; + +sigdefer() +{ /* printf("sigdefer()\n"); /* DEBUG */ + sigflag=1; } /* delayed signal handler, installed during load_script() */ + +mkincludes(includees) +word includees; +{ extern word FBS,BAD_DUMP,CLASHES,exportfiles,exports,TORPHANS; + word pid,result=NIL,tclashes=NIL; + includees=reverse(includees); /* process in order of occurrence in script */ + if(pid=fork()) + { /* parent */ + word status; + if(pid==-1) + { perror("UNIX error - cannot create process"); /* will say why */ + if(ideep>6) /* perhaps cyclic %include */ + fprintf(stderr,"error occurs %d deep in %%include files\n",ideep); + if(ideep)exit(2); + SYNERR=2; /* special code to prevent makedump() */ + printf("compilation of \"%s\" abandoned\n",current_script); + return(NIL); } + while(pid!=wait(&status)); + if((WEXITSTATUS(status))==2) /* child aborted */ + if(ideep)exit(2); /* recursive abortion of parent process */ + else { SYNERR=2; + printf("compilation of \"%s\" abandoned\n",current_script); + return(NIL); } + /* if we get to here child completed normally, so carry on */ + } + else { /* child does equivalent of `mira -make' on each includee */ + extern word oldfiles; + (void)signal(SIGINT,SIG_DFL); /* don't trap interrupts */ + ideep++; making=1; make_status=0; echoing=listing=verbosity=magic=0; + setjmp(env); /* will return here on blankerr (via reset) */ + while(includees!=NIL&&!make_status) /* stop at first bad includee */ + { undump((char *)hd[hd[hd[includees]]]); + if(ND!=NIL||files==NIL&&oldfiles!=NIL)make_status=1; + /* any errors in dump? */ + includees=tl[includees]; + } /* obscure bug - undump above can reinvoke compiler, which + side effects compiler variable `includees' - to fix this + had to make sure child is holding local copy of includees*/ + exit(make_status); } + sigflag=0; + for(;includees!=NIL;includees=tl[includees]) + { word x=NIL; + sighandler oldsig; + FILE *f; + char *fn=(char *)hd[hd[hd[includees]]]; + extern word DETROP,MISSING,ALIASES,TSUPPRESSED,*stackp,*dstack; + (void)strcpy(dicp,fn); + (void)strcpy(dicp+strlen(dicp)-1,obsuffix); + if(!making) /* cannot interrupt load_script() */ + oldsig=signal(SIGINT,(sighandler)sigdefer); + if(f=fopen(dicp,"r")) + x=load_script(f,fn,hd[tl[hd[includees]]],tl[tl[hd[includees]]],0), + fclose(f); + ld_stuff=cons(x,ld_stuff); + if(!making)(void)signal(SIGINT,oldsig); + if(sigflag)sigflag=0,(* oldsig)(); /* take deferred interrupt */ + if(f&&!BAD_DUMP&&x!=NIL&&ND==NIL&&CLASHES==NIL&&ALIASES==NIL&& + TSUPPRESSED==NIL&&DETROP==NIL&&MISSING==NIL) + /* i.e. if load_script worked ok */ + { /* stuff here is to share repeated file components + issues: + Consider only includees (fil_share=1), not insertees. + Effect of sharing is to replace value fields in later copies + by (pointers to) corresponding ids in first copy - so sharing + transmitted thru dumps. It is illegal to have more than one + copy of a (non-synonym) type in the same scope, even under + different names. */ + word y,z; + /* printf("start share analysis\n"); /* DEBUG */ + if(TORPHANS)rfl=shunt(x,rfl); /* file has type orphans */ + for(y=x;y!=NIL;y=tl[y])fil_inodev(hd[y])=inodev(get_fil(hd[y])); + for(y=x;y!=NIL;y=tl[y]) + if(fil_share(hd[y])) + for(z=result;z!=NIL;z=tl[z]) + if(fil_share(hd[z])&&same_file(hd[y],hd[z]) + &&fil_time(hd[y])==fil_time(hd[z])) + { word p=fil_defs(hd[y]),q=fil_defs(hd[z]); + for(;p!=NIL&&q!=NIL;p=tl[p],q=tl[q]) + if(tag[hd[p]]==ID) + if(id_type(hd[p])==type_t&& + (tag[hd[q]]==ID||tag[pn_val(hd[q])]==ID)) + { /* typeclash - record in tclashes */ + word w=tclashes; + word orig=tag[hd[q]]==ID?hd[q]:pn_val(hd[q]); + if(t_class(hd[p])==synonym_t)continue; + while(w!=NIL&&((char *)hd[hd[w]]!=get_fil(hd[z]) + ||hd[tl[hd[w]]]!=orig)) + w=tl[w]; + if(w==NIL) + w=tclashes=cons(strcons(get_fil(hd[z]), + cons(orig,NIL)),tclashes); + tl[tl[hd[w]]]=cons(hd[p],tl[tl[hd[w]]]); + } + else the_val(hd[q])=hd[p]; + else the_val(hd[p])=hd[q]; + /*following test redundant - remove when sure is ok*/ + if(p!=NIL||q!=NIL) + fprintf(stderr,"impossible event in mkincludes\n"); + /*break; /* z loop -- NO! (see liftbug) */ + } + if(member(exportfiles,(word)fn)) + { /* move ids of x onto exports */ + for(y=x;y!=NIL;y=tl[y]) + for(z=fil_defs(hd[y]);z!=NIL;z=tl[z]) + if(isvariable(hd[z])) + tl[exports]=add1(hd[z],tl[exports]); + /* skip pnames, constructors (expanded later) */ + } + result=append1(result,x); + /* keep `result' in front-first order */ + if(hd[FBS]==NIL)FBS=tl[FBS]; + else hd[FBS]=cons(tl[hd[hd[includees]]],hd[FBS]); /* hereinfo */ + /* printf("share analysis finished\n"); /* DEBUG */ + continue; } + /* something wrong - find out what */ + if(!f)result=cons(make_fil(hd[hd[hd[includees]]], + fm_time(fn),0,NIL),result); else + if(x==NIL&&BAD_DUMP!= -2)result=append1(result,oldfiles),oldfiles=NIL; + else result=append1(result,x); + /* above for benefit of `oldfiles' */ + /* BAD_DUMP -2 is nameclashes due to aliasing */ + SYNERR=1; + printf("unsuccessful %%include directive "); + sayhere(tl[hd[hd[includees]]],1); +/* if(!f)printf("\"%s\" non-existent or unreadable\n",fn), */ + if(!f)printf("\"%s\" cannot be loaded\n",fn), + CLASHES=DETROP=MISSING=NIL; + /* just in case not cleared from a previous load_script() */ + else + if(BAD_DUMP== -2) + printlist("aliasing causes nameclashes: ",CLASHES), + CLASHES=NIL; else + if(ALIASES!=NIL||TSUPPRESSED!=NIL) + { if(ALIASES!=NIL) + printf("alias fails (name%s not found in file", + tl[ALIASES]==NIL?"":"s"), + printlist("): ",ALIASES),ALIASES=NIL; + if(TSUPPRESSED!=NIL) + { printf("illegal alias (cannot suppress typename%s):", + tl[TSUPPRESSED]==NIL?"":"s"); + while(TSUPPRESSED!=NIL) + printf(" -%s",get_id(hd[TSUPPRESSED])), + TSUPPRESSED=tl[TSUPPRESSED]; + putchar('\n'); } + /* if -typename allowed, remember to look for type orphans */ + }else + if(BAD_DUMP)printf("\"%s\" has bad data in dump file\n",fn); else + if(x==NIL)printf("\"%s\" contains syntax error\n",fn); else + if(ND!=NIL) + printf("\"%s\" contains undefined names or type errors\n",fn); + if(ND==NIL&&CLASHES!=NIL) /* can have this and failed aliasing */ + printf("\"%s\" ",fn),printlist("causes nameclashes: ",CLASHES); + while(DETROP!=NIL&&tag[hd[DETROP]]==CONS) + { word fa=hd[tl[hd[DETROP]]],ta=tl[tl[hd[DETROP]]]; + char *pn=get_id(hd[hd[DETROP]]); + if(fa== -1||ta== -1) + printf("`%s' has binding of wrong kind ",pn), + printf(fa== -1?"(should be \"= value\" not \"== type\")\n" + :"(should be \"== type\" not \"= value\")\n"); + else + printf("`%s' has == binding of wrong arity ",pn), + printf("(formal has arity %d, actual has arity %d)\n",fa,ta); + DETROP=tl[DETROP]; } + if(DETROP!=NIL) + printf("illegal parameter binding (name%s not %%free in file", + tl[DETROP]==NIL?"":"s"), + printlist("): ",DETROP),DETROP=NIL; + if(MISSING!=NIL) + printf("missing parameter binding%s: ",tl[MISSING]==NIL?"":"s"); + while(MISSING!=NIL) + printf("%s%s",(char *)hd[hd[MISSING]],tl[MISSING]==NIL?";\n":","), + MISSING=tl[MISSING]; + printf("compilation abandoned\n"); + stackp=dstack; /* in case of BAD_DUMP */ + return(result); } /* for unload() */ + if(tclashes!=NIL) + { printf("TYPECLASH - the following type%s multiply named:\n", + tl[tclashes]==NIL?" is":"s are"); + /* structure of tclashes is list of strcons(filname,list-of-ids) */ + for(;tclashes!=NIL;tclashes=tl[tclashes]) + { printf("\'%s\' of file \"%s\", as: ", + getaka(hd[tl[hd[tclashes]]]), + (char *)hd[hd[tclashes]]); + printlist("",alfasort(tl[hd[tclashes]])); } + printf("typecheck cannot proceed - compilation abandoned\n"); + SYNERR=1; + return(result); } /* for unload */ + return(result); +} + +word tlost=NIL; +word pfrts=NIL; /* list of private free types bound in this script */ + +readoption() /* readopt type orphans */ +{ word f,t; + extern word TYPERRS,FBS; + pfrts=tlost=NIL; + /* exclude anonymous free types, these dealt with later by mcheckfbs() */ + if(FBS!=NIL) + for(f=FBS;f!=NIL;f=tl[f]) + for(t=tl[hd[f]];t!=NIL;t=tl[t]) + if(tag[hd[hd[t]]]==STRCONS&&tl[tl[hd[t]]]==type_t) + pfrts=cons(hd[hd[t]],pfrts); + /* this may needlessly scan `silent' files - fix later */ + for(;rfl!=NIL;rfl=tl[rfl]) + for(f=fil_defs(hd[rfl]);f!=NIL;f=tl[f]) + if(tag[hd[f]]==ID) + if((t=id_type(hd[f]))==type_t) + { if(t_class(hd[f])==synonym_t) + t_info(hd[f])=fixtype(t_info(hd[f]),hd[f]); } + else id_type(hd[f])=fixtype(t,hd[f]); + if(tlost==NIL)return; + TYPERRS++; + printf("MISSING TYPENAME%s\n",tl[tlost]==NIL?"":"S"); + printf("the following type%s no name in this scope:\n", + tl[tlost]==NIL?" is needed but has":"s are needed but have"); + /* structure of tlost is list of cons(losttype,list-of-ids) */ + for(;tlost!=NIL;tlost=tl[tlost]) + { /* printf("tinfo_tlost=");out(stdout,t_info(hd[hd[tlost]])); + putchar(';'); /*DEBUG */ + printf("\'%s\' of file \"%s\", needed by: ", + (char *)hd[hd[t_info(hd[hd[tlost]])]], + (char *)hd[tl[t_info(hd[hd[tlost]])]]); + printlist("",alfasort(tl[hd[tlost]])); } +} + +/*fixtype(t,x) +int t,x; +{ int t1; + t1=fixtype1(t,x); + printf("fixing type of %s\n",get_id(x)); + out_type(t); printf(" := "); + out_type(t1); putchar('\n'); + return(t1); +} /* DEBUG */ + +fixtype(t,x) /* substitute out any indirected typenames in t */ +word t,x; +{ switch(tag[t]) + { case AP: + case CONS: tl[t]=fixtype(tl[t],x); + hd[t]=fixtype(hd[t],x); + default: return(t); + case STRCONS: if(member(pfrts,t))return(t); /* see jrcfree.bug */ + while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/ + if(tag[t]!=ID) + { /* lost type - record in tlost */ + word w=tlost; + while(w!=NIL&&hd[hd[w]]!=t)w=tl[w]; + if(w==NIL) + w=tlost=cons(cons(t,cons(x,NIL)),tlost); + tl[hd[w]]=add1(x,tl[hd[w]]); + } + return(t); + } +} + +#define mask(c) (c&0xDF) +/* masks out lower case bit, which is 0x20 */ +alfa_ls(a,b) /* 'DICTIONARY ORDER' - not currently used */ +char *a,*b; +{ while(*a&&mask(*a)==mask(*b))a++,b++; + if(mask(*a)==mask(*b))return(strcmp(a,b)<0); /* lower case before upper */ + return(mask(*a)<mask(*b)); +} + +alfasort(x) /* also removes non_IDs from result */ +word x; +{ word a=NIL,b=NIL,hold=NIL; + if(x==NIL)return(NIL); + if(tl[x]==NIL)return(tag[hd[x]]!=ID?NIL:x); + while(x!=NIL) /* split x */ + { if(tag[hd[x]]==ID)hold=a,a=cons(hd[x],b),b=hold; + x=tl[x]; } + a=alfasort(a),b=alfasort(b); + /* now merge two halves back together */ + while(a!=NIL&&b!=NIL) + if(strcmp(get_id(hd[a]),get_id(hd[b]))<0)x=cons(hd[a],x),a=tl[a]; + else x=cons(hd[b],x),b=tl[b]; + if(a==NIL)a=b; + while(a!=NIL)x=cons(hd[a],x),a=tl[a]; + return(reverse(x)); +} + +unsetids(d) /* d is a list of identifiers */ +word d; +{ while(d!=NIL) + { if(tag[hd[d]]==ID)id_val(hd[d])=UNDEF, + id_who(hd[d])=NIL, + id_type(hd[d])=undef_t; + d=tl[d]; } /* should we remove from namebucket ? */ +} + +unload() /* clear out current script in preparation for reloading */ +{ extern word TABSTRS,SGC,speclocs,newtyps,rv_script,algshfns,nextpn,nolib, + includees,freeids; + word x; + sorted=0; + speclocs=NIL; + nextpn=0; /* lose pnames */ + rv_script=0; + algshfns=NIL; + unsetids(newtyps); + newtyps=NIL; + unsetids(freeids); + freeids=includees=SGC=freeids=TABSTRS=ND=NIL; + unsetids(internals); + internals=NIL; + while(files!=NIL) + { unsetids(fil_defs(hd[files])); + fil_defs(hd[files])=NIL; + files = tl[files]; } + for(;ld_stuff!=NIL;ld_stuff=tl[ld_stuff]) + for(x=hd[ld_stuff];x!=NIL;x=tl[x])unsetids(fil_defs(hd[x])); +} + +yyerror(s) /* called by YACC in the event of a syntax error */ +char *s; +{ extern word yychar; + if(SYNERR)return; /* error already reported, so shut up */ + if(echoing)printf("\n"); + printf("%s - unexpected ",s); + if(yychar==OFFSIDE&&(c==EOF||c=='|')) + { if(c==EOF) /* special case introduced by fix for dtbug */ + printf("end of file"); else + printf("token '|'"); + /* special case introduced by sreds fix to offside rule */ + } else + { printf(yychar==0?commandmode?"newline":"end of file":"token "); + if(yychar>=256)putchar('\"'); + if(yychar!=0)out2(stdout,yychar); + if(yychar>=256)putchar('\"'); } + printf("\n"); + SYNERR=1; + reset_lex(); +} + +syntax(s) /* called by actions after discovering a (context sensitive) syntax + error */ +char *s; +{ if(SYNERR)return; + if(echoing)printf("\n"); + printf("syntax error: %s",s); + SYNERR=1; /* this will stop YACC at its next call to yylex() */ + reset_lex(); +} + +acterror() /* likewise, but assumes error message output by caller */ +{ if(SYNERR)return; + SYNERR=1; /* to stop YACC at next symbol */ + reset_lex(); +} + +mira_setup() +{ extern word common_stdin,common_stdinb,cook_stdin; + setupheap(); + tsetup(); + reset_pns(); + bigsetup(); + common_stdin= ap(READ,0); + common_stdinb= ap(READBIN,0); + cook_stdin=ap(readvals(0,0),OFFSIDE); + nill= cons(CONST,NIL); + Void=make_id("()"); + id_type(Void)=void_t; + id_val(Void)=constructor(0,Void); + message=make_id("sys_message"); + main_id=make_id("main"); /* change to magic scripts 19.11.2013 */ + concat=make_id("concat"); + diagonalise=make_id("diagonalise"); + standardout=constructor(0,"Stdout"); + indent_fn=make_id("indent"); + outdent_fn=make_id("outdent"); + listdiff_fn=make_id("listdiff"); + shownum1=make_id("shownum1"); + showbool=make_id("showbool"); + showchar=make_id("showchar"); + showlist=make_id("showlist"); + showstring=make_id("showstring"); + showparen=make_id("showparen"); + showpair=make_id("showpair"); + showvoid=make_id("showvoid"); + showfunction=make_id("showfunction"); + showabstract=make_id("showabstract"); + showwhat=make_id("showwhat"); + primlib(); } /* sets up predefined ids, not referred to by RULES */ + +void dieclean() /* called if evaluation is interrupted - see RULES */ +{ printf("<<...interrupt>>\n"); +#ifndef NOSTATSONINT + outstats(); /* suppress in presence of segfault on ^C with /count */ +#endif + exit(0); +} + +/* the function process() creates a process and waits for it to die - + returning 1 in the child and 0 in the parent - it is used in the + evaluation command (see MIRANDA RULES) */ +process() +{ word pid; + sighandler oldsig; + oldsig = signal(SIGINT,SIG_IGN); + /* do not let parent receive interrupts intended for child */ + if(pid=fork()) + { /* parent */ + word status; /* see man 2 exit, wait, signal */ + if(pid== -1) + { perror("UNIX error - cannot create process"); + return(0); + } + while(pid!=wait(&status)); + /* low byte of status is termination state of child, next byte is the + (low order byte of the) exit status */ + if(WIFSIGNALED(status)) /* abnormal termination status */ + { char *cd=status&0200?" (core dumped)":""; + char *pc=""; /* "probably caused by stack overflow\n";*/ + switch(WTERMSIG(status)) + { case SIGBUS: printf("\n<<...bus error%s>>\n%s",cd,pc); break; + case SIGSEGV: printf("\n<<...segmentation fault%s>>\n%s",cd,pc); break; + default: printf("\n<<...uncaught signal %d>>\n",WTERMSIG(status)); + } } + /*if(status >>= 8)printf("\n(exit status %d)\n",status); */ + (void)signal(SIGINT,oldsig); /* restore interrupt status */ + return(0); } + else return(1); /* child */ +} + +/* Notice that the MIRANDA system has a two-level interrupt structure. + 1) Each evaluation (see RULES) is an interruptible process. + 2) If the command loop is interrupted outside an evaluation or during + compilation it reverts to the top level prompt - see set_jmp and + signal(reset) in commandloop() */ + +primdef(n,v,t) /* used by "primlib", see below */ +char *n; +word v,t; +{ word x; + x= make_id(n); + primenv=cons(x,primenv); + id_val(x)= v; + id_type(x)=t; } + +predef(n,v,t) /* used by "privlib" and "stdlib", see below */ +char *n; +word v,t; +{ word x; + x= make_id(n); + addtoenv(x); + id_val(x)= isconstructor(x)?constructor(v,x):v; + id_type(x)=t; +} + +primlib() /* called by "mira_setup", this routine enters + the primitive identifiers into the primitive environment */ +{ primdef("num",make_typ(0,0,synonym_t,num_t),type_t); + primdef("char",make_typ(0,0,synonym_t,char_t),type_t); + primdef("bool",make_typ(0,0,synonym_t,bool_t),type_t); + primdef("True",1,bool_t); /* accessible only to 'finger' */ + primdef("False",0,bool_t); /* likewise - FIX LATER */ +} + +privlib() /* called when compiling <prelude>, adds some + internally defined identifiers to the environment */ +{ extern word ltchar; + predef("offside",OFFSIDE,ltchar); /* used by `indent' in prelude */ + predef("changetype",I,wrong_t); /* wrong_t to prevent being typechecked */ + predef("first",HD,wrong_t); + predef("rest",TL,wrong_t); +/* the following added to make prelude compilable without stdenv */ + predef("code",CODE,undef_t); + predef("concat",ap2(FOLDR,APPEND,NIL),undef_t); + predef("decode",DECODE,undef_t); + predef("drop",DROP,undef_t); + predef("error",ERROR,undef_t); + predef("filter",FILTER,undef_t); + predef("foldr",FOLDR,undef_t); + predef("hd",HD,undef_t); + predef("map",MAP,undef_t); + predef("shownum",SHOWNUM,undef_t); + predef("take",TAKE,undef_t); + predef("tl",TL,undef_t); +} + +stdlib() /* called when compiling <stdenv>, adds some + internally defined identifiers to the environment */ +{ predef("arctan",ARCTAN_FN,undef_t); + predef("code",CODE,undef_t); + predef("cos",COS_FN,undef_t); + predef("decode",DECODE,undef_t); + predef("drop",DROP,undef_t); + predef("entier",ENTIER_FN,undef_t); + predef("error",ERROR,undef_t); + predef("exp",EXP_FN,undef_t); + predef("filemode",FILEMODE,undef_t); + predef("filestat",FILESTAT,undef_t); /* added Feb 91 */ + predef("foldl",FOLDL,undef_t); + predef("foldl1",FOLDL1,undef_t); /* new at release 2 */ + predef("hugenum",sto_dbl(DBL_MAX),undef_t); + /* max_normal() if present returns same value (see <math.h>) */ + predef("last",LIST_LAST,undef_t); + predef("foldr",FOLDR,undef_t); + predef("force",FORCE,undef_t); + predef("getenv",GETENV,undef_t); + predef("integer",INTEGER,undef_t); + predef("log",LOG_FN,undef_t); + predef("log10",LOG10_FN,undef_t); /* new at release 2 */ + predef("merge",MERGE,undef_t); /* new at release 2 */ + predef("numval",NUMVAL,undef_t); + predef("read",STARTREAD,undef_t); + predef("readb",STARTREADBIN,undef_t); + predef("seq",SEQ,undef_t); + predef("shownum",SHOWNUM,undef_t); + predef("showhex",SHOWHEX,undef_t); + predef("showoct",SHOWOCT,undef_t); + predef("showfloat",SHOWFLOAT,undef_t); /* new at release 2 */ + predef("showscaled",SHOWSCALED,undef_t); /* new at release 2 */ + predef("sin",SIN_FN,undef_t); + predef("sqrt",SQRT_FN,undef_t); + predef("system",EXEC,undef_t); /* new at release 2 */ + predef("take",TAKE,undef_t); + predef("tinynum",mktiny(),undef_t); /* new at release 2 */ + predef("zip2",ZIP,undef_t); /* new at release 2 */ +} + +mktiny() +{ volatile + double x=1.0,x1=x/2.0; + while(x1>0.0)x=x1,x1/=2.0; + return(sto_dbl(x)); +} +/* min_subnormal() if present returns same value (see <math.h>) */ + +size(x) /* measures the size of a compiled expression */ +word x; +{ word s; + s= 0; + while(tag[x]==CONS||tag[x]==AP) + { s= s+1+size(hd[x]); + x= tl[x]; } + return(s); } + +makedump() +{ char *obf=linebuf; + FILE *f; + (void)strcpy(obf,current_script); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + f=fopen(obf,"w"); + if(!f){ printf("WARNING: CANNOT WRITE TO %s\n",obf); + if(strcmp(current_script,PRELUDE)==0|| + strcmp(current_script,STDENV)==0) + printf( + "TO FIX THIS PROBLEM PLEASE GET SUPER-USER TO EXECUTE `mira'\n"); + if(making&&!make_status)make_status=1; + return; } + /* printf("dumping to %s\n",obf); /* DEBUG */ + unlinkme=obf; + /* fchmod(fileno(f),0666); /* to make dumps writeable by all */ /* no! */ + setprefix(current_script); + dump_script(files,f); + unlinkme=NULL; + fclose(f); +} + +undump(t) /* restore t from dump, or recompile if necessary */ +char *t; +{ extern word BAD_DUMP,CLASHES; + if(!normal(t)&&!initialising)return loadfile(t); + /* except for prelude, only .m files have dumps */ + char obf[pnlim]; + FILE *f; + sighandler oldsig; + word flen=strlen(t); + time_t t1=fm_time(t),t2; + if(flen>pnlim) + { printf("sorry, pathname too long (limit=%d): %s\n",pnlim,t); + return; } /* if anyone complains, should remove this limit */ + (void)strcpy(obf,t); + (void)strcpy(obf+flen-1,obsuffix); + t2=fm_time(obf); + if(t2&&!t1)t2=0,unlink(obf); /* dump is orphan - remove */ + if(!t2||t2<t1) /* dump is nonexistent or older than source - ignore */ + { loadfile(t); return; } + f=fopen(obf,"r"); + if(!f){ printf("cannot open %s\n",obf); loadfile(t); return; } + current_script=t; + loading=1; + oldfiles=NIL; + unload(); +/*if(!initialising)printf("undumping from %s\n",obf); /* DEBUG */ + if(!initialising&&!making) /* ie this is the main script */ + sigflag=0, + oldsig=signal(SIGINT,(sighandler)sigdefer); + /* can't take interrupt during load_script */ + files=load_script(f,t,NIL,NIL,!making&!initialising); + fclose(f); + if(BAD_DUMP) + { extern word *stackp,*dstack; + unlink(obf); unload(); CLASHES=NIL; stackp=dstack; + printf("warning: %s contains incorrect data (file removed)\n",obf); + if(BAD_DUMP== -1)printf("(obsolete dump format)\n"); else + if(BAD_DUMP==1)printf("(wrong source file)\n"); else + printf("(error %d)\n",BAD_DUMP); } + if(!initialising&&!making) /* restore interrupt handler */ + (void)signal(SIGINT,oldsig); + if(sigflag)sigflag=0,(*oldsig)(); /* take deferred interrupt */ + /*if(!initialising)printf("%s undumped\n",obf); /* DEBUG */ + if(CLASHES!=NIL) + { if(ideep==0)printf("cannot load %s ",obf), + printlist("due to name clashes: ",alfasort(CLASHES)); + unload(); + loading=0; + return; } + if(BAD_DUMP||src_update())loadfile(t);/* any sources modified since dump? */ + else + if(initialising) + { if(ND!=NIL||files==NIL) /* error in dump of PRELUDE */ + fprintf(stderr,"panic: %s contains errors\n",obf), + exit(1); } /* beware of dangling else ! (whence {}) */ + else + if(verbosity||magic||mkexports) /* for less silent making s/mkexports/making/ */ + if(files==NIL)printf("%s contains syntax error\n",t); else + if(ND!=NIL)printf("%s contains undefined names or type errors\n",t); else + if(!making&&!magic)printf("%s\n",t); /* added &&!magic 26.11.2019 */ + if(!files==NIL&&!making&!initialising)unfixexports(); + loading=0; +} + +unlinkx(t) /* remove orphaned .x file */ +char *t; +{ char *obf=linebuf; + (void)strcpy(obf,t); + (void)strcpy(obf+strlen(t)-1,obsuffix); + if(!stat(obf,&buf))unlink(obf); +} + +void fpe_error() +{ if(compiling) + { (void)signal(SIGFPE,(sighandler)fpe_error); /* reset SIGFPE trap */ +#ifdef sparc8 + fpsetmask(commonmask); /* to clear sticky bits */ +#endif + syntax("floating point number out of range\n"); + SYNERR=0; longjmp(env,1); + /* go straight back to commandloop - necessary because decoding very + large numbers can cause huge no. of repeated SIGFPE exceptions */ + } + else printf("\nFLOATING POINT OVERFLOW\n"),exit(1); +} + +char fbuf[512]; + +filecopy(fil) /* copy the file "fil" to standard out */ +char *fil; +{ word in=open(fil,0),n; + if(in== -1)return; + while((n=read(in,fbuf,512))>0)write(1,fbuf,n); + close(in); +} + +filecp(fil1,fil2) /* copy file "fil1" to "fil2" (like `cp') */ +char *fil1,*fil2; +{ word in=open(fil1,0),n; + word out=creat(fil2,0644); + if(in== -1||out== -1)return; + while((n=read(in,fbuf,512))>0)write(out,fbuf,n); + close(in); + close(out); +} + +/* to define winsize and TIOCGWINSZ for twidth() */ +#include <termios.h> +#include <sys/ioctl.h> + +twidth() /* returns width (in columns) of current window, less 2 */ +{ +#ifdef TIOCGWINSZ + static struct winsize tsize; + ioctl(fileno(stdout),TIOCGWINSZ,&tsize); + return (tsize.ws_col==0)?78:tsize.ws_col-2; +#else +#error TIOCGWINSZ undefined +/* porting note: if you cannot find how to enable use of TIOCGWINSZ + comment out the above #error line */ + return 78; /* give up, we will assume screen width to be 80 */ +#endif +} + +/* was called when Miranda starts up and before /help, /aux + to clear screen - suppressed Oct 2019 */ +/* clrscr() +{ printf("\x1b[2J\x1b[H"); fflush(stdout); +} */ + +/* the following code tests if we are in a UTF-8 locale */ + +#ifdef CYGWIN +#include <windows.h> + +utf8test() +{ return GetACP()==65001; } +/* codepage 1252 is Windows version of Latin-1; 65001 is UTF-8 */ + +#else + +utf8test() +{ char *lang; + if(!(lang=getenv("LC_CTYPE"))) + lang=getenv("LANG"); + if(lang&& + (strstr(lang,"UTF-8")||strstr(lang,"UTF8")|| + strstr(lang,"utf-8")||strstr(lang,"utf8"))) + return 1; + return 0; +} +#endif + +/* end of MIRANDA STEER */ + diff --git a/new/trans.c b/new/trans.c new file mode 100644 index 0000000..e50eb8a --- /dev/null +++ b/new/trans.c @@ -0,0 +1,1026 @@ +/* MIRANDA TRANS */ +/* performs translation to combinatory logic */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" + + /* miscellaneous declarations */ +extern word nill,Void; +extern word listdiff_fn,count_fn,from_fn; +extern word diagonalise,concat; +extern word lastname,initialising; +extern word current_id,echoing; +extern word errs; +word newtyps=NIL; /* list of typenames declared in current script */ +word SGC=NIL; /* list of user defined sui-generis constructors */ +#define sui_generis(k) (/* k==Void|| */ member(SGC,k)) + /* 3/10/88 decision to treat `()' as lifted */ + +abstract(x,e) /* abstraction of template x from compiled expression e */ +word x,e; +{ switch(tag[x]) + { case ID: + if(isconstructor(x)) + return(sui_generis(x)?ap(K,e): + ap2(Ug,primconstr(x),e)); + else return(abstr(x,e)); + case CONS: + if(hd[x]==CONST) + if(tag[tl[x]]==INT)return(ap2(MATCHINT,tl[x],e)); + else return(ap2(MATCH,tl[x]==NILS?NIL:tl[x],e)); + else return(ap(U_,abstract(hd[x],abstract(tl[x],e)))); + case TCONS: + case PAIR: /* tuples */ + return(ap(U,abstract(hd[x],abstract(tl[x],e)))); + case AP: + if(sui_generis(head(x))) + return(ap(Uf,abstract(hd[x],abstract(tl[x],e)))); + if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + return(ap2(ATLEAST,tl[hd[x]],abstract(tl[x],e))); + while(tag[x]==AP) + { e= abstract(tl[x],e); + x= hd[x]; } + /* now x must be a constructor */ + default: ; } + if(isconstructor(x)) + return(ap2(Ug,primconstr(x),e)); + printf("error in declaration of \"%s\", undeclared constructor in pattern: ", + get_id(current_id)); /* something funny here - fix later */ + out(stdout,x); + printf("\n"); + return(NIL); +} + +primconstr(x) +word x; +{ x=id_val(x); + while(tag[x]!=CONSTRUCTOR)x=tl[x]; + return(x); + /* => constructor values are of the form TRY f k where k is the + original constructor value, and ! constructors are of the form + MKSTRICT i k */ +} + +memb(l,x) /* tests if x is a member of list "l" - used in testing for + repeated names - see rule for "v2" in MIRANDA RULES */ +word l,x; +{ if(tag[x]==TVAR) /* type variable! */ + while(l!=NIL&&!eqtvar(hd[l],x))l= tl[l]; + else while(l!=NIL&&hd[l]!=x)l= tl[l]; + return(l!=NIL); } + +abstr(x,e) /* "bracket abstraction" of variable x from code e */ +word x,e; +{ switch(tag[e]) + { case TCONS: + case PAIR: + case CONS: return(liscomb(abstr(x,hd[e]),abstr(x,tl[e]))); + case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR) + return(ap(K,e)); /* don't go inside error info */ + return(combine(abstr(x,hd[e]),abstr(x,tl[e]))); + case LAMBDA: + case LET: + case LETREC: + case TRIES: + case LABEL: + case SHOW: + case LEXER: + case SHARE: fprintf(stderr,"impossible event in abstr (tag=%d)\n",tag[e]), + exit(1); + default: if(x==e||isvar_t(x)&&isvar_t(e)&&eqtvar(x,e)) + return(I); /* see note */ + return(ap(K,e)); +}} /* note - we allow abstraction wrt tvars - see genshfns() */ + +#define mkindex(i) ((i)<256?(i):make(INT,i,0)) + /* will fall over if i >= IBASE */ + +abstrlist(x,e) /* abstraction of list of variables x from code e */ +word x,e; +{ switch(tag[e]) + { case TCONS: + case PAIR: + case CONS: return(liscomb(abstrlist(x,hd[e]),abstrlist(x,tl[e]))); + case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR) + return(ap(K,e)); /* don't go inside error info */ + else return(combine(abstrlist(x,hd[e]),abstrlist(x,tl[e]))); + case LAMBDA: case LET: case LETREC: case TRIES: case LABEL: case SHOW: + case LEXER: + case SHARE: fprintf(stderr, + "impossible event in abstrlist (tag=%d)\n",tag[e]), + exit(1); + default: { word i=0; + while(x!=NIL&&hd[x]!=e)i++,x=tl[x]; + if(x==NIL)return(ap(K,e)); + return(ap(SUBSCRIPT,mkindex(i))); } +}} + +word rv_script=0; /* flags readvals in use (for garbage collector) */ + +codegen(x) /* returns expression x with abstractions performed */ +word x; +{ extern word debug,commandmode,cook_stdin,common_stdin,common_stdinb,rv_expr; + switch(tag[x]) + { case AP: if(commandmode /* beware of corrupting lastexp */ + &&x!=cook_stdin&&x!=common_stdin&&x!=common_stdinb) /* but share $+ $- */ + return(make(AP,codegen(hd[x]),codegen(tl[x]))); + if(tag[hd[x]]==AP&&hd[hd[x]]==APPEND&&tl[hd[x]]==NIL) + return(codegen(tl[x])); /* post typecheck reversal of HR bug fix */ + hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]); + /* otherwise do in situ */ + return(tag[hd[x]]==AP&&hd[hd[x]]==G_ALT?leftfactor(x):x); + case TCONS: + case PAIR: return(make(CONS,codegen(hd[x]),codegen(tl[x]))); + case CONS: if(commandmode) + return(make(CONS,codegen(hd[x]),codegen(tl[x]))); + /* otherwise do in situ (see declare) */ + hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]); + return(x); + case LAMBDA: return(abstract(hd[x],codegen(tl[x]))); + case LET: return(translet(hd[x],tl[x])); + case LETREC: return(transletrec(hd[x],tl[x])); + case TRIES: return(transtries(hd[x],tl[x])); + case LABEL: return(codegen(tl[x])); + case SHOW: return(makeshow(hd[x],tl[x])); + case LEXER: + { word r=NIL,uses_state=0;; + while(x!=NIL) + { word rule=abstr(mklexvar(0),codegen(tl[tl[hd[x]]])); + rule=abstr(mklexvar(1),rule); + if(!(tag[rule]==AP&&hd[rule]==K))uses_state=1; + r=cons(cons(hd[hd[x]], /* start condition stuff */ + cons(ap(hd[tl[hd[x]]],NIL), /* matcher [] */ + rule)), + r); + x=tl[x]; } + if(!uses_state) /* strip off (K -) from each rule */ + { for(x=r;x!=NIL;x=tl[x])tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]]; + r = ap(LEX_RPT,ap(LEX_TRY,r)); } + else r = ap(LEX_RPT1,ap(LEX_TRY1,r)); + return(ap(r,0)); } /* 0 startcond */ + case STARTREADVALS: + if(ispoly(tl[x])) + { extern word cook_stdin,polyshowerror,ND; + printf("type error - %s used at polymorphic type :: [", + cook_stdin&&x==hd[cook_stdin]?"$+":"readvals or $+"); + out_type(redtvars(tl[x])),printf("]\n"); + polyshowerror=1; + if(current_id) + ND=add1(current_id,ND), + id_type(current_id)=wrong_t, + id_val(current_id)=UNDEF; + if(hd[x])sayhere(hd[x],1); } + if(commandmode)rv_expr=1; else rv_script=1; + return(x); + case SHARE: if(tl[x]!= -1) /* arbitrary flag for already visited */ + hd[x]=codegen(hd[x]),tl[x]= -1; + return(hd[x]); + default: if(x==NILS)return(NIL); + return(x); /* identifier, private name, or constant */ +}} + +word lfrule=0; + +leftfactor(x) + +/* grammar optimisations - x is of the form ap2(G_ALT,...) + G_ALT(G_SEQ a b) a => G_SEQ a (G_ALT b G_UNIT) + G_ALT(G_SEQ a b)(G_SEQ a c) => G_SEQ a (G_ALT b c) + G_ALT(G_SEQ a b)(G_ALT a d) => G_ALT(G_SEQ a (G_ALT b G_UNIT)) d + G_ALT(G_SEQ a b)(G_ALT(G_SEQ a c) d) => G_ALT(G_SEQ a (G_ALT b c)) d +*/ +word x; +{ word a,b,c,d; + if(tag[c=tl[hd[x]]]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ) + a=tl[hd[c]],b=tl[c]; else return(x); + if(same(a,d=tl[x])) + { hd[x]=ap(G_SEQ,a), tl[x]=ap2(G_ALT,b,G_UNIT); lfrule++; + /* printob("rule1: ",x); */ + return(x); } + if(tag[d]==AP&&tag[hd[d]]==AP) + c=hd[hd[d]]; else return(x); + if(c==G_SEQ&&same(a,tl[hd[d]])) + { c=tl[d], + hd[x]=ap(G_SEQ,a), tl[x]=leftfactor(ap2(G_ALT,b,c)); lfrule++; + /* printob("rule2: ",x); */ + return(x); } + if(c!=G_ALT)return(x); + if(same(a,c=tl[hd[d]])) + { d=tl[d]; + hd[x]=ap(G_ALT,ap2(G_SEQ,a,ap2(G_ALT,b,G_UNIT))); + tl[x]=d; lfrule++; + /* printob("rule3: ",x); */ + return(leftfactor(x)); } + if(tag[c]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ + &&same(a,tl[hd[c]])) + { c=tl[c],d=tl[d], + hd[x]=ap(G_ALT,ap2(G_SEQ,a,leftfactor(ap2(G_ALT,b,c)))); + tl[x]=d; lfrule++; + /* printob("rule4: ",x); */ + return(leftfactor(x)); } + return(x); +} + +same(x,y) /* structural equality */ +word x,y; +{ if(x==y)return(1); + if(tag[x]==ATOM||tag[y]==ATOM||tag[x]!=tag[y])return(0); + if(tag[x]<INT)return(hd[x]==hd[y]&&tl[x]==tl[y]); + if(tag[x]>STRCONS)return(same(hd[x],hd[y])&&same(tl[x],tl[y])); + return(hd[x]==hd[y]&&same(tl[x],tl[y])); /* INT..STRCONS */ +} + +static word was_poly; +word polyshowerror; + +makeshow(here,type) +word here,type; +{ word f; + extern word ND; + was_poly=0; f=mkshow(0,0,type); + /* printob("showfn=",f); /* DEBUG */ + if(here&&was_poly) + { extern char *current_script; + printf("type error in definition of %s\n",get_id(current_id)); + sayhere(here,0); + printf(" use of \"show\" at polymorphic type "); + out_type(redtvars(type)); + putchar('\n'); + id_type(current_id)=wrong_t; + id_val(current_id)=UNDEF; + polyshowerror=1; + ND=add1(current_id,ND); + was_poly=0; } + return(f); +} + +mkshow(s,p,t) /* build a show function appropriate to type t */ +word s,p,t; /* p is precedence - 0 for top level, 1 for internal */ + /* s flags special case invoked from genshfns */ +{ extern word shownum1,showbool,showchar,showlist,showstring,showparen, + showvoid,showpair,showfunction,showabstract,showwhat; + word a=NIL; + while(tag[t]==AP)a=cons(tl[t],a),t=hd[t]; + switch(t) + { case num_t: return(p?shownum1:SHOWNUM); + case bool_t: return(showbool); + case char_t: return(showchar); + case list_t: if(hd[a]==char_t)return(showstring); + return(ap(showlist,mkshow(s,0,hd[a]))); + case comma_t: return(ap(showparen,ap2(showpair,mkshow(s,0,hd[a]), + mkshowt(s,hd[tl[a]])))); + case void_t: return(showvoid); + case arrow_t:return(showfunction); + default: if(tag[t]==ID) + { word r=t_showfn(t); + if(r==0) /* abstype without show function */ + return(showabstract); + if(r==showwhat) /* dont apply to parameter showfns */ + return(r); + while(a!=NIL)r=ap(r,mkshow(s,1,hd[a])),a=tl[a]; + if(t_class(t)==algebraic_t)r=ap(r,p); + return(r); + /* note that abstype-showfns have only one precedence + and show their components (if any) at precedence 1 + - if the latter is a problem could do parenthesis + stripping */ + } + if(isvar_t(t)){ if(s)return(t); /* see genshfns */ + was_poly=1; + return(showwhat); } + /* arbitrary - could be any strict function */ + if(tag[t]==STRCONS) /* pname */ /* DEBUG */ + { printf("warning - mkshow applied to suppressed type\n"); + return(showwhat); } + else { printf("impossible event in mkshow ("), + out_type(t), printf(")\n"); + return(showwhat); } + } +} + +mkshowt(s,t) /* t is a (possibly singleton) tuple type */ +word s,t; /* flags special call from genshfns */ +{ extern word showpair; + if(tl[t]==void_t)return(mkshow(s,0,tl[hd[t]])); + return(ap2(showpair,mkshow(s,0,tl[hd[t]]),mkshowt(s,tl[t]))); +} + +word algshfns=NIL; /* list of showfunctions for all algebraic types in scope + (list of pnames) - needed to make dumps */ + +genshfns() /* called after meta type check - create show functions for + algebraic types */ +{ word s; + for(s=newtyps;s!=NIL;s=tl[s]) + if(t_class(hd[s])==algebraic_t) + { word f=0,r=t_info(hd[s]); /* r is list of constructors */ + word ush= tl[r]==NIL&&member(SGC,hd[r])?Ush1:Ush; + for(;r!=NIL;r=tl[r]) + { word t=id_type(hd[r]),k=id_val(hd[r]); + while(tag[k]!=CONSTRUCTOR)k=tl[k];/* lawful and !'d constructors*/ + /* k now holds constructor(i,hd[r]) */ + /* k=constructor(hd[k],datapair(get_id(tl[k]),0)); + /* this `freezes' the name of the constructor */ + /* incorrect, makes showfns immune to aliasing, should be + done at mkshow time, not genshfn time - FIX LATER */ + while(isarrow_t(t)) + k=ap(k,mkshow(1,1,tl[hd[t]])),t=tl[t]; /* NB 2nd arg */ + k=ap(ush,k); + while(iscompound_t(t))k=abstr(tl[t],k),t=hd[t]; + /* see kahrs.bug.m (this is the fix) */ + if(f)f=ap2(TRY,k,f); + else f=k; + } + /* f~=0, placeholder types dealt with in specify() */ + pn_val(t_showfn(hd[s]))=f; + algshfns=cons(t_showfn(hd[s]),algshfns); + } + else + if(t_class(hd[s])==abstract_t) /* if showfn present check type is ok */ + if(t_showfn(hd[s])) + if(!abshfnck(hd[s],id_type(t_showfn(hd[s])))) + printf("warning - \"%s\" has type inappropriate for a show-function\n", + get_id(t_showfn(hd[s]))),t_showfn(hd[s])=0; +} + +abshfnck(t,f) /* t is an abstype, is f right type for its showfn? */ +word t,f; +{ word n=t_arity(t),i=1; + while(i<=n) + if(isarrow_t(f)) + { word h=tl[hd[f]]; + if(!(isarrow_t(h)&&isvar_t(tl[hd[h]])&&gettvar(tl[hd[h]])==i + &&islist_t(tl[h])&&tl[tl[h]]==char_t))return(0); + i++,f=tl[f]; + } else return(0); + if(!(isarrow_t(f)&&islist_t(tl[f])&&tl[tl[f]]==char_t))return(0); + f=tl[hd[f]]; + while(iscompound_t(f)&&isvar_t(tl[f])&&gettvar(tl[f])==n--)f=hd[f]; + return(f==t); +} + +transtries(id,x) +word id,x; /* x is a list of alternative values, in reverse order */ +{ word r,h=0,earliest; + if(fallible(hd[x])) /* add default last case */ + { word oldn=tag[id]==ID?datapair(get_id(id),0):0; + r=ap(BADCASE,h=cons(oldn,0)); + /* 0 is placeholder for here-info */ + /* oldn omitted if id is pattern - FIX LATER */ } + else r=codegen(earliest=hd[x]), x = tl[x]; + while(x!=NIL)r=ap2(TRY,codegen(earliest=hd[x]),r), x=tl[x]; + if(h)tl[h]=hd[earliest]; /* first line-no is the best marker */ + return(r); +} + +translet(d,e) /* compile block with body e and def d */ +word d,e; +{ word x=mklazy(d); + return(ap(abstract(dlhs(x),codegen(e)),codegen(dval(x)))); +} +/* nasty bug, codegen(dval(x)) was interfering with abstract(dlhs(x)... + to fix made codegen on tuples be NOT in situ 20/11/88 */ + +transletrec(dd,e) /* better method, using list indexing - Jan 88 */ +word e,dd; +{ word lhs=NIL,rhs=NIL,pn=1; + /* list of defs (x=e) is combined to listwise def `xs=es' */ + for(;dd!=NIL;dd=tl[dd]) + { word x=hd[dd]; + if(tag[dlhs(x)]==ID) /* couldn't be constructor, by grammar */ + lhs=cons(dlhs(x),lhs), + rhs=cons(codegen(dval(x)),rhs); + else { word i=0,ids,p=mkgvar(pn++); /* see note 1 */ + x=new_mklazy(x); ids=dlhs(x); + lhs=cons(p,lhs),rhs=cons(codegen(dval(x)),rhs); + for(;ids!=NIL;ids=tl[ids],i++) + lhs=cons(hd[ids],lhs), + rhs=cons(ap2(SUBSCRIPT,mkindex(i),p),rhs); + } + } + if(tl[lhs]==NIL) /* singleton */ + return(ap(abstr(hd[lhs],codegen(e)),ap(Y,abstr(hd[lhs],hd[rhs])))); + return(ap(abstrlist(lhs,codegen(e)),ap(Y,abstrlist(lhs,rhs)))); +} +/* note 1: we here use the alternative `mklazy' transformation + pat = e => x1=p!0;...;xn=p!(n-1);p=(lambda(pat)[xs])e|conferror; + where p is a private name (need be unique only within a given letrec) +*/ + +mklazy(d) /* transforms local p=e to ids=($p.ids)e|conferror */ +word d; +{ if(irrefutable(dlhs(d)))return(d); +{ word ids=mktuple(dlhs(d)); + if(ids==NIL){ printf("impossible event in mklazy\n"); return(d); } + dval(d)=ap2(TRY,ap(lambda(dlhs(d),ids),dval(d)), + ap(CONFERROR,cons(dlhs(d),here_inf(dval(d))))); + dlhs(d)=ids; + return(d); +}} + +new_mklazy(d) /* transforms local p=e to ids=($p.ids)e|conferror + with ids a LIST (not tuple as formerly) */ +word d; +{ word ids=get_ids(dlhs(d)); + if(ids==NIL){ printf("impossible event in new_mklazy\n"); return(d); } + dval(d)=ap2(TRY,ap(lambda(dlhs(d),ids),dval(d)), + ap(CONFERROR,cons(dlhs(d),here_inf(dval(d))))); + dlhs(d)=ids; + return(d); +} + +here_inf(rhs) /* rhs is of form tries(id,val_list) */ +word rhs; +{ word x=tl[rhs]; + while(tl[x]!=NIL)x=tl[x]; /* find earliest alternative */ + return(hd[hd[x]]); /* hd[x] is of form label(here_info,value) */ +} + +irrefutable(x) /* x built from suigeneris constr's and (unrepeated) names */ +word x; +{ if(tag[x]==CONS)return(0); /* includes constants */ + if(isconstructor(x))return(sui_generis(x)); + if(tag[x]==ID)return(1); + if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + return(0); + return(irrefutable(hd[x])&&irrefutable(tl[x])); +} + +combine(x,y) +word x,y; +{ word a,b,a1,b1; + a= tag[x]==AP&&hd[x]==K; + b= tag[y]==AP&&hd[y]==K; + if(a&&b)return(ap(K,ap(tl[x],tl[y]))); + /* rule of K propagation */ + if(a&&y==I)return(tl[x]); + /* rule 'eta */ + b1= tag[y]==AP&&tag[hd[y]]==AP&&hd[hd[y]]==B; + if(a)if(b1)return(ap3(B1,tl[x],tl[hd[y]],tl[y])); else + /* Mark Scheevel's new B1 introduction rule -- adopted Aug 83 */ + if(tag[tl[x]]==AP&&tag[hd[tl[x]]]==AP&&hd[hd[tl[x]]]==COND) + return(ap3(COND,tl[hd[tl[x]]],ap(K,tl[tl[x]]),y)); + else return(ap2(B,tl[x],y)); + a1= tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==B; + if(b)if(a1)if(tag[tl[hd[x]]]==AP&&hd[tl[hd[x]]]==COND) + return(ap3(COND,tl[tl[hd[x]]],tl[x],y)); + else return(ap3(C1,tl[hd[x]],tl[x],tl[y])); + else return(ap2(C,x,tl[y])); + if(a1)if(tag[tl[hd[x]]]==AP&&hd[tl[hd[x]]]==COND) + return(ap3(COND,tl[tl[hd[x]]],tl[x],y)); + else return(ap3(S1,tl[hd[x]],tl[x],y)); + else return(ap2(S,x,y)); } + +liscomb(x,y) /* the CONSy analogue of "combine" */ +word x,y; +{ word a,b; + a= tag[x]==AP&&hd[x]==K; + b= tag[y]==AP&&hd[y]==K; + if(a&&b)return(ap(K,cons(tl[x],tl[y]))); + /* K propagation again */ + if(a)if(y==I)return(ap(P,tl[x])); /* eta P - new rule added 20/11/88 */ + else return(ap2(B_p,tl[x],y)); + if(b)return(ap2(C_p,x,tl[y])); + return(ap2(S_p,x,y)); } +/* B_p,C_p,S_p are the CONSy analogues of B,C,S + see MIRANDA REDUCE for their definitions */ + +compzf(e,qq,diag) /* compile a zf expression with body e and qualifiers qq + (listed in reverse order); diag is 0 for sequential + and 1 for diagonalising zf expressions */ +word e,qq,diag; +{ word hold=NIL,r=0,g1= -1; /* r is number of generators */ + while(qq!=NIL) /* unreverse qualifier list */ + { if(hd[hd[qq]]==REPEAT)qq=fixrepeats(qq); + hold=cons(hd[qq],hold); + if(hd[hd[qq]]==GUARD)r++; /* count filters */ + qq = tl[qq]; } + for(qq=hold;qq!=NIL&&hd[hd[qq]]==GUARD;qq=tl[qq])r--; /* less leading filters */ + if(hd[hd[hold]]==GENERATOR)g1=tl[tl[hd[hold]]]; /* rhs of 1st generator */ + e=transzf(e,hold,diag?diagonalise:concat); + /* diagonalise [ // ] comprehensions, but not [ | ] ones */ + if(diag) + while(r--)e=ap(concat,e); /* see funny version of rule 3 below */ + return(e==g1?ap2(APPEND,NIL,e):e); /* test in g1 is to fix HR bug */ +} +/* HR bug - if Rule 1 applied at outermost level, type info is lost + eg [p|p<-3] ==> 3 (reported by Ham Richards, Nov 89) +*/ + +transzf(e,qq,conc) /* Bird and Wadler page 63 */ +word e,qq,conc; +{ word q,q2; + if(qq==NIL)return(cons(e,NIL)); + q=hd[qq]; + if(hd[q]==GUARD) + return(ap3(COND,tl[q],transzf(e,tl[qq],conc),NIL)); + if(tl[qq]==NIL) + if(hd[tl[q]]==e&&isvariable(e))return(tl[tl[q]]); /* Rule 1 */ + else if(irrefutable(hd[tl[q]])) + return(ap2(MAP,lambda(hd[tl[q]],e),tl[tl[q]])); /* Rule 2 */ + else /* Rule 2 warped for refutable patterns */ + return(ap2(FLATMAP,lambda(hd[tl[q]],cons(e,NIL)),tl[tl[q]])); + q2=hd[tl[qq]]; + if(hd[q2]==GUARD) + if(conc==concat) /* Rule 3 */ + { tl[tl[q]]=ap2(FILTER,lambda(hd[tl[q]],tl[q2]),tl[tl[q]]); + tl[qq]=tl[tl[qq]]; + return(transzf(e,qq,conc)); } + else /* funny [//] version of Rule 3 to avoid creating weak lists */ + { e=ap3(COND,tl[q2],cons(e,NIL),NIL); + tl[qq]=tl[tl[qq]]; + return(transzf(e,qq,conc)); } /* plus wrap result with concat */ + return(ap(conc,transzf(transzf(e,tl[qq],conc),cons(q,NIL),conc))); + /* Rule 4 */ +} + +fixrepeats(qq) /* expands multi-lhs generators in zf expressions */ +word qq; +{ word q = hd[qq]; + word rhs = q; + qq = tl[qq]; + while(hd[rhs]==REPEAT)rhs = tl[tl[rhs]]; + rhs = tl[tl[rhs]]; /* rhs now contains the common right hand side */ + while(hd[q]==REPEAT) + { qq = cons(cons(GENERATOR,cons(hd[tl[q]],rhs)),qq); + q = tl[tl[q]]; + } + return(cons(q,qq)); +} /* EFFICIENCY PROBLEM - rhs gets re-evaluated for each lhs, fix later */ + /* likewise re-typechecked, although this probably doesn't matter */ + +lastlink(x) /* finds last link of a list -- needed with zf body elision */ +word x; +{ while(tl[x]!=NIL)x=tl[x]; + return(x); +} + +#define ischar(x) ((x)>=0&&(x)<=255) + +genlhs(x) /* x is an expression found on the lhs of <- and genlhs returns + the corresponding pattern */ +word x; +{ word hold; + switch(tag[x]) + { case AP: + if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS&&isnat(tl[x])) + return(ap2(PLUS,tl[x],genlhs(tl[hd[x]]))); /* n+k pattern */ + case CONS: + case TCONS: + case PAIR: + hold=genlhs(hd[x]); return(make(tag[x],hold,genlhs(tl[x]))); + case ID: + if(member(idsused,x))return(cons(CONST,x)); + if(!isconstructor(x))idsused=cons(x,idsused); return(x); + case INT: return(cons(CONST,x)); + case DOUBLE: syntax("floating point literal in pattern\n"); + return(nill); + case ATOM: if(x==True||x==False||x==NILS||x==NIL||ischar(x)) + return(cons(CONST,x)); + default: syntax("illegal form on left of <-\n"); + return(nill); +}} + +#ifdef OBSOLETE +genexp(x) /* undoes effect of genlhs - sorry about that! (see qualifiers1)*/ +word x; +{ switch(tag[x]) + { case AP: return(ap(genexp(hd[x]),genexp(tl[x]))); + case TCONS: return(tcons(genexp(hd[x]),genexp(tl[x]))); + case PAIR: return(pair(genexp(hd[x]),genexp(tl[x]))); + case CONS: return(hd[x]==CONST?tl[x] + :cons(genexp(hd[x]),genexp(tl[x]))); + default: return(x); /* must be ID or constant */ +}} +#endif + +word speclocs=NIL; /* list of cons(id,hereinfo) giving location of spec for + ids both defined and specified - needed to locate errs + in meta_tcheck, abstr_mcheck */ +getspecloc(x) +word x; +{ word s=speclocs; + while(s!=NIL&&hd[hd[s]]!=x)s=tl[s]; + return(s==NIL?id_who(x):tl[hd[s]]); } + +declare(x,e) /* translates <pattern> = <exp> at top level */ +word x,e; +{ if(tag[x]==ID&&!isconstructor(x))decl1(x,e);else + { word bindings=scanpattern(x,x,share(tries(x,cons(e,NIL)),undef_t), + ap(CONFERROR,cons(x,hd[e]))); + /* hd[e] is here-info */ + /* note creation of share node to force sharing on code generation + and typechecking */ + if(bindings==NIL){ errs=hd[e]; + syntax("illegal lhs for definition\n"); + return; } + lastname=0; + while(bindings!=NIL) + { word h; + if(id_val(h=hd[hd[bindings]])!=UNDEF) + { errs=hd[e]; nameclash(h); return; } + id_val(h)=tl[hd[bindings]]; + if(id_who(h)!=NIL)speclocs=cons(cons(h,id_who(h)),speclocs); + id_who(h)=hd[e]; /* here-info */ + if(id_type(h)==undef_t)addtoenv(h); + bindings = tl[bindings]; + } +}} + +scanpattern(p,x,e,fail) /* declare ids in x as components of `p=e', each as + n = ($p.n)e, result is list of bindings */ +word p,x,e,fail; +{ if(hd[x]==CONST||isconstructor(x))return(NIL); + if(tag[x]==ID){ word binding= + cons(x,ap2(TRY,ap(lambda(p,x),e),fail)); + return(cons(binding,NIL)); } + if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + return(scanpattern(p,tl[x],e,fail)); + return(shunt(scanpattern(p,hd[x],e,fail),scanpattern(p,tl[x],e,fail))); +} + +get_ids(x) /* return list of names in pattern x (without repetitions) */ +word x; +{ if(hd[x]==CONST||isconstructor(x))return(NIL); + if(tag[x]==ID)return(cons(x,NIL)); + if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + return(get_ids(tl[x])); + return(UNION(get_ids(hd[x]),get_ids(tl[x]))); +} + +mktuple(x) /* extract tuple-structure of names from pattern x */ +word x; +{ if(hd[x]==CONST||isconstructor(x))return(NIL); + if(tag[x]==ID)return(x); + if(tag[x]==AP&&tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + return(mktuple(tl[x])); +{ word y=mktuple(tl[x]); x=mktuple(hd[x]); + return(x==NIL?y:y==NIL?x:pair(x,y)); +}} + +decl1(x,e) /* declare name x to have the value denoted by e */ +word x,e; +{ if(id_val(x)!=UNDEF&&lastname!=x) + { errs=hd[e]; nameclash(x); return; } + if(id_val(x)==UNDEF) + { id_val(x)= tries(x,cons(e,NIL)); + if(id_who(x)!=NIL)speclocs=cons(cons(x,id_who(x)),speclocs); + id_who(x)= hd[e]; /* here-info */ + if(id_type(x)==undef_t)addtoenv(x); + } else + if(!fallible(hd[tl[id_val(x)]])) + errs=hd[e], + printf("%ssyntax error: unreachable case in defn of \"%s\"\n", + echoing?"\n":"",get_id(x)), + acterror(); + else tl[id_val(x)]= cons(e,tl[id_val(x)]); +/* multi-clause definitions are composed as tries(id,rhs_list) + where id is included purely for diagnostic purposes + note that rhs_list is reversed - put right by code generation */ +} + +fallible(e) /* e is "fallible" rhs - if not sure, says yes */ +word e; +{ for(;;) + { if(tag[e]==LABEL)e=tl[e]; + if(tag[e]==LETREC||tag[e]==LET)e=tl[e]; else + if(tag[e]==LAMBDA) + if(irrefutable(hd[e]))e=tl[e]; + else return(1); else + if(tag[e]==AP&&tag[hd[e]]==AP&&tag[hd[hd[e]]]==AP&&hd[hd[hd[e]]]==COND) + e=tl[e]; else + return(e==FAIL); /* test for nested (COND a b FAIL) */ + } +} /* NOTE + When an rhs contains FAIL as a result of compiling an elseless guard set + it is of the form + XX ::= ap3(COND,a,b,FAIL) | let[rec](def[s],XX) | lambda(pat,XX) + an rhs is fallible if + 1) it is an XX, as above, or + 2) it is of the form lambda(pat1,...,lambda(patn,e)...) + where at least one of the patterns pati is refutable. + */ + +/* combinator to select i'th out of n args *//* +k(i,n) +int i,n; +{ if(i==1)return(n==1?I:n==2?K:ap2(B,K,k(1,n-1))); + if(i==2&&n==2)return(KI); /* redundant but saves space *//* + return(ap(K,k(i-1,n-1))); +} */ + +#define arity_check if(t_arity(tf)!=arity)\ + printf("%ssyntax error: \ +wrong number of parameters for typename \"%s\" (%d expected)\n",\ + echoing?"\n":"",get_id(tf),t_arity(tf)),errs=here,acterror() + +decltype(tf,class,info,here) /* declare a user defined type */ +word tf,class,info,here; +{ word arity=0; + extern word errs; + while(tag[tf]==AP)arity++,tf=hd[tf]; + if(class==synonym_t&&id_type(tf)==type_t&&t_class(tf)==abstract_t + &&t_info(tf)==undef_t) + { /* this is binding for declared but not yet bound abstract typename */ + arity_check; + id_who(tf)=here; + t_info(tf)=info; + return; } + if(class==abstract_t&&id_type(tf)==type_t&&t_class(tf)==synonym_t) + { /* this is abstype declaration of already bound typename */ + arity_check; + t_class(tf)=abstract_t; + return; } + if(id_val(tf)!=UNDEF) + { errs=here; nameclash(tf); return; } + if(class!=synonym_t)newtyps=add1(tf,newtyps); + id_val(tf)=make_typ(arity,class==algebraic_t?make_pn(UNDEF):0,class,info); + if(id_type(tf)!=undef_t){ errs=here; respec_error(tf); return; } + else addtoenv(tf); + id_who(tf)=here; + id_type(tf)=type_t; +} + +declconstr(x,n,t) /* declare x to be constructor number n of type t */ +word x,n,t; /* x must be an identifier */ +{ id_val(x)=constructor(n,x); + if(n>>16) + { syntax("algebraic type has too many constructors\n"); return; } + if(id_type(x)!=undef_t){ errs=id_who(x); respec_error(x); return; } + else addtoenv(x); + id_type(x) = t; +} /* the value of a constructor x is constructor(constr_tag,x) + where constr_tag is a small natural number */ + +/* #define DEPSDEBUG . + /* switches on debugging printouts for dependency analysis in block() */ +#ifdef DEPSDEBUG +pd(def) +word def; +{ out1(stdout,dlhs(def)); } + +pdlist(defs) +word defs; +{ putchar('('); + for(;defs!=NIL;defs=tl[defs]) + pd(hd[defs]),printf(tl[defs]==NIL?"":","); + putchar(')'); +} +#endif + +block(defs,e,keep) /* semantics of "where" - performs dependency analysis */ +/* defs has form list(defn(pat,typ,val)), e is body of block */ +/* if `keep' hold together as single letrec */ +word defs,e,keep; +{ word ids=NIL,deftoids=NIL,g=NIL,d; + extern word SYNERR,detrop; + /* return(letrec(defs,e)); /* release one semantics was just this */ + if(SYNERR)return(NIL); /* analysis falls over on empty patterns */ + for(d=defs;d!=NIL;d=tl[d]) /* first collect all ids defined in block */ + { word x = get_ids(dlhs(hd[d])); + ids=UNION(ids,x); + deftoids=cons(cons(hd[d],x),deftoids); + } + defs=sort(defs); + for(d=defs;d!=NIL;d=tl[d]) /* now build dependency relation g */ + { word x=intersection(deps(dval(hd[d])),ids),y=NIL; + for(;x!=NIL;x=tl[x]) /* replace each id by corresponding def */ + y=add1(invgetrel(deftoids,hd[x]),y); + g=cons(cons(hd[d],add1(hd[d],y)),g); + /* treat all defs as recursive for now */ + } + g=reverse(g); /* keep in address order of first components */ +#ifdef DEPSDEBUG + { word g1=g; + printf("g="); + for(;g1!=NIL;g1=tl[g1]) + pd(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';'); + printf("\n"); } +#endif +/* g is list(cons(def,defs)) + where defs are all on which def immediately depends, plus self */ + g = tclos(g); /* now g is list(cons(def,ultdefs)) */ +#ifdef DEPSDEBUG + { word g1=g; + printf("tclos(g)="); + for(;g1!=NIL;g1=tl[g1]) + pd(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';'); + printf("\n"); } +#endif + { /* check for unused definitions */ + word x=intersection(deps(e),ids),y=NIL,*g1= &g; + for(;x!=NIL;x=tl[x]) + { word d=invgetrel(deftoids,hd[x]); + if(!member(y,d))y=UNION(y,getrel(g,d)); } + defs=setdiff(defs,y); /* these are de trop */ + if(defs!=NIL)detrop=append1(detrop,defs); + if(keep) /* if local polymorphism not required */ + return(letrec(y,e)); /* analysis was solely to find unwanted defs */ + /* remove redundant entries from g */ + /* no, leave in for typecheck - could remove afterwards + while(*g1!=NIL&&defs!=NIL) + if(hd[hd[*g1]]==hd[defs])*g1=tl[*g1]; else + if(hd[hd[*g1]]<hd[defs])g1= &tl[*g1]; + else defs=tl[defs]; */ + } + g = msc(g); /* g is list(defgroup,ultdefs) */ +#ifdef DEPSDEBUG + { word g1=g; + printf("msc(g)="); + for(;g1!=NIL;g1=tl[g1]) + pdlist(hd[hd[g1]]),putchar(':'),pdlist(tl[hd[g1]]),putchar(';'); + printf("\n"); } +#endif + g = tsort(g); /* g is list(defgroup) in dependency order */ +#ifdef DEPSDEBUG + { word g1=g; + printf("tsort(g)="); + for(;g1!=NIL;g1=tl[g1]) + pdlist(hd[g1]),putchar(';'); + printf("\n"); } +#endif + g = reverse(g); /* reconstruct block inside-first */ + while(g!=NIL) + { if(tl[hd[g]]==NIL && + intersection(get_ids(dlhs(hd[hd[g]])),deps(dval(hd[hd[g]])))==NIL + )e=let(hd[hd[g]],e); /* single non-recursive def */ + else e=letrec(hd[g],e); + g=tl[g]; } + return(e); +} +/* Implementation note: + tsort will fall over if there is a non-list strong component because it + was originally written on assumption that relation is over identifiers. + Whence need to pretend all defs recursive until after tsort. + Could do better - some defs may be subsidiary to others */ + +tclos(r) /* fast transitive closure - destructive in r */ +word r; /* r is of form list(cons(x,xs)) */ +{ word r1; + for(r1=r;r1!=NIL;r1=tl[r1]) + { word x= less1(tl[hd[r1]],hd[hd[r1]]); + /* invariant x intersect tl[hd[r1]] = NIL */ + while(x!=NIL) + { x=imageless(r,x,tl[hd[r1]]); + tl[hd[r1]]=UNION(tl[hd[r1]],x); } + } + return(r); +} + +getrel(r,x) /* r is list(cons(x,xs)) - return appropriate xs, else NIL */ +word r,x; +{ while(r!=NIL&&hd[hd[r]]!=x)r=tl[r]; + return(r==NIL?NIL:tl[hd[r]]); +} + +invgetrel(r,x) /* return first x1 such that `x1 r x' error if none found */ +word r,x; +{ while(r!=NIL&&!member(tl[hd[r]],x))r=tl[r]; + if(r==NIL)fprintf(stderr,"impossible event in invgetrel\n"),exit(1); + return(hd[hd[r]]); +} + + +imageless(r,y,z) /* image of set y in reln r, less set z */ +word r,y,z; +{ word i=NIL; + while(r!=NIL&&y!=NIL) + if(hd[hd[r]]==hd[y]) + i=UNION(i,less(tl[hd[r]],z)),r=tl[r],y=tl[y]; else + if(hd[hd[r]]<hd[y])r=tl[r]; + else y=tl[y]; + return(i); +} + +less(x,y) /* non-destructive set difference x-y */ +word x,y; +{ word r=NIL; + while(x!=NIL&&y!=NIL) + if(hd[x]==hd[y])x=tl[x],y=tl[y]; else + if(hd[x]<hd[y])r=cons(hd[x],r),x=tl[x]; + else y=tl[y]; + return(shunt(r,x)); +} + +less1(x,a) /* non-destructive set difference x- {a} */ +word x,a; +{ word r=NIL; + while(x!=NIL&&hd[x]!=a)r=cons(hd[x],r),x=tl[x]; + return(shunt(r,x==NIL?NIL:tl[x])); +} + +sort(x) /* into address order */ +word x; +{ word a=NIL,b=NIL,hold=NIL; + if(x==NIL||tl[x]==NIL)return(x); + while(x!=NIL) /* split x */ + { hold=a,a=cons(hd[x],b),b=hold; + x=tl[x]; } + a=sort(a),b=sort(b); + /* now merge two halves back together */ + while(a!=NIL&&b!=NIL) + if(hd[a]<hd[b])x=cons(hd[a],x),a=tl[a]; + else x=cons(hd[b],x),b=tl[b]; + if(a==NIL)a=b; + while(a!=NIL)x=cons(hd[a],x),a=tl[a]; + return(reverse(x)); +} + +sortrel(x) /* sort relation into address order of first components */ +word x; /* x is a list of cons(y,ys) */ +{ word a=NIL,b=NIL,hold=NIL; + if(x==NIL||tl[x]==NIL)return(x); + while(x!=NIL) /* split x */ + { hold=a,a=cons(hd[x],b),b=hold; + x=tl[x]; } + a=sortrel(a),b=sortrel(b); + /* now merge two halves back together */ + while(a!=NIL&&b!=NIL) + if(hd[hd[a]]<hd[hd[b]])x=cons(hd[a],x),a=tl[a]; + else x=cons(hd[b],x),b=tl[b]; + if(a==NIL)a=b; + while(a!=NIL)x=cons(hd[a],x),a=tl[a]; + return(reverse(x)); +} + +specify(x,t,h) /* semantics of a "::" statement */ +word x,t,h; /* N.B. t not yet in reduced form */ +{ extern word showwhat; + if(tag[x]!=ID&&t!=type_t){ errs=h; + syntax("incorrect use of ::\n"); + return; } + if(t==type_t) + { word a=0; + while(tag[x]==AP)a++,x=hd[x]; + if(!(id_val(x)==UNDEF&&id_type(x)==undef_t)) + { errs=h; nameclash(x); return; } + id_type(x)=type_t; + if(id_who(x)==NIL)id_who(x)=h; /* premise always true, see above */ + /* if specified and defined, locate by definition */ + id_val(x)=make_typ(a,showwhat,placeholder_t,NIL);/* placeholder type */ + addtoenv(x); + newtyps=add1(x,newtyps); + return; } + if(id_type(x)!=undef_t){ errs=h; respec_error(x); return; } + id_type(x)=t; + if(id_who(x)==NIL)id_who(x)=h; /* as above */ + else speclocs=cons(cons(x,h),speclocs); + if(id_val(x)==UNDEF)addtoenv(x); +} + +respec_error(x) /* only one type spec per name allowed - IS THIS RIGHT? */ +word x; +{ extern word primenv; + if(echoing)putchar('\n'); + printf("syntax error: type of \"%s\" already declared%s\n",get_id(x), + member(primenv,x)?" (in standard environment)":""); + acterror(); +} + +nameclash(x) /* only one top level binding per name allowed */ +word x; +{ extern word primenv; + if(echoing)putchar('\n'); + printf("syntax error: nameclash, \"%s\" already defined%s\n",get_id(x), + member(primenv,x)?" (in standard environment)":""); + acterror(); +} + +nclashcheck(n,dd,hr) /* is n already bound in list of definitions dd */ +word n,dd,hr; +{ while(dd!=NIL&&!nclchk(n,dlhs(hd[dd]),hr))dd=tl[dd]; +} + +nclchk(n,p,hr) /* is n already bound in pattern p */ +word n,p,hr; +{ if(hd[p]==CONST)return(0); + if(tag[p]==ID) + { if(n!=p)return(0); + if(echoing)putchar('\n'); + errs=hr, + printf( +"syntax error: conflicting definitions of \"%s\" in where clause\n", + get_id(n)), + acterror(); + return(1); } + if(tag[p]==AP&&hd[p]==PLUS) /* hd of n+k pattern */ + return(0); + return(nclchk(n,hd[p],hr)||nclchk(n,tl[p],hr)); +} + +transtypeid(x) /* recognises literal type constants - see RULES */ +word x; +{ char *n=get_id(x); + return(strcmp(n,"bool")==0?bool_t: + strcmp(n,"num")==0?num_t: + strcmp(n,"char")==0?char_t: + x); +} + +/* end of MIRANDA TRANS */ + diff --git a/new/types.c b/new/types.c new file mode 100644 index 0000000..f20627f --- /dev/null +++ b/new/types.c @@ -0,0 +1,1613 @@ +/* MIRANDA TYPECHECKER */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +word R=NIL; /* direct-and-indirect dependency graph */ +word TABSTRS=NIL; /* list of abstype declarations */ +word ND; /* undefined names used in script */ +word SBND; /* names specified but not defined (handled separately) */ +word FBS; /* list of bindings caused by parameterised %include's */ +word ATNAMES; /* global var set by abstr_check */ +word NT=NIL; /* undefined typenames used in script */ +word TYPERRS; +word bnf_t=0; +word current_id=0,lastloc=0,lineptr=0; /* used to locate type errors */ +word showchain=NIL; /* links together all occurrences of special forms (show) + encountered during typecheck */ +extern word rfl; + +#include <setjmp.h> +jmp_buf env1; /* for longjmp - see man (3) setjmp */ + +checktypes() /* outcome indicated by setting of flags SYNERR, TYPERRS, ND */ +{ word s; + extern word freeids,SYNERR,fnts; + ATNAMES=TYPERRS=0; + NT=R=SBND=ND=NIL; /* NT=R= added 4/6/88 */ + if(setjmp(env1)==1)goto L; + if(rfl!=NIL)readoption(); + for(s=reverse(fil_defs(hd[files]));s!=NIL;s=tl[s]) + comp_deps(hd[s]); /* for each identifier in current script, compute + dependencies to form R */ + R=tclos(sortrel(R)); + if(FBS!=NIL)mcheckfbs(); + abstr_mcheck(TABSTRS); +L:if(TYPERRS) + { /* badly formed types, so give up */ + TABSTRS=NT=R=NIL; + printf("typecheck cannot proceed - compilation abandoned\n"); + SYNERR=1; + return; } + if(freeids!=NIL)redtfr(freeids); + /* printgraph("dependency analysis:",R); /* for debugging */ + genshfns(); + if(fnts!=NIL)genbnft(); + R=msc(R); + /* printgraph("strong components:",R); /* for debugging */ + s=tsort(R); + /* printlist("topological sort:",s); /* for debugging */ + NT=R=NIL; /* must be invariant across the call */ + while(s!=NIL)infer_type(hd[s]),s=tl[s]; + checkfbs(); + while(TABSTRS!=NIL) + abstr_check(hd[TABSTRS]),TABSTRS=tl[TABSTRS]; + if(SBND!=NIL) + printlist("SPECIFIED BUT NOT DEFINED: ",alfasort(SBND)),SBND=NIL; + fixshows(); + lastloc=0; + return; +} + +/* NOTES + let element ::= id | list(id) + let graph1 ::= list(cons(id,list(id))) + let graph2 ::= list(cons(element,list(id))) + we define: + comp_deps(id)->builds R::graph1, direct dependencies + R=tclos(sortrel(R))::graph1, direct and indirect dependencies + msc(R)->collects maximal strong components in R, now R::graph2 + tsort(graph2)->list(element), topologically sorted + infer_type(element)->fills in the id_type field(s) of element +*/ +/* R occupies quadratic worst-case space - does anyone know a better way? */ + +comp_deps(n) /* adds to R an entry of the form cons(n,RHS) where n is an + identifier and RHS is a list of all the identifiers in the + current script upon which n directly depends */ +/* it also meta-typechecks type specifications, and puts them in reduced + form, as it goes */ +word n; +{ word rhs=NIL,r; + /* printf("comp_deps(%s)\n",get_id(n)); /* DEBUG */ + if(id_type(n)==type_t) + { if(t_class(n)==algebraic_t) + { r=t_info(n); + while(r!=NIL) /* meta type check constructors */ + { current_id=hd[r]; + id_type(hd[r])=redtvars(meta_tcheck(id_type(hd[r]))); + r=tl[r]; } + } + else if(t_class(n)==synonym_t) + current_id=n,t_info(n)=meta_tcheck(t_info(n)); + else if(t_class(n)==abstract_t) + if(t_info(n)==undef_t) + printf("error: script contains no binding for abstract typename\ + \"%s\"\n",get_id(n)),sayhere(id_who(n),1),TYPERRS++; + else current_id=n,t_info(n)=meta_tcheck(t_info(n)); + /* placeholder types - no action */ + current_id=0; + return; } + if(tag[id_val(n)]==CONSTRUCTOR)return; + /* primitive constructors require no type analysis */ + if(id_type(n)!=undef_t) /* meta typecheck spec, if present */ + { current_id=n; + if(tag[id_type(n)]==CONS) + { /* signature identifier */ + if(id_val(n)==UNDEF)SBND=add1(n,SBND); + id_type(n)=redtvars(meta_tcheck(hd[id_type(n)])); + current_id=0; + return; } /* typechecked separately, under TABSTRS */ + id_type(n)=redtvars(meta_tcheck(id_type(n))); + current_id=0; } + if(id_val(n)==FREE)return; /* no further analysis required */ + if(id_val(n)==UNDEF) /* name specified but not defined */ + { SBND=add1(n,SBND); /* change of policy (as for undefined sigid, above) */ + return; } /* now not added to ND, so script can be %included */ + r=deps(id_val(n)); + while(r!=NIL) + { if(id_val(hd[r])!=UNDEF&&id_type(hd[r])==undef_t) + /* only defined names without explicitly assigned types + cause dependency */ + rhs=add1(hd[r],rhs); + r=tl[r]; } + R=cons(cons(n,rhs),R); +} + +tsort(g) /* topological sort - returns a list of the elements in the domain + of relation g, in an order such that each element is preceded by everything + it depends on */ +word g; /* the structure of g is "graph2" see NOTES above */ +{ word NP=NIL; /* NP is set of elements with no predecessor */ + word g1=g, r=NIL; /* r is result */ + g=NIL; + while(g1!=NIL) + { if(tl[hd[g1]]==NIL)NP=cons(hd[hd[g1]],NP); + else g=cons(hd[g1],g); + g1=tl[g1]; } + while(NP!=NIL) + { word D=NIL; /* ids to be removed from range of g */ + while(NP!=NIL) + { r=cons(hd[NP],r); + if(tag[hd[NP]]==ID)D=add1(hd[NP],D); + else D=UNION(D,hd[NP]); + NP=tl[NP]; } + g1=g;g=NIL; + while(g1!=NIL) + { word rhs=setdiff(tl[hd[g1]],D); + if(rhs==NIL)NP=cons(hd[hd[g1]],NP); + else tl[hd[g1]]=rhs,g=cons(hd[g1],g); + g1=tl[g1]; } + } + if(g!=NIL)fprintf(stderr,"error: impossible event in tsort\n"); + return(reverse(r)); +} + +msc(R) /* collects maximal strong components in R, converting it from "graph1" + to "graph2" form - destructive in R */ +word R; +{ word R1=R; + while(R1!=NIL) + { word *r= &tl[hd[R1]],l=hd[hd[R1]]; + if(remove1(l,r)) + { hd[hd[R1]]=cons(l,NIL); + while(*r!=NIL) + { word n=hd[*r],*R2= &tl[R1]; + while(*R2!=NIL&&hd[hd[*R2]]!=n)R2= &tl[*R2]; /* find n-entry in R */ + if(*R2!=NIL&&member(tl[hd[*R2]],l)) + { *r=tl[*r]; /* remove n from r */ + *R2=tl[*R2]; /* remove n's entry from R */ + hd[hd[R1]]=add1(n,hd[hd[R1]]); + } + else r= &tl[*r]; + } + } + R1=tl[R1]; + } + return(R); +} + +word meta_pending=NIL; + +meta_tcheck(t) /* returns type t with synonyms substituted out and checks that + the result is well formed */ +word t; +{ word tn=t,i=0; + /* TO DO -- TIDY UP ERROR MESSAGES AND SET ERRLINE (ERRS) IF POSS */ + while(iscompound_t(tn)) + tl[tn]=meta_tcheck(tl[tn]),i++,tn=hd[tn]; + if(tag[tn]==STRCONS)goto L; /* patch to handle free type bindings */ + if(tag[tn]!=ID) + { if(i>0&&(isvar_t(tn)||tn==bool_t||tn==num_t||tn==char_t)) + { TYPERRS++; + if(tag[current_id]==DATAPAIR) + locate_inc(), + printf("badly formed type \""),out_type(t), + printf("\" in binding for \"%s\"\n",(char *)hd[current_id]), + printf("("),out_type(tn),printf(" has zero arity)\n"); + else + printf("badly formed type \""),out_type(t), + printf("\" in %s for \"%s\"\n", + id_type(current_id)==type_t?"== binding":"specification", + get_id(current_id)), + printf("("),out_type(tn),printf(" has zero arity)\n"), + sayhere(getspecloc(current_id),1); + sterilise(t); } + return(t); } + if(id_type(tn)==undef_t&&id_val(tn)==UNDEF) + { TYPERRS++; + if(!member(NT,tn)) + { if(tag[current_id]==DATAPAIR)locate_inc(); + printf("undeclared typename \"%s\" ",get_id(tn)); + if(tag[current_id]==DATAPAIR) + printf("in binding for %s\n",(char *)hd[current_id]); + else sayhere(getspecloc(current_id),1); + NT=add1(tn,NT); } + return(t); }else + if(id_type(tn)!=type_t||t_arity(tn)!=i) + { TYPERRS++; + if(tag[current_id]==DATAPAIR) + locate_inc(), + printf("badly formed type \""),out_type(t), + printf("\" in binding for \"%s\"\n",(char *)hd[current_id]); + else + printf("badly formed type \""),out_type(t), + printf("\" in %s for \"%s\"\n", + id_type(current_id)==type_t?"== binding":"specification", + get_id(current_id)); + if(id_type(tn)!=type_t) + printf("(%s not defined as typename)\n",get_id(tn)); + else printf("(typename %s has arity %d)\n",get_id(tn),t_arity(tn)); + if(tag[current_id]!=DATAPAIR) + sayhere(getspecloc(current_id),1); + sterilise(t); + return(t); } +L:if(t_class(tn)!=synonym_t)return(t); + if(member(meta_pending,tn)) + { TYPERRS++;/* report cycle */ + if(tag[current_id]==DATAPAIR)locate_inc(); + printf("error: cycle in type \"==\" definition%s ", + meta_pending==NIL?"":"s"); + printelement(meta_pending); putchar('\n'); + if(tag[current_id]!=DATAPAIR) + sayhere(id_who(tn),1); + longjmp(env1,1); /* fatal error - give up */ +/* t_class(tn)=algebraic_t;t_info(tn)=NIL; + /* to make sure we dont fall in here again! */ + return(t); } + meta_pending=cons(tn,meta_pending); + tn=NIL; + while(iscompound_t(t)) + tn=cons(tl[t],tn),t=hd[t]; + t=meta_tcheck(ap_subst(t_info(t),tn)); + meta_pending=tl[meta_pending]; + return(t); +} +/* needless inefficiency - we recheck the rhs of a synonym every time we + use it */ + +sterilise(t) /* to prevent multiple reporting of metatype errors from + namelist :: type */ +word t; +{ if(tag[t]==AP)hd[t]=list_t,tl[t]=num_t; +} + +word tvcount=1; +#define NTV mktvar(tvcount++) + /* brand new type variable */ +#define reset_SUBST (current_id=tvcount>=hashsize?clear_SUBST():0) + +infer_type(x) /* deduces the types of the identifiers in x - no result, + works by filling in id_type fields */ +word x; /* x is an "element" */ +{ if(tag[x]==ID) + { word t,oldte=TYPERRS; + current_id=x; + t = subst(etype(id_val(x),NIL,NIL)); + if(id_type(x)==undef_t)id_type(x)=redtvars(t); + else /* x already has assigned type */ + if(!subsumes(t,instantiate(id_type(x)))) + { TYPERRS++; + printf("incorrect declaration "); + sayhere(getspecloc(x),1); /* or: id_who(x) to locate defn */ + printf("specified, "); report_type(x); putchar('\n'); + printf("inferred, %s :: ",get_id(x)); out_type(redtvars(t)); + putchar('\n'); } + if(TYPERRS>oldte)id_type(x)=wrong_t, + id_val(x)=UNDEF, + ND=add1(x,ND); + reset_SUBST; } + else{ /* recursive group of names */ + word x1,oldte,ngt=NIL; + for(x1=x;x1!=NIL;x1=tl[x1]) + ngt=cons(NTV,ngt), + id_type(hd[x1])=ap(bind_t,hd[ngt]); + for(x1=x;x1!=NIL;x1=tl[x1]) + { oldte=TYPERRS, + current_id=hd[x1], + unify(tl[id_type(hd[x1])],etype(id_val(hd[x1]),NIL,ngt)); + if(TYPERRS>oldte) + id_type(hd[x1])=wrong_t, + id_val(hd[x1])=UNDEF,ND=add1(hd[x1],ND); } + for(x1=x;x1!=NIL;x1=tl[x1]) + if(id_type(hd[x1])!=wrong_t) + id_type(hd[x1])=redtvars(ult(tl[id_type(hd[x1])])); + reset_SUBST; + } +} + +word hereinc; /* location of currently-being-processed %include */ +word lasthereinc; + +mcheckfbs() +{ word ff,formals,n; + lasthereinc=0; + for(ff=FBS;ff!=NIL;ff=tl[ff]) + { hereinc=hd[hd[FBS]]; + for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals]) + { word t=tl[tl[hd[formals]]]; + if(t!=type_t)continue; + current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */ + t_info(hd[hd[formals]])=meta_tcheck(t_info(hd[hd[formals]])); + /*ATNAMES=cons(hd[hd[formals]],ATNAMES?ATNAMES:NIL); */ + current_id=0; + } + if(TYPERRS)return; /* to avoid misleading error messages */ + for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals]) + { word t=tl[tl[hd[formals]]]; + if(t==type_t)continue; + current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */ + tl[tl[hd[formals]]]=redtvars(meta_tcheck(t)); + current_id=0; + } + /* above double traverse is very inefficient way of doing types first + would be better to have bindings sorted in this order beforehand */ + } + /* all imported names must now have their types reduced to + canonical form wrt the parameter bindings */ + /* alternative method - put info in ATNAMES, see above and in abstr_check */ + /* a problem with this is that types do not print in canonical form */ + if(TYPERRS)return; + for(ff=tl[files];ff!=NIL;ff=tl[ff]) + for(formals=fil_defs(hd[ff]);formals!=NIL;formals=tl[formals]) + if(tag[n=hd[formals]]==ID) + if(id_type(n)==type_t) + { if(t_class(n)==synonym_t)t_info(n)=meta_tcheck(t_info(n)); } + else id_type(n)=redtvars(meta_tcheck(id_type(n))); +} /* wasteful if many includes */ + +redtfr(x) /* ensure types of freeids are in reduced form */ +word x; +{ for(;x!=NIL;x=tl[x]) + tl[tl[hd[x]]] = id_type(hd[hd[x]]); +} + +checkfbs() +/* FBS is list of entries of form cons(hereinfo,formals) where formals + has elements of form cons(id,cons(datapair(orig,0),type)) */ +{ word oldte=TYPERRS,formals; + lasthereinc=0; + for(;FBS!=NIL;FBS=tl[FBS]) + for(hereinc=hd[hd[FBS]],formals=tl[hd[FBS]]; + formals!=NIL;formals=tl[formals]) + { word t,t1=fix_type(tl[tl[hd[formals]]]); + if(t1==type_t)continue; + current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */ + t = subst(etype(the_val(hd[hd[formals]]),NIL,NIL)); + if(!subsumes(t,instantiate(t1))) + { TYPERRS++; + locate_inc(); + printf("binding for parameter `%s' has wrong type\n", + (char *)hd[current_id]); + printf( "required :: "); out_type(tl[tl[hd[formals]]]); + printf("\n actual :: "); out_type(redtvars(t)); + putchar('\n'); } + the_val(hd[hd[formals]])=codegen(the_val(hd[hd[formals]])); } + if(TYPERRS>oldte) + { /* badly typed parameter bindings, so give up */ + extern word SYNERR; + TABSTRS=NT=R=NIL; + printf("compilation abandoned\n"); + SYNERR=1; } + reset_SUBST; +} + +fix_type(t,x) /* substitute out any indirected typenames in t */ +word t,x; +{ switch(tag[t]) + { case AP: + case CONS: tl[t]=fixtype(tl[t],x); + hd[t]=fixtype(hd[t],x); + default: return(t); + case STRCONS: while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/ + return(t); + } +} + +locate_inc() +{ if(lasthereinc==hereinc)return; + printf("incorrect %%include directive "); + sayhere(lasthereinc=hereinc,1); +} + +abstr_mcheck(tabstrs) /* meta-typecheck abstract type declarations */ +word tabstrs; +{ while(tabstrs!=NIL) + { word atnames=hd[hd[tabstrs]],sigids=tl[hd[tabstrs]],rtypes=NIL; + if(cyclic_abstr(atnames))return; + while(sigids!=NIL) /* compute representation types */ + { word rt=rep_t(id_type(hd[sigids]),atnames); + /*if(rt==id_type(hd[sigids])) + printf("abstype declaration error: \"%s\" has a type unrelated to \ +the abstraction\n",get_id(hd[sigids])), + sayhere(getspecloc(hd[sigids]),1), + TYPERRS++; /* suppressed June 89, see karen.m, secret.m */ + rtypes=cons(rt,rtypes); + sigids=tl[sigids]; } + rtypes=reverse(rtypes); + hd[hd[tabstrs]]=cons(hd[hd[tabstrs]],rtypes); + tabstrs=tl[tabstrs]; + } +} + +abstr_check(x) /* typecheck the implementation equations of a type abstraction + with the given signature */ +word x; +{ word rtypes=tl[hd[x]],sigids=tl[x]; +/*int holdat=ATNAMES; + ATNAMES=shunt(hd[hd[x]],ATNAMES); */ + ATNAMES=hd[hd[x]]; + txchange(sigids,rtypes); /* install representation types */ + /* report_types("concrete signature:\n",sigids); /* DEBUG */ + for(x=sigids;x!=NIL;x=tl[x]) + { word t,oldte=TYPERRS; + current_id=hd[x]; + t=subst(etype(id_val(hd[x]),NIL,NIL)); + if(!subsumes(t,instantiate(id_type(hd[x])))) + { TYPERRS++; + printf("abstype implementation error\n"); + printf("\"%s\" is bound to value of type: ",get_id(hd[x])); + out_type(redtvars(t)); + printf("\ntype expected: "); + out_type(id_type(hd[x])); + putchar('\n'); + sayhere(id_who(hd[x]),1); } + if(TYPERRS>oldte) + id_type(hd[x])=wrong_t,id_val(hd[x])=UNDEF,ND=add1(hd[x],ND); + reset_SUBST; } + /* restore the abstract types - for "finger" */ + for(x=sigids;x!=NIL;x=tl[x],rtypes=tl[rtypes]) + if(id_type(hd[x])!=wrong_t)id_type(hd[x])=hd[rtypes]; + ATNAMES= /* holdat */ 0; +} + +cyclic_abstr(atnames) /* immediately-cyclic acts of dta are illegal */ +word atnames; +{ word x,y=NIL; + for(x=atnames;x!=NIL;x=tl[x])y=ap(y,t_info(hd[x])); + for(x=atnames;x!=NIL;x=tl[x]) + if(occurs(hd[x],y)) + { printf("illegal type abstraction: cycle in \"==\" binding%s ", + tl[atnames]==NIL?"":"s"); + printelement(atnames); putchar('\n'); + sayhere(id_who(hd[x]),1); + TYPERRS++; return(1); } + return(0); +} + +txchange(ids,x) /* swap the id_type of each id with the corresponding type + in the list x */ +word ids,x; +{ while(ids!=NIL) + { word t=id_type(hd[ids]); + id_type(hd[ids])=hd[x],hd[x]=t; + ids=tl[ids],x=tl[x]; } +} + +report_type(x) +word x; +{ printf("%s",get_id(x)); + if(id_type(x)==type_t) + if(t_arity(x)>5)printf("(arity %d)",t_arity(x)); + else { word i,j; + for(i=1;i<=t_arity(x);i++) + { putchar(' '); + for(j=0;j<i;j++)putchar('*'); } + } + printf(" :: "); + out_type(id_type(x)); +} + +report_types(header,x) +char *header; +word x; +{ printf("%s",header); + while(x!=NIL) + report_type(hd[x]),putchar(';'),x=tl[x]; + putchar('\n'); +} + +typesfirst(x) /* rearrange list of ids to put types first */ +word x; +{ word *y= &x,z=NIL; + while(*y!=NIL) + if(id_type(hd[*y])==type_t) + z=cons(hd[*y],z),*y=tl[*y]; + else y= &tl[*y]; + return(shunt(z,x)); +} + +rep_t1(T,L) /* computes the representation type corresponding to T, wrt the + abstract typenames in L */ + /* will need to apply redtvars to result, see below */ + /* if no substitutions found, result is identically T */ +word T,L; +{ word args=NIL,t1,new=0; + for(t1=T;iscompound_t(t1);t1=hd[t1]) + { word a=rep_t1(tl[t1],L); + if(a!=tl[t1])new=1; + args=cons(a,args); } + if(member(L,t1))return(ap_subst(t_info(t1),args)); + /* call to redtvars removed 26/11/85 + leads to premature normalisation of subterms */ + if(!new)return(T); + while(args!=NIL) + t1=ap(t1,hd[args]),args=tl[args]; + return(t1); +} + +rep_t(T,L) /* see above */ +word T,L; +{ word t=rep_t1(T,L); + return(t==T?t:redtvars(t)); +} + +type_of(x) /* returns the type of expression x, in reduced form */ +word x; +{ word t; + TYPERRS=0; + t=redtvars(subst(etype(x,NIL,NIL))); + fixshows(); + if(TYPERRS>0)t=wrong_t; + return(t); +} + +checktype(x) /* is expression x well-typed ? */ + /* not currently used */ +word x; +{ TYPERRS=0; + etype(x,NIL,NIL); + reset_SUBST; + return(!TYPERRS); +} + +#define bound_t(t) (iscompound_t(t)&&hd[t]==bind_t) +#define tf(a,b) ap2(arrow_t,a,b) +#define tf2(a,b,c) tf(a,tf(b,c)) +#define tf3(a,b,c,d) tf(a,tf2(b,c,d)) +#define tf4(a,b,c,d,e) tf(a,tf3(b,c,d,e)) +#define lt(a) ap(list_t,a) +#define pair_t(x,y) ap2(comma_t,x,ap2(comma_t,y,void_t)) + +word tfnum,tfbool,tfbool2,tfnum2,tfstrstr,tfnumnum,ltchar, + tstep,tstepuntil; + +tsetup() +{ tfnum=tf(num_t,num_t); + tfbool=tf(bool_t,bool_t); + tfnum2=tf(num_t,tfnum); + tfbool2=tf(bool_t,tfbool); + ltchar=lt(char_t); + tfstrstr=tf(ltchar,ltchar); + tfnumnum=tf(num_t,num_t); + tstep=tf2(num_t,num_t,lt(num_t)); + tstepuntil=tf(num_t,tstep); +} + +word exec_t=0,read_t=0,filestat_t=0; /* set lazily, when used */ + +genlstat_t() /* type of %lex state */ +{ return(pair_t(num_t,num_t)); } + +genbnft() /* if %bnf used, find out input type of parsing fns */ +{ word bnftokenstate=findid("bnftokenstate"); + if(bnftokenstate!=NIL&&id_type(bnftokenstate)==type_t) + if(t_arity(bnftokenstate)==0) + bnf_t=t_class(bnftokenstate)==synonym_t? + t_info(bnftokenstate):bnftokenstate; + else printf("warning - bnftokenstate has arity>0 (ignored by parser)\n"), + bnf_t=void_t; + else bnf_t=void_t; /* now bnf_t holds the state type */ + bnf_t=ap2(comma_t,ltchar,ap2(comma_t,bnf_t,void_t)); +} /* the input type for parsers is lt(bnf_t) + note that tl[hd[tl[bnf_t]]] holds the state type */ + +extern word col_fn; + +checkcolfn() /* if offside rule used, check col_fn has right type */ +{ word t=id_type(col_fn),f=tf(tl[hd[tl[bnf_t]]],num_t); + if(t==undef_t||t==wrong_t + /* will be already reported - do not generate further typerrs + in both cases col_fn will behave as undefined name */ + ||subsumes(instantiate(t),f)) + { col_fn=0; return; } /* no further action required */ + printf("`bnftokenindentation' has wrong type for use in offside rule\n"); + printf("type required :: "); out_type(f); putchar('\n'); + printf(" actual type :: "); out_type(t); putchar('\n'); + sayhere(getspecloc(col_fn),1); + TYPERRS++; + col_fn= -1; /* error flag */ +} /* note that all parsing fns get type wrong_t if offside rule used + anywhere and col_fn has wrong type - strictly this is overkill */ + +etype(x,env,ngt) /* infer a type for an expression, by using unification */ +word x,env; /* env is list of local bindings of variables to types */ +word ngt; /* ngt is list of non-generic type variables */ +{ word a,b,c,d; /* initialise to 0 ? */ + switch(tag[x]) + { case AP: if(hd[x]==BADCASE||hd[x]==CONFERROR)return(NTV); + /* don't type check insides of error messages */ + { word ft=etype(hd[x],env,ngt),at=etype(tl[x],env,ngt),rt=NTV; + if(!unify1(ft,ap2(arrow_t,at,rt))) + { ft=subst(ft); + if(isarrow_t(ft)) + if(tag[hd[x]]==AP&&hd[hd[x]]==G_ERROR) + type_error8(at,tl[hd[ft]]); + else + type_error("unify","with",at,tl[hd[ft]]); + else type_error("apply","to",ft,at); + return(NTV); } + return(rt); } + case CONS: { word ht=etype(hd[x],env,ngt),rt=etype(tl[x],env,ngt); + if(!unify1(ap(list_t,ht),rt)) + { type_error("cons","to",ht,rt); + return(NTV); } + return(rt); } + case LEXER: { word hold=lineptr; + lineptr=hd[tl[tl[hd[x]]]]; + tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label(hereinf,-)*/ + a=etype(tl[tl[hd[x]]],env,ngt); + while((x=tl[x])!=NIL) + { lineptr=hd[tl[tl[hd[x]]]]; + tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label... */ + if(!unify1(a,b=etype(tl[tl[hd[x]]],env,ngt))) + { type_error7(a,b); + lineptr=hold; + return(NTV); } + } + lineptr=hold; + return(tf(ltchar,lt(a))); } + case TCONS: return(ap2(comma_t,etype(hd[x],env,ngt), + etype(tl[x],env,ngt))); + case PAIR: return(ap2(comma_t,etype(hd[x],env,ngt), + ap2(comma_t,etype(tl[x],env,ngt),void_t))); + case DOUBLE: + case INT: return(num_t); + case ID: a=env; + while(a!=NIL) /* take local binding, if present */ + if(hd[hd[a]]==x) + return(linst(tl[hd[a]]=subst(tl[hd[a]]),ngt)); + else a=tl[a]; + a=id_type(x); /* otherwise pick up global binding */ + if(bound_t(a))return(tl[a]); + if(a==type_t)type_error1(x); + if(a==undef_t) + { extern word commandmode; + if(commandmode)type_error2(x); + else + if(!member(ND,x)) /* report first occurrence only */ + { if(lineptr)sayhere(lineptr,0); + else if(tag[current_id]==DATAPAIR) /* see checkfbs */ + locate_inc(); + printf("undefined name \"%s\"\n",get_id(x)); + ND=add1(x,ND); } + return(NTV); } + if(a==wrong_t)return(NTV); + return(instantiate(ATNAMES?rep_t(a,ATNAMES):a)); + case LAMBDA: a=NTV; b=NTV; + d=cons(a,ngt); + c=conforms(hd[x],a,env,d); + if(c==-1||!unify(b,etype(tl[x],c,d)))return(NTV); + return(tf(a,b)); + case LET: { word e,def=hd[x]; + a=NTV,e=conforms(dlhs(def),a,env,cons(a,ngt)); + current_id=cons(dlhs(def),current_id); + c=lineptr; lineptr=dval(def); + b = unify(a,etype(dval(def),env,ngt)); + lineptr=c; + current_id=tl[current_id]; + if(e==-1||!b)return(NTV); + return(etype(tl[x],e,ngt)); } + case LETREC: { word e=env,s=NIL; + a=NIL; c=ngt; + for(d=hd[x];d!=NIL;d=tl[d]) + if(dtyp(hd[d])==undef_t) + a=cons(hd[d],a), /* unspecified defs */ + dtyp(hd[d])=(b=NTV), + c=cons(b,c), /* collect non-generic tvars */ + e=conforms(dlhs(hd[d]),b,e,c); + else dtyp(hd[d])=meta_tcheck(dtyp(hd[d])), + /* should do earlier, and locate errs properly*/ + s=cons(hd[d],s), /* specified defs */ + e=cons(cons(dlhs(hd[d]),dtyp(hd[d])),e); + if(e==-1)return(NTV); + b=1; + for(;a!=NIL;a=tl[a]) + { current_id=cons(dlhs(hd[a]),current_id); + d=lineptr; lineptr=dval(hd[a]); + b &= unify(dtyp(hd[a]),etype(dval(hd[a]),e,c)); + lineptr=d; current_id=tl[current_id]; } + for(;s!=NIL;s=tl[s]) + { current_id=cons(dlhs(hd[s]),current_id); + d=lineptr; lineptr=dval(hd[s]); + if(!subsumes(a=etype(dval(hd[s]),e,ngt), + linst(dtyp(hd[s]),ngt))) + /* would be better to set lineptr to spec here */ + b=0,type_error6(dlhs(hd[s]),dtyp(hd[s]),a); + lineptr=d; current_id=tl[current_id]; } + if(!b)return(NTV); + return(etype(tl[x],e,ngt)); } + case TRIES: { word hold=lineptr; + a=NTV; + x=tl[x]; + while(x!=NIL&&(lineptr=hd[hd[x]], + unify(a,etype(tl[hd[x]],env,ngt))) + )x=tl[x]; + lineptr=hold; + if(x!=NIL)return(NTV); + return(a); } + case LABEL: { word hold=lineptr,t; + lineptr=hd[x]; + t=etype(tl[x],env,ngt); + lineptr=hold; + return(t); } + case STARTREADVALS: if(tl[x]==0) + hd[x]=lineptr, /* insert here-info */ + tl[x]=NTV, + showchain=cons(x,showchain); + return(tf(ltchar,lt(tl[x]))); + case SHOW: hd[x]=lineptr; /* insert here-info */ + showchain=cons(x,showchain); + return(tf(tl[x]=NTV,ltchar)); + case SHARE: if(tl[x]==undef_t) + { word h=TYPERRS; + tl[x]=subst(etype(hd[x],env,ngt)); + if(TYPERRS>h)hd[x]=UNDEF,tl[x]=wrong_t; } + if(tl[x]==wrong_t) + { TYPERRS++; return(NTV); } + return(tl[x]); + case CONSTRUCTOR: a=id_type(tl[x]); + return(instantiate(ATNAMES?rep_t(a,ATNAMES):a)); + case UNICODE: return(char_t); + case ATOM: if(x<256)return(char_t); + switch(x) + { + case S:a=NTV,b=NTV,c=NTV; + d=tf3(tf2(a,b,c),tf(a,b),a,c); + return(d); + case K:a=NTV,b=NTV; + return(tf2(a,b,a)); + case Y:a=NTV; + return(tf(tf(a,a),a)); + case C:a=NTV,b=NTV,c=NTV; + return(tf3(tf2(a,b,c),b,a,c)); + case B:a=NTV,b=NTV,c=NTV; + return(tf3(tf(a,b),tf(c,a),c,b)); + case FORCE: + case G_UNIT: + case G_RULE: + case I:a=NTV; + return(tf(a,a)); + case G_ZERO:return(NTV); + case HD:a=NTV; + return(tf(lt(a),a)); + case TL:a=lt(NTV); + return(tf(a,a)); + case BODY:a=NTV,b=NTV; + return(tf(ap(a,b),a)); + case LAST:a=NTV,b=NTV; + return(tf(ap(a,b),b)); + case S_p:a=NTV,b=NTV; + c=lt(b); + return(tf3(tf(a,b),tf(a,c),a,c)); + case U: + case U_: a=NTV,b=NTV; + c=lt(a); + return(tf2(tf2(a,c,b),c,b)); + case Uf: a=NTV,b=NTV,c=NTV; + return(tf2(tf2(tf(a,b),a,c),b,c)); + case COND: a=NTV; + return(tf3(bool_t,a,a,a)); + case EQ:case GR:case GRE: + case NEQ: a=NTV; + return(tf2(a,a,bool_t)); + case NEG: return(tfnum); + case AND: + case OR: return(tfbool2); + case NOT: return(tfbool); + case MERGE: + case APPEND: a=lt(NTV); + return(tf2(a,a,a)); + case STEP: return(tstep); + case STEPUNTIL: return(tstepuntil); + case MAP: a=NTV; b=NTV; + return(tf2(tf(a,b),lt(a),lt(b))); + case FLATMAP: a=NTV,b=lt(NTV); + return(tf2(tf(a,b),lt(a),b)); + case FILTER: a=NTV; b=lt(a); + return(tf2(tf(a,bool_t),b,b)); + case ZIP: a=NTV; b=NTV; + return(tf2(lt(a),lt(b),lt(pair_t(a,b)))); + case FOLDL: a=NTV; b=NTV; + return(tf3(tf2(a,b,a),a,lt(b),a)); + case FOLDL1: a=NTV; + return(tf2(tf2(a,a,a),lt(a),a)); + case LIST_LAST: a=NTV; + return(tf(lt(a),a)); + case FOLDR: a=NTV; b=NTV; + return(tf3(tf2(a,b,b),b,lt(a),b)); + case MATCHINT: + case MATCH: a=NTV,b=NTV; + return(tf3(a,b,a,b)); + case TRY: a=NTV; + return(tf2(a,a,a)); + case DROP: + case TAKE: a=lt(NTV); + return(tf2(num_t,a,a)); + case SUBSCRIPT:a=NTV; + return(tf2(num_t,lt(a),a)); + case P: a=NTV; + b=lt(a); + return(tf2(a,b,b)); + case B_p: a=NTV,b=NTV; + c=lt(a); + return(tf3(a,tf(b,c),b,c)); + case C_p: a=NTV,b=NTV; + c=lt(b); + return(tf3(tf(a,b),c,a,c)); + case S1: a=NTV,b=NTV,c=NTV,d=NTV; + return(tf4(tf2(a,b,c),tf(d,a),tf(d,b),d,c)); + case B1: a=NTV,b=NTV,c=NTV,d=NTV; + return(tf4(tf(a,b),tf(c,a),tf(d,c),d,b)); + case C1: a=NTV,b=NTV,c=NTV,d=NTV; + return(tf4(tf2(a,b,c),tf(d,a),b,d,c)); + case SEQ: a=NTV,b=NTV; + return(tf2(a,b,b)); + case ITERATE1: + case ITERATE: a=NTV; + return(tf2(tf(a,a),a,lt(a))); + case EXEC: { if(!exec_t) + a=ap2(comma_t,ltchar,ap2(comma_t,num_t,void_t)), + exec_t=tf(ltchar,ap2(comma_t,ltchar,a)); + return(exec_t); } + case READBIN: + case READ: { if(!read_t) + read_t=tf(char_t,ltchar); + /* $- is ap(READ,0) */ + return(read_t); } + case FILESTAT: { if(!filestat_t) + filestat_t=tf(ltchar,pair_t(pair_t(num_t,num_t),num_t)); + return(filestat_t); } + case FILEMODE: + case GETENV: + case NB_STARTREAD: + case STARTREADBIN: + case STARTREAD: return(tfstrstr); + case GETARGS: return(tf(char_t,lt(ltchar))); + case SHOWHEX: + case SHOWOCT: + case SHOWNUM: return(tf(num_t,ltchar)); + case SHOWFLOAT: + case SHOWSCALED: return(tf2(num_t,num_t,ltchar)); + case NUMVAL: return(tf(ltchar,num_t)); + case INTEGER: return(tf(num_t,bool_t)); + case CODE: return(tf(char_t,num_t)); + case DECODE: return(tf(num_t,char_t)); + case LENGTH: return(tf(lt(NTV),num_t)); + case ENTIER_FN: case ARCTAN_FN: case EXP_FN: case SIN_FN: + case COS_FN: case SQRT_FN: case LOG_FN: case LOG10_FN: + return(tfnumnum); + case MINUS:case PLUS:case TIMES:case INTDIV:case FDIV: + case MOD:case POWER: return(tfnum2); + case True: case False: return(bool_t); + case NIL: a=lt(NTV); + return(a); + case NILS: return(ltchar); + case MKSTRICT: a=NTV; + return(tf(char_t,tf(a,a))); +/* the following are not the true types of the G_fns, which have the action + Ai->lt(bnf_t)->(B:lt(bnf_t)) + here represented by the type Ai->B. G_CLOSE interfaces the parser fns to + the outside world */ + case G_ALT: a=NTV; + return(tf2(a,a,a)); + case G_ERROR: a=NTV; + return(tf2(a,tf(lt(bnf_t),a),a)); + case G_OPT: + case G_STAR: a=NTV; + return(tf(a,lt(a))); + case G_FBSTAR: a=NTV; b=tf(a,a); + return(tf(b,b)); + case G_SYMB: return(tfstrstr); + case G_ANY: return(ltchar); + case G_SUCHTHAT: return(tf(tf(ltchar,bool_t),ltchar)); + case G_END: return(lt(bnf_t)); + case G_STATE: return(tl[hd[tl[bnf_t]]]); + case G_SEQ: a=NTV; b=NTV; + return(tf2(a,tf(a,b),b)); + /* G_RULE has same type as I */ + case G_CLOSE: a=NTV; + if(col_fn) /* offside rule used */ + if(col_fn== -1) /* arbitrary flag */ + TYPERRS++; /*overkill, see note on checkcolfn*/ + else checkcolfn(); + return(tf3(ltchar,a,lt(bnf_t),a)); + case OFFSIDE: return(ltchar); + /* pretend, used by indent, see prelude */ + case FAIL: /* compiled from last guard on rhs */ + case CONFERROR: + case BADCASE: + case UNDEF: return(NTV); + case ERROR: return(tf(ltchar,NTV)); + default: printf("do not know type of "); + out(stdout,x); + putchar('\n'); + return(wrong_t); + } + default: printf("unexpected tag in etype "); + out(stdout,tag[x]); + putchar('\n'); + return(wrong_t); + } +} + +rhs_here(r) +word r; +{ if(tag[r]==LABEL)return(hd[r]); + if(tag[r]==TRIES)return(hd[hd[lastlink(tl[r])]]); + return(0); /* something wrong */ +} /* efficiency hack, sometimes we set lineptr to rhs, can extract here_info + as above when needed */ + +conforms(p,t,e,ngt) /* returns new environment of local type bindings obtained + by conforming pattern p to type t; -1 means failure */ +word p,t,e,ngt; +{ if(e==-1)return(-1); + if(tag[p]==ID&&!isconstructor(p))return(cons(cons(p,t),e)); + if(hd[p]==CONST) + { unify(etype(tl[p],e,ngt),t); return(e); } + if(tag[p]==CONS) + { word at=NTV; + if(!unify(lt(at),t))return(-1); + return(conforms(tl[p],t,conforms(hd[p],at,e,ngt),ngt)); } + if(tag[p]==TCONS) + { word at=NTV,bt=NTV; + if(!unify(ap2(comma_t,at,bt),t))return(-1); + return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); } + if(tag[p]==PAIR) + { word at=NTV,bt=NTV; + if(!unify(ap2(comma_t,at,ap2(comma_t,bt,void_t)),t))return(-1); + return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); } + if(tag[p]==AP&&tag[hd[p]]==AP&&hd[hd[p]]==PLUS) /* n+k pattern */ + { if(!unify(num_t,t))return(1); + return(conforms(tl[p],num_t,e,ngt)); } +{ word p_args=NIL,pt; + while(tag[p]==AP)p_args=cons(tl[p],p_args),p=hd[p]; + if(!isconstructor(p)) + { type_error4(p); return(-1); } + if(id_type(p)==undef_t) + { type_error5(p); return(-1); } + pt= /*instantiate(id_type(p)); */ + instantiate(ATNAMES?rep_t(id_type(p),ATNAMES):id_type(p)); + while(p_args!=NIL&&isarrow_t(pt)) + { e=conforms(hd[p_args],tl[hd[pt]],e,ngt),pt=tl[pt],p_args=tl[p_args]; + if(e==-1)return(-1); } + if(p_args!=NIL||isarrow_t(pt)){ type_error3(p); return(-1); } + if(!unify(pt,t))return(-1); + return(e); +}} + +locate(s) /* for locating type errors */ +char *s; +{ TYPERRS++; + if(TYPERRS==1||lastloc!=current_id) /* avoid tedious repetition */ + if(current_id) + if(tag[current_id]==DATAPAIR) /* see checkfbs */ + { locate_inc(); + printf("%s in binding for %s\n",s,(char *)hd[current_id]); + return; } + else + { extern word fnts; + word x=current_id; + printf("%s in definition of ",s); + while(tag[x]==CONS) + if(tag[tl[x]]==ID&&member(fnts,tl[x])) + printf("nonterminal "),x=hd[x]; else /*note1*/ + out_formal1(stdout,hd[x]),printf(", subdef of "), + x=tl[x]; + printf("%s",get_id(x)); + putchar('\n'); } + else printf("%s in expression\n",s); + if(lineptr)sayhere(lineptr,0); else + if(current_id&&id_who(current_id)!=NIL)sayhere(id_who(current_id),0); + lastloc=current_id; +} +/* note1: this is hack to suppress extra `subdef of <fst start symb>' when + reporting error in defn of non-terminal in %bnf stuff */ + +sayhere(h,nl) /* h is hereinfo - reports location (in parens, newline if nl) + and sets errline/errs if not already set */ +word h,nl; +{ extern word errs,errline; + extern char *current_script; + if(tag[h]!=FILEINFO) + { h=rhs_here(h); + if(tag[h]!=FILEINFO) + { fprintf(stderr,"(impossible event in sayhere)\n"); return; }} + printf("(line %3d of %s\"%s\")",tl[h], + (char *)hd[h]==current_script?"":"%insert file ",(char *)hd[h]); + if(nl)putchar('\n'); else putchar(' '); + if((char *)hd[h]==current_script) + { if(!errline) /* tells editor where first error is */ + errline=tl[h]; } + else { if(!errs)errs=h; } +} + +type_error(a,b,t1,t2) +char *a,*b; +word t1,t2; +{ t1=redtvars(ap(subst(t1),subst(t2))); + t2=tl[t1];t1=hd[t1]; + locate("type error"); + printf("cannot %s ",a);out_type(t1); + printf(" %s ",b);out_type(t2);putchar('\n'); +} + +type_error1(x) /* typename in expression */ +word x; +{ locate("type error"); + printf("typename used as identifier (%s)\n",get_id(x)); +} + +type_error2(x) /* undefined name in expression */ +word x; +{ if(compiling)return; /* treat as type error only in $+ data */ + TYPERRS++; + printf("undefined name - %s\n",get_id(x)); +} + +type_error3(x) /* constructor used at wrong arity in formal */ +word x; +{ locate("error"); + printf("constructor \"%s\" used at wrong arity in formal\n", get_id(x)); +} + +type_error4(x) /* non-constructor as head of formal */ +word x; +{ locate("error"); + printf("illegal object \""); out_pattern(stdout,x); + printf("\" as head of formal\n"); +} + +type_error5(x) /* undeclared constructor in formal */ +word x; +{ locate("error"); + printf("undeclared constructor \""); out_pattern(stdout,x); + printf("\" in formal\n"); + ND=add1(x,ND); +} + +type_error6(x,f,a) +word x,f,a; +{ TYPERRS++; + printf("incorrect declaration "); sayhere(lineptr,1); + printf("specified, %s :: ",get_id(x)); out_type(f); putchar('\n'); + printf("inferred, %s :: ",get_id(x)); out_type(redtvars(subst(a))); + putchar('\n'); +} + +type_error7(t,args) +word t,args; +{ word i=1; + while((args=tl[args])!=NIL)i++; + locate("type error"); + printf(i==1?"1st":i==2?"2nd":i==3?"3rd":"%dth",i); + printf(" arg of zip has type :: "); + out_type(redtvars(subst(t))); + printf("\n - should be list\n"); +} + +type_error8(t1,t2) +word t1,t2; +{ word big; + t1=subst(t1); t2=subst(t2); + if(same(hd[t1],hd[t2])) + t1=tl[t1],t2=tl[t2]; /* discard `[bnf_t]->' */ + t1=redtvars(ap(t1,t2)); + t2=tl[t1];t1=hd[t1]; + big = size(t1)>=10 || size(t2)>=10; + locate("type error"); + printf("cannot unify%s ",big?"\n ":"");out_type(t1); + printf(big?"\nwith\n ":" with ");out_type(t2);putchar('\n'); +} + +unify(t1,t2) /* works by side-effecting SUBST, returns 1,0 as it succeeds + or fails */ +word t1,t2; +{ t1=subst(t1),t2=subst(t2); + if(t1==t2)return(1); + if(isvar_t(t1)&&!occurs(t1,t2)) + { addsubst(t1,t2); return(1); } + if(isvar_t(t2)&&!occurs(t2,t1)) + { addsubst(t2,t1); return(1); } + if(iscompound_t(t1)&&iscompound_t(t2)&& + unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2]))return(1); + type_error("unify","with",t1,t2); + return(0); +} + +unify1(t1,t2) /* inner call - exactly like unify, except error reporting is + done only by top level, see above */ + /* we do this to avoid printing inner parts of types */ +word t1,t2; +{ t1=subst(t1),t2=subst(t2); + if(t1==t2)return(1); + if(isvar_t(t1)&&!occurs(t1,t2)) + { addsubst(t1,t2); return(1); } + if(isvar_t(t2)&&!occurs(t2,t1)) + { addsubst(t2,t1); return(1); } + if(iscompound_t(t1)&&iscompound_t(t2)) + return(unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2])); + return(0); +} + +subsumes(t1,t2) /* like unify but lop-sided; returns 1,0 as t2 falls, doesnt + fall under t1 */ +word t1,t2; +{ if(t2==wrong_t)return(1); + /* special case, shows up only when compiling prelude (changetype etc) */ + return(subsu1(t1,t2,t2)); } + +subsu1(t1,t2,T2) +word t1,t2,T2; +{ t1=subst(t1); + if(t1==t2)return(1); + if(isvar_t(t1)&&!occurs(t1,T2)) + { addsubst(t1,t2); return(1); } + if(iscompound_t(t1)&&iscompound_t(t2)) + return(subsu1(hd[t1],hd[t2],T2)&&subsu1(tl[t1],tl[t2],T2)); + return(0); +} + +walktype(t,f) /* make a copy of t with f applied to its variables */ +word t; +word (*f)(); +{ if(isvar_t(t))return((*f)(t)); + if(iscompound_t(t)) + { word h1=walktype(hd[t],f); + word t1=walktype(tl[t],f); + return(h1==hd[t]&&t1==tl[t]?t:ap(h1,t1)); } + return(t); +} + +occurs(tv,t) /* does tv occur in type t? */ +word tv,t; +{ while(iscompound_t(t)) + { if(occurs(tv,tl[t]))return(1); + t=hd[t]; } + return(tv==t); +} + +ispoly(t) /* does t contain tvars? (should call subst first) */ +word t; +{ while(iscompound_t(t)) + { if(ispoly(tl[t]))return(1); + t=hd[t]; } + return(isvar_t(t)); +} + +word SUBST[hashsize]; /* hash table of substitutions */ + +clear_SUBST() +/* To save time and space we call this after a type inference to clear out + substitutions in extinct variables. Calling this too often can slow you + down - whence #define reset_SUBST, see above */ +{ word i; + fixshows(); + for(i=0;i<hashsize;i++)SUBST[i]=0; + /*printf("tvcount=%d\n",tvcount); /* probe */ + tvcount=1; + return(0); /* see defn of reset_SUBST */ +} +/* doubling hashsize from 512 to 1024 speeded typecheck by only 3% on + parser.m (=350 line block, used c. 5000 tvars) - may be worth increasing + for very large programs however. Guesstimate - further increase from + 512 would be worthwhile on blocks>2000 lines */ + +fixshows() +{ while(showchain!=NIL) + { tl[hd[showchain]]=subst(tl[hd[showchain]]); + showchain=tl[showchain]; } +} + +lookup(tv) /* find current substitution for type variable */ +word tv; +{ word h=SUBST[hashval(tv)]; + while(h) + { if(eqtvar(hd[hd[h]],tv))return(tl[hd[h]]); + h=tl[h]; } + return(tv); /* no substitution found, so answer is self */ +} + +addsubst(tv,t) /* add new substitution to SUBST */ +word tv,t; +{ word h=hashval(tv); + SUBST[h]=cons(cons(tv,t),SUBST[h]); +} + +ult(tv) /* fully substituted out value of a type var */ +word tv; +{ word s=lookup(tv); + return(s==tv?tv:subst(s)); +} + +subst(t) /* returns fully substituted out value of type expression */ +word t; +{ return(walktype(t,ult)); +} + +word localtvmap=NIL; +word NGT=0; + +lmap(tv) +word tv; +{ word l; + if(non_generic(tv))return(tv); + for(l=localtvmap;l!=NIL;l=tl[l]) + if(hd[hd[l]]==tv)return(tl[hd[l]]); + localtvmap=cons(cons(tv,l=NTV),localtvmap); + return(l); +} + +linst(t,ngt) /* local instantiate */ +word t; /* relevant tvars are those not in ngt */ +{ localtvmap=NIL; NGT=ngt; + return(walktype(t,lmap)); +} + +non_generic(tv) +word tv; +{ word x; + for(x=NGT;x!=NIL;x=tl[x]) + if(occurs(tv,subst(hd[x])))return(1); + return(0); +} /* note that when a non-generic tvar is unified against a texp, all tvars + in texp become non-generic; this is catered for by call to subst above + (obviating the need for unify to directly side-effect NGT) */ + +word tvmap=NIL; + +mapup(tv) +word tv; +{ word *m= &tvmap; + tv=gettvar(tv); + while(--tv)m= &tl[*m]; + if(*m==NIL)*m=cons(NTV,NIL); + return(hd[*m]); +} + +instantiate(t) /* make a copy of t with a new set of type variables */ +word t; /* t MUST be in reduced form - see redtvars */ +{ tvmap=NIL; + return(walktype(t,mapup)); +} + +ap_subst(t,args) /* similar, but with a list of substitions for the type + variables provided (args). Again, t must be in reduced form */ +word t,args; +{ word r; + tvmap=args; + r=walktype(t,mapup); + tvmap=NIL; /* ready for next use */ + return(r); +} + + +mapdown(tv) +word tv; +{ word *m= &tvmap; + word i=1; + while(*m!=NIL&&!eqtvar(hd[*m],tv))m= &tl[*m],i++; + if(*m==NIL)*m=cons(tv,NIL); + return(mktvar(i)); +} + +redtvars(t) /* renames the variables in t, in order of appearance to walktype, + using the numbers 1,2,3... */ +word t; +{ tvmap=NIL; + return(walktype(t,mapdown)); +} + + +remove1(e,ss) /* destructively remove e from set with address ss, returning + 1 if e was present, 0 otherwise */ +word e,*ss; +{ while(*ss!=NIL&&hd[*ss]<e)ss= &tl[*ss]; /* we assume set in address order */ + if(*ss==NIL||hd[*ss]!=e)return(0); + *ss=tl[*ss]; + return(1); +} + +setdiff(s1,s2) /* destructive on s1, returns set difference */ +word s1,s2; /* both are in ascending address order */ +{ word *ss1= &s1; + while(*ss1!=NIL&&s2!=NIL) + if(hd[*ss1]==hd[s2])*ss1=tl[*ss1]; else /* removes element */ + if(hd[*ss1]<hd[s2])ss1= &tl[*ss1]; + else s2=tl[s2]; + return(s1); +} + +add1(e,s) /* inserts e destructively into set s, kept in ascending address + order */ +word e,s; +{ word s1=s; + if(s==NIL||e<hd[s])return(cons(e,s)); + if(e==hd[s])return(s); /* no duplicates! */ + while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1]; + if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else + if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]); + return(s); +} + +word NEW; /* nasty hack, see rules */ + +newadd1(e,s) /* as above, but with side-effect on NEW */ +word e,s; +{ word s1=s; + NEW=1; + if(s==NIL||e<hd[s])return(cons(e,s)); + if(e==hd[s]){ NEW=0; return(s); } /* no duplicates! */ + while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1]; + if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else + if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]); + else NEW=0; + return(s); +} + +UNION(s1,s2) /* destructive on s1; s1, s2 both in address order */ +word s1,s2; +{ word *ss= &s1; + while(*ss!=NIL&&s2!=NIL) + if(hd[*ss]==hd[s2])ss= &tl[*ss],s2=tl[s2]; else + if(hd[*ss]<hd[s2])ss= &tl[*ss]; + else *ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2]; + if(*ss==NIL) + while(s2!=NIL)*ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2]; + /* must copy tail of s2, in case of later destructive operations on s1 */ + return(s1); +} + +intersection(s1,s2) /* s1, s2 and result all in address order */ +word s1,s2; +{ word r=NIL; + while(s1!=NIL&&s2!=NIL) + if(hd[s1]==hd[s2])r=cons(hd[s1],r),s1=tl[s1],s2=tl[s2]; else + if(hd[s1]<hd[s2])s1=tl[s1]; + else s2=tl[s2]; + return(reverse(r)); +} + +deps(x) /* returns list of the free identifiers in expression x */ +word x; +{ word d=NIL; +L:switch(tag[x]) +{ case AP: + case TCONS: + case PAIR: + case CONS: d=UNION(d,deps(hd[x])); + x=tl[x]; + goto L; + case ID: return(isconstructor(x)?d:add1(x,d)); + case LAMBDA: /* d=UNION(d,patdeps(hd[x])); + /* should add this - see sahbug3.m */ + return(rembvars(UNION(d,deps(tl[x])),hd[x])); + case LET: d=rembvars(UNION(d,deps(tl[x])),dlhs(hd[x])); + return(UNION(d,deps(dval(hd[x])))); + case LETREC: { word y; + d=UNION(d,deps(tl[x])); + for(y=hd[x];y!=NIL;y=tl[y]) + d=UNION(d,deps(dval(hd[y]))); + for(y=hd[x];y!=NIL;y=tl[y]) + d=rembvars(d,dlhs(hd[y])); + return(d); } + case LEXER: while(x!=NIL) + d=UNION(d,deps(tl[tl[hd[x]]])), + x=tl[x]; + return(d); + case TRIES: + case LABEL: x=tl[x]; goto L; + case SHARE: x=hd[x]; goto L; /* repeated analysis - fix later */ + default: return(d); +}} + +rembvars(x,p) /* x is list of ids in address order, remove bv's of pattern p + (destructive on x) */ +word x,p; +{ L: + switch(tag[p]) + { case ID: return(remove1(p,&x),x); + case CONS: if(hd[p]==CONST)return(x); + x=rembvars(x,hd[p]);p=tl[p];goto L; + case AP: if(tag[hd[p]]==AP&&hd[hd[p]]==PLUS) + p=tl[p]; /* for n+k patterns */ + else { x=rembvars(x,hd[p]);p=tl[p]; } + goto L; + case PAIR: + case TCONS: x=rembvars(x,hd[p]);p=tl[p];goto L; + default: fprintf(stderr, "impossible event in rembvars\n"); + return(x); +}} + +member(s,x) +word s,x; +{ while(s!=NIL&&x!=hd[s])s=tl[s]; + return(s!=NIL); +} + +printgraph(title,g) /* for debugging info */ +char *title; +word g; +{ printf("%s\n",title); + while(g!=NIL) + { printelement(hd[hd[g]]); putchar(':'); + printelement(tl[hd[g]]); printf(";\n"); + g=tl[g]; } +} + +printelement(x) +word x; +{ if(tag[x]!=CONS){ out(stdout,x); return; } + putchar('('); + while(x!=NIL) + { out(stdout,hd[x]); + x=tl[x]; + if(x!=NIL)putchar(' '); } + putchar(')'); +} + +printlist(title,l) /* for debugging */ +char *title; +word l; +{ printf("%s",title); + while(l!=NIL) + { printelement(hd[l]); + l=tl[l]; + if(l!=NIL)putchar(','); } + printf(";\n"); +} + +printob(title,x) /* for debugging */ +char *title; +word x; +{ printf("%s",title); out(stdout,x); putchar('\n'); + return(x); } + +print2obs(title,title2,x,y) /* for debugging */ +char *title,*title2; +word x,y; +{ printf("%s",title); out(stdout,x); printf("%s",title2); out(stdout,y); putchar('\n'); +} + +word allchars=0; /* flag used by tail */ + +out_formal1(f,x) +FILE *f; +word x; +{ extern word nill; + if(hd[x]==CONST)x=tl[x]; + if(x==NIL)fprintf(f,"[]"); else + if(tag[x]==CONS&&tail(x)==NIL) + if(allchars) + { fprintf(f,"\"");while(x!=NIL)fprintf(f,"%s",charname(hd[x])),x=tl[x]; + fprintf(f,"\""); } else + { fprintf(f,"["); + while(x!=nill&&x!=NIL) + { out_pattern(f,hd[x]); + x=tl[x]; + if(x!=nill&&x!=NIL)fprintf(f,","); } + fprintf(f,"]"); } else + if(tag[x]==AP||tag[x]==CONS) + { fprintf(f,"("); out_pattern(f,x); + fprintf(f,")"); } else + if(tag[x]==TCONS||tag[x]==PAIR) + { fprintf(f,"("); + while(tag[x]==TCONS) + { out_pattern(f,hd[x]); + x=tl[x]; fprintf(f,","); } + out_pattern(f,hd[x]); fprintf(f,","); out_pattern(f,tl[x]); + fprintf(f,")"); } else + if(tag[x]==INT&&neg(x)||tag[x]==DOUBLE&&get_dbl(x)<0) + { fprintf(f,"("); out(f,x); fprintf(f,")"); } /* -ve numbers */ + else + out(f,x); /* all other cases */ +} + +out_pattern(f,x) +FILE *f; +word x; +{ if(tag[x]==CONS) + if(hd[x]==CONST&&(tag[tl[x]]==INT||tag[tl[x]]==DOUBLE))out(f,tl[x]); else + if(hd[x]!=CONST&&tail(x)!=NIL) + { out_formal(f,hd[x]); fprintf(f,":"); out_pattern(f,tl[x]); } + else out_formal(f,x); + else out_formal(f,x); +} + +out_formal(f,x) +FILE *f; +word x; +{ if(tag[x]!=AP) + out_formal1(f,x); else + if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ + { out_formal(f,tl[x]); fprintf(f,"+"); out(f,tl[hd[x]]); } + else + { out_formal(f,hd[x]); fprintf(f," "); out_formal1(f,tl[x]); } +} + +tail(x) +word x; +{ allchars=1; + while(tag[x]==CONS)allchars&=(is_char(hd[x])),x=tl[x]; + return(x); +} + +out_type(t) /* for printing external representation of types */ +word t; +{ while(isarrow_t(t)) + { out_type1(tl[hd[t]]); + printf("->"); + t=tl[t]; } + out_type1(t); +} + +out_type1(t) +word t; +{ if(iscompound_t(t)&&!iscomma_t(t)&&!islist_t(t)&&!isarrow_t(t)) + { out_type1(hd[t]); + putchar(' '); + t=tl[t]; } + out_type2(t); +} + +out_type2(t) +word t; +{ if(islist_t(t)) + { putchar('['); + out_type(tl[t]); /* could be out_typel, but absence of parentheses + might be confusing */ + putchar(']'); }else + if(iscompound_t(t)) + { putchar('('); + out_typel(t); + if(iscomma_t(t)&&tl[t]==void_t)putchar(','); + /* type of a one-tuple -- an anomaly that should never occur */ + putchar(')'); }else + switch(t) + { + case bool_t: printf("bool"); return; + case num_t: printf("num"); return; + case char_t: printf("char"); return; + case wrong_t: printf("WRONG"); return; + case undef_t: printf("UNKNOWN"); return; + case void_t: printf("()"); return; + case type_t: printf("type"); return; + default: if(tag[t]==ID)printf("%s",get_id(t));else + if(isvar_t(t)) + { word n=gettvar(t); + /*if(1)printf("t%d",n-1); else /* experiment, suppressed */ + /*if(n<=26)putchar('a'+n-1); else /* experiment */ + if(n>0&&n<7)while(n--)putchar('*'); /* 6 stars max */ + else printf("%d",n); }else + if(tag[t]==STRCONS) /* pname - see hack in privatise */ + { extern char *current_script; + if(tag[pn_val(t)]==ID)printf("%s",get_id(pn_val(t))); else + /* ?? one level of indirection sometimes present */ + if(strcmp((char *)hd[tl[t_info(t)]],current_script)==0) + printf("%s",(char *)hd[hd[t_info(t)]]); else /* elision */ + printf("`%s@%s'", + (char *)hd[hd[t_info(t)]], /* original typename */ + (char *)hd[tl[t_info(t)]]); /* sourcefile */ } + else printf("<BADLY FORMED TYPE:%d,%d,%d>",tag[t],hd[t],tl[t]); + } +} + +out_typel(t) +word t; +{ while(iscomma_t(t)) + { out_type(tl[hd[t]]); + t=tl[t]; + if(iscomma_t(t))putchar(','); + else if(t!=void_t)printf("<>"); } /* "tuple-cons", shouldn't occur free */ + if(t==void_t)return; + out_type(t); +} + +/* end of MIRANDA TYPECHECKER */ + @@ -0,0 +1,7 @@ +chmod -R a-w miralib +cd miralib +chmod a+w ex/*.x preludx stdenv.x +chmod u+w . ex local + +#makes miralib files read-only except for .x files +#to prevent users accidentally changing stdenv.m or manual pages diff --git a/quotehostinfo b/quotehostinfo new file mode 100755 index 0000000..cd060ec --- /dev/null +++ b/quotehostinfo @@ -0,0 +1,7 @@ +#!/bin/bash +fil=/tmp/quotehostinfo$$ +echo compiled: `date` > $fil +make -s tellcc >> $fil +cat .host >> $fil +echo \"`cat $fil | sed 's/.*/&\\\\n/'`\" | sed 's/\\n /\\n/g' +rm $fil diff --git a/reduce.c b/reduce.c new file mode 100644 index 0000000..24c3241 --- /dev/null +++ b/reduce.c @@ -0,0 +1,2394 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#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 int 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 */ + +static void apfile(word); +static void closefile(word); +static void div_error(void); +static void fn_error(char *); +static void getenv_error(char *); +static word g_residue(word); +static void lexfail(word); +static word lexstate(word); +static int memclass(int,word); +static word numplus(word,word); +static void outf(word); +static word piperrmess(word); +static void print(word); +static word reduce(word); +static void stdin_error(int); +static void subs_error(void); +static void int_error(char *); + +#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 */ + +int 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); +} + +void 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; +} + +word 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 */ + +/* ### */ +void output(e) /* "output" is called by YACC (see rules.y) 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 int_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); +} + +/* ### */ +void 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 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 */ + +/* ### */ +void 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; +} + +void 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 */ +} + +void 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 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 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 */ +word reduce(e) +word e; +{ word 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_int(n)); } + goto DONE; + + case DROP: + getarg(arg1); + upleft; + arg1=tl[hd[e]]=reduce(tl[hd[e]]); /* ### */ + if(tag[arg1]!=INT)int_error("drop"); + { long long n=get_int(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; + if(tag[arg1]==ATOM)indx=arg1;/* small indexes represented directly */ + else if(tag[arg1]==INT)indx=get_int(arg1); + else int_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; + { 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(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 { int 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)int_error("take"); + { long long n=get_int(arg1); + if(n<=0||(lastarg=reduce(lastarg))==NIL) /* ### */ + { simpl(NIL); goto DONE; } + setcell(CONS,hd[lastarg],ap2(TAKE,sto_int(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_int(buf.st_ino), + sto_int(buf.st_dev) ), + sto_int(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; + { int 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_int(-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)int_error("decode"); + long long val=get_int(lastarg); + if(val<0||val>UMAX) + { fprintf(stderr,"\nCHARACTER OUT-OF-RANGE decode(%lld)\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)int_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)int_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 word 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)int_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) + int_error("showscaled"); + arg1=getsmallint(arg1); + (void)sprintf(linebuf,"%.*e",(int)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) + int_error("showfloat"); + arg1=getsmallint(arg1); + (void)sprintf(linebuf,"%.*f",(int)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 */ + +int memclass(c,x) /* is char c in list x (may include ranges) */ +int c; word x; +{ 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); +} + +void lexfail(x) /* x is known to be a non-empty string (see LEX_RPT) */ +word x; +{ int 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); +} + +word lexstate(x) /* extracts initial state info from list of chars labelled + by LEX_COUNT - x is evaluated and known to be non-empty */ +word x; +{ x = hd[hd[x]]; /* count field of first char */ + return(cons(sto_int(x>>8),stosmallint(x&255))); +} + +word piperrmess(pid) +word pid; +{ return(str_conv(pid== -1?"cannot create process\n":"cannot open pipe\n")); +} + +word 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)); +} + +word 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)); +} + +void fn_error(s) +char *s; +{ fprintf(stderr,"\nprogram error: %s\n",s); + outstats(); + exit(1); } + +void getenv_error(char *a) +{ fprintf(stderr, + "program error: getenv(%s): illegal characters in result string\n",a); + outstats(); + exit(1); } + +void subs_error() +{ fn_error("subscript out of range"); +} + +void div_error() +{ fn_error("attempt to divide by zero"); +} +/* other arithmetic exceptions signal-trapped by fpe_error - see STEER */ + +void math_error(s) +char *s; +{ fprintf(stderr,"\nmath function %serror (%s)\n", + errno==EDOM?"domain ":errno==ERANGE?"range ":"",s); + outstats(); + exit(1); +} + +void int_error(s) +char *s; +{ fprintf(stderr, + "\nprogram error: fractional number where integer expected (%s)\n",s); + outstats(); + exit(1); +} + +char *stdname(c) +int c; +{ return c==':' ? "$:-" : c=='-' ? "$-" : "$+"; } + +void stdin_error(c) +int 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 + +void initclock() +{ +#ifndef BSDCLOCK +start=clock(); +#endif +} + +void 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 %3ld 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 */ + +void outstats() +{ extern long claims,nogcs; + extern int atcount; + extern long long cellcount; +#ifdef BSDCLOCK + struct tms buffer; +#endif +#ifdef HISTO + 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 */ + @@ -0,0 +1,4 @@ +ls -t `make -s sources` | ./fdate + +#output the date of most recently revised source file +#e.g 9 July 2004 @@ -0,0 +1,1689 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +/* 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 "big.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; +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; +{ 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); +} + +int eprod(word); + +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 ? */ +word x; +{ 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&&t!=wrong_t&&fil!=NULL&&(!ef||efil)) + { int 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_int($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 */ + @@ -0,0 +1 @@ +big.c big.h data.h data.c lex.c reduce.c rules.y steer.c trans.c types.c @@ -0,0 +1,2241 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +/* this stuff is to get the time-last-modified of files */ +#include <sys/types.h> +#include <sys/stat.h> +#include <fcntl.h> /* creat() */ +/* #include <sys/wait.h> /* seems not needed, oct 05 */ +struct stat buf; /* see man(2) stat - gets file status */ + +#include "data.h" +#include "big.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 2500000l +#define DFLTDICSPACE 100000l +/* 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; +int UTF8=0, UTF8OUT=0; +extern char *vdate, *host; +extern word version, ND; +extern word *dstack,*stackp; + +static void allnamescom(void); +static void announce(void); +static int badeditor(void); +static int checkversion(char*); +static void command(void); +static void commandloop(char*); +static void diagnose(char*); +static void editfile(char*,int); +static void ed_warn(void); +static void filecopy(char*); +static void filecp(char*,char*); +static void finger(char*); +static void fixeditor(void); +static void fixexports(void); +static int getln(FILE*,word,char*); +static word isfreeid(word); +static void libfails(void); +static void loadfile(char*); +static void makedump(void); +static void manaction(void); +static void mira_setup(void); +static void missparam(char*); +static char *mkabsolute(char*); +static word mkincludes(word); +static word mktiny(void); +static void namescom(word); +static void primlib(void); +static word privatise(word); +static void privlib(void); +static word publicise(word); +static word rc_read(char*); +static void rc_write(void); +static int src_update(void); +static void stdlib(void); +static char *strvers(int); +static int twidth(void); +static void undump(char*); +static int utf8test(void); +static void unfixexports(void); +static void unlinkx(char*); +static void unload(void); +static void v_info(int); +static void xschars(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 */ +int 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 */ +int 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 */ +int 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 + +int main(argc,argv) /* system initialisation, followed by call to YACC */ +int argc; +char *argv[]; +{ word manonly=0; + char *home, *prs; + int okhome_rc; /* flags valid HOME/.mirarc file present */ + char *argv0=argv[0]; + char *initscript; + int badlib=0; + extern int 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],"%ld",&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],"%ld",&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",(int)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 */ +} + +int vstack[4]; /* record of miralib versions looked at */ +char *mstack[4]; /* and where found */ +int mvp=0; + +int checkversion(m) +/* returns 1 iff m is directory with .version containing our version number */ +char *m; +{ int 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; +} + +void 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) +int 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); +} + +void missparam(s) +char *s; +{ fprintf(stderr,"mira: missing param after flag \"-%s\"\n",s); + exit(1); } + +int oldversion=0; +#define colmax 400 +#define spaces(s) for(j=s;j>0;j--)putchar(' ') + +void 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-2020\n\n"); + spaces(w); printf(" World Wide Web: http://miranda.org.uk\n\n\n"); + if(SPACELIMIT!=DFLTSPACE) + printf("(%ld cells)\n",SPACELIMIT); + if(!strictif)printf("(-nostrictif : deprecated!)\n"); +/*printf("\t\t\t\t%dbit platform\n",__WORDSIZE); /* temporary */ + 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); +} + + +word 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,"%ld%ld%ld%*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%ld%ld%ld%ld",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%ld%ld%ld",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); +} + +void 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(); +} + +int 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); +} + +int 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); +} + +void 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," %ld %ld %ld %s\n",SPACELIMIT,DICSPACE,version,editor); + fclose(out); +} + +word lastid=0; /* first inscope identifier of immediately preceding command */ +word rv_expr=0; + +void commandloop(initscript) +char* initscript; +{ int ch; + void reset(); + extern word cook_stdin; + extern void obey(word); + 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(); + 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; +}}} + +word 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); } +}} + +void 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); +} + +word 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 */ +} /* we assume time_t can be stored in a word */ + +#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 */ +int 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); +} + +int loading; +char *unlinkme; /* if set, is name of partially created obfile */ + +void reset() /* interrupt catcher - see call to signal in commandloop */ +{ extern word lineptr,ATNAMES,current_id; + extern int blankerr,collecting; + /*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; + +int lose; + +int normal(f) /* s has ".m" suffix */ +char *f; +{ int n=strlen(f); + return n>=2&&strcmp(f+n-2,".m")==0; +} + +void v_info(int full) +{ printf("%s last revised %s\n",strvers(version),vdate); + if(!full)return; + printf("%s",host); + printf("XVERSION %u\n",XVERSION); +} + +void command() +{ char *t; + int 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("%ld chars",DICSPACE); + if(DICSPACE!=DFLTDICSPACE) + printf(" (default=%ld)",DFLTDICSPACE); + printf(" %ld in use\n",(long)(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,%ld,%ld)",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("%ld cells",SPACELIMIT); + if(SPACELIMIT!=DFLTSPACE) + printf(" (default=%ld)",DFLTSPACE); + printf("\n"); + return; } + checkeol; + if(sscanf(dicp,"%ld",&x)!=1||badval(x)) + { printf("illegal value (heap unchanged)\n"); return; } + if(x<trueheapsize()) + printf("sorry, cannot shrink heap to %ld at this time\n",x); + else { if(x!=SPACELIMIT) + SPACELIMIT=x,resetheap(); + printf("heaplimit = %ld 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 word 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 %ld\n",SPACELIMIT); + printf("*\tdic %ld\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",(int)c,dicp); + printf("type /h for help\n"); + while((ch=getchar())!='\n'&&ch!=EOF); + return; + } /* end of switch statement */ + xschars(); +} + +void 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 */ + +void editfile(t,line) +char *t; +int line; +{ char *ebuf=linebuf; + char *p=ebuf,*q=editor; + int 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; +} + +void xschars() +{ word ch; + printf("\7extra characters at end of command\n"); + while((ch=getchar())!='\n'&&ch!=EOF); +} + +word 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); +} + +word 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}; +int presym_n[] = + { 21, 8, 15, 8, 15, 31, 23, 22, 15, + 21 }; + +#include <ctype.h> + +void filequote(p) /* write p to stdout with <quotes> if appropriate */ +char *p; /* p is a pathname */ +{ static int 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 */ + +void finger(n) /* find info about name stored at dicp */ +char *n; +{ word x; int 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); +} + +void diagnose(n) +char *n; +{ int 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); +} + +int sorted=0; /* flag to avoid repeatedly sorting fil_defs */ +int leftist; /* flag to alternate bias of padding in justification */ +int words[colmax]; /* max plausible size of screen */ + +void allnamescom() +{ word s; + word x=ND; + word y=x,z=0; + leftist=0; + namescom(make_fil(nostdenv?0:(word)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 */ + +void 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 */ + +void loadfile(t) +char *t; +{ extern word fileq; + extern word current_id,includees,embargoes,exportfiles,freeids,exports; + extern word fnts,FBS,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) + { 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 int lfrule; + /* 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; +} + +word isfreeid(x) +word 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)] + +void fixexports() +{ extern word 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() */ + +void 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() */ + +word 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 */ + +word 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); +} + +int sigflag=0; + +void sigdefer() +{ /* printf("sigdefer()\n"); /* DEBUG */ + sigflag=1; } /* delayed signal handler, installed during load_script() */ + +word 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 */ + int 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; + (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 %ld, actual has arity %ld)\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 */ + +void 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]])); } +} + +word 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 */ +word 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)); +} + +word 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)); +} + +void 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 ? */ +} + +void 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])); +} + +void yyerror(s) /* called by YACC in the event of a syntax error */ +char *s; +{ extern int 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(); +} + +void 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(); +} + +void acterror() /* likewise, but assumes error message output by caller */ +{ if(SYNERR)return; + SYNERR=1; /* to stop YACC at next symbol */ + reset_lex(); +} + +void 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.y */ + +void dieclean() /* called if evaluation is interrupted - see rules.y */ +{ 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 rules.y) */ +word process() +{ int pid; + sighandler oldsig; + oldsig = signal(SIGINT,SIG_IGN); + /* do not let parent receive interrupts intended for child */ + if(pid=fork()) + { /* parent */ + int 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.y) 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() */ + +void 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; } + +void 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; +} + +void 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 */ +} + +void 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); +} + +void 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); + 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 */ +} + +word mktiny() +{ volatile + double x=1.0,x1=x/2.0; + while(x1>0.0)x=x1,x1/=2.0; + return(sto_dbl(x)); +} + +word 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); } + +void 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); +} + +void 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) + { unlink(obf); unload(); CLASHES=NIL; stackp=dstack; + printf("warning: %s contains incorrect data (file removed)\n",obf); + if(BAD_DUMP== -1)printf("(unrecognised dump format)\n"); else + if(BAD_DUMP==1)printf("(wrong source file)\n"); else + printf("(error %ld)\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; +} + +void 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]; + +void 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); +} + +void 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> + +int 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> + +int utf8test() +{ return GetACP()==65001; } +/* codepage 1252 is Windows version of Latin-1; 65001 is UTF-8 */ + +#else + +int 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 */ + @@ -0,0 +1,9 @@ +tok ::= ID [char] posn | CHAR char posn +posn == (num,num) + +analyse = +%lex +letter = `a-z\xfff\&A-Z-` +letter+ -> ID $$ $# +. -> CHAR (hd $$) $# +%% @@ -0,0 +1,1000 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +#include "lex.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 */ +static word abshfnck(word,word); +static word abstr(word,word); +static word combine(word,word); +static void decl1(word,word); +static word fixrepeats(word); +static word getrel(word,word); +static word here_inf(word); +static word imageless(word,word,word); +static word invgetrel(word,word); +static word leftfactor(word); +static word less(word,word); +static word less1(word,word); +static word liscomb(word,word); +static word makeshow(word,word); +static word mklazy(word); +static word mkshowt(word,word); +static word mktuple(word); +static void nameclash(word); +static int nclchk(word,word,word); +static word new_mklazy(word); +static word primconstr(word); +static void respec_error(word); +static word scanpattern(word,word,word,word); +static word sort(word); +static word translet(word,word); +static word transletrec(word,word); +static word transtries(word,word); +static word transzf(word,word,word); + +word 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); +} + +word 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 */ +} + +word memb(l,x) /* tests if x is a member of list "l" - used in testing for + repeated names - see rule for "v2" in rules.y */ +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); } + +word 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 */ + +word 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) */ + +word codegen(x) /* returns expression x with abstractions performed */ +word x; +{ extern word 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,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 */ +}} + +int lfrule=0; + +word 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); +} + +word 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; +int polyshowerror=0; + +word 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); +} + +word 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); } + } +} + +word 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 */ + +void 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; +} + +word 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); +} + +word 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); +} + +word 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 */ + +word 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) +*/ + +word 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); +}} + +word 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); +} + +word 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) */ +} + +word 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])); +} + +word 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)); } + +word 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 */ + +word 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) +*/ + +word 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 */ +} + +word 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 */ + +word 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) + +word 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); +}} + +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 */ +word 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]]); } + +void 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]; + } +}} + +word 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))); +} + +word 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]))); +} + +word 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)); +}} + +void 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 */ +} + +word 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 *//* +word 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))); +} /* not currently used */ + +#define arity_check if(t_arity(tf)!=arity)\ + printf("%ssyntax error: \ +wrong number of parameters for typename \"%s\" (%ld expected)\n",\ + echoing?"\n":"",get_id(tf),t_arity(tf)),errs=here,acterror() + +void 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; +} + +void 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 */ + +word 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 */ +/* 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)) */ + { /* 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) */ + g = tsort(g); /* g is list(defgroup) in dependency order */ + 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 */ + +word 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); +} + +word 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]]); +} + +word 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]]); +} + + +word 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); +} + +word 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)); +} + +word 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])); +} + +word 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)); +} + +word 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)); +} + +void 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); +} + +void 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(); +} + +void 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(); +} + +void 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]; +} + +int 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)); +} + +word transtypeid(x) /* recognises literal type constants - see rules.y */ +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 */ + @@ -0,0 +1,1674 @@ +/* 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. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "lex.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 */ + +static void abstr_check(word); +static void abstr_mcheck(word); +static void addsubst(word,word); +static word ap_subst(word,word); +static void checkfbs(void); +static int clear_SUBST(void); +static void comp_deps(word); +static word conforms(word,word,word,word); +static word cyclic_abstr(word); +static word etype(word,word,word); +static word fix_type(word); +static void fixshows(void); +static void genbnft(void); +static void infer_type(word); +static word linst(word,word); +static void locate_inc(void); +static void mcheckfbs(void); +static word meta_tcheck(word); +static int non_generic(word); +static int occurs(word,word); +static void out_formal(FILE*,word); +static void out_formal1(FILE*,word); +static void out_type1(word); +static void out_type2(word); +static void out_typel(word); +static void printelement(word); +static void redtfr(word); +static word rembvars(word,word); +static word remove1(word,word*); +static word rep_t(word,word); +static void sterilise(word); +static word subst(word); +static word subsu1(word,word,word); +static word tail(word); +static void txchange(word,word); +static void type_error(char*,char*,word,word); +static void type_error1(word); +static void type_error2(word); +static void type_error3(word); +static void type_error4(word); +static void type_error5(word); +static void type_error6(word,word,word); +static void type_error7(word,word); +static void type_error8(word,word); +static word ult(word); +static int unify(word,word); +static int unify1(word,word); + +void 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? */ + +void 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); +} + +word 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)); +} + +word 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; + +word 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 %ld)\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 */ + +void 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) + +void 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; + +void 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 */ + +void 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]]); +} + +void 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; +} + +word fix_type(t) /* substitute out any indirected typenames in t */ +word t; +{ switch(tag[t]) + { case AP: + case CONS: tl[t]=fix_type(tl[t]); + hd[t]=fix_type(hd[t]); + default: return(t); + case STRCONS: while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/ + return(t); + } +} + +void locate_inc() +{ if(lasthereinc==hereinc)return; + printf("incorrect %%include directive "); + sayhere(lasthereinc=hereinc,1); +} + +void 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]; + } +} + +void 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; +} + +word 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); +} + +void 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]; } +} + +void report_type(x) +word x; +{ printf("%s",get_id(x)); + if(id_type(x)==type_t) + if(t_arity(x)>5)printf("(arity %ld)",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)); +} + +void report_types(header,x) +char *header; +word x; +{ printf("%s",header); + while(x!=NIL) + report_type(hd[x]),putchar(';'),x=tl[x]; + putchar('\n'); +} + +word 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)); +} + +word 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); +} + +word rep_t(T,L) /* see above */ +word T,L; +{ word t=rep_t1(T,L); + return(t==T?t:redtvars(t)); +} + +word 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); +} + +word 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; + +void 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 */ + +word genlstat_t() /* type of %lex state */ +{ return(pair_t(num_t,num_t)); } + +void 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; + +void 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 */ + +word 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); + } +} + +word 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 */ + +word 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); +}} + +void 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 */ + +void 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 %3ld 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; } +} + +void 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'); +} + +void type_error1(x) /* typename in expression */ +word x; +{ locate("type error"); + printf("typename used as identifier (%s)\n",get_id(x)); +} + +void 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)); +} + +void 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)); +} + +void 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"); +} + +void 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); +} + +void 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'); +} + +void type_error7(a,b) +word a,b; +{ locate("type error"); + printf("\nrhs of lex rule :: "); + out_type(redtvars(subst(b))); + printf("\n type expected :: "); + out_type(redtvars(subst(a))); + putchar('\n'); +} + +/* void type_error7(t,args) +word t,args; +{ int 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"); +} */ + +void 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'); +} + +int 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); +} + +int 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); +} + +word 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)); } + +word 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); +} + +word 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); +} + +int 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); +} + +int 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 */ + +int 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 */ + +void fixshows() +{ while(showchain!=NIL) + { tl[hd[showchain]]=subst(tl[hd[showchain]]); + showchain=tl[showchain]; } +} + +word 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 */ +} + +void addsubst(tv,t) /* add new substitution to SUBST */ +word tv,t; +{ word h=hashval(tv); + SUBST[h]=cons(cons(tv,t),SUBST[h]); +} + +word ult(tv) /* fully substituted out value of a type var */ +word tv; +{ word s=lookup(tv); + return(s==tv?tv:subst(s)); +} + +word subst(t) /* returns fully substituted out value of type expression */ +word t; +{ return(walktype(t,ult)); +} + +word localtvmap=NIL; +word NGT=0; + +word 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); +} + +word linst(t,ngt) /* local instantiate */ +word t,ngt; /* relevant tvars are those not in ngt */ +{ localtvmap=NIL; NGT=ngt; + return(walktype(t,lmap)); +} + +int 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; + +word 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]); +} + +word 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)); +} + +word 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); +} + + +word 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)); +} + +word 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)); +} + + +word 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); +} + +word 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); +} + +word 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 */ + +word 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); +} + +word 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); +} + +word 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)); +} + +word 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); +}} + +word 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); +}} + +word member(s,x) +word s,x; +{ while(s!=NIL&&x!=hd[s])s=tl[s]; + return(s!=NIL); +} + +void 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]; } +} + +void 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(')'); +} + +void 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"); +} + +word printob(title,x) /* for debugging */ +char *title; +word x; +{ printf("%s",title); out(stdout,x); putchar('\n'); + return(x); } + +void 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 */ + +void 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 */ +} + +void 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); +} + +void 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]); } +} + +word tail(x) +word x; +{ allchars=1; + while(tag[x]==CONS)allchars&=(is_char(hd[x])),x=tl[x]; + return(x); +} + +void 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); +} + +void 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); +} + +void 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("%ld",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,%ld,%ld>",tag[t],hd[t],tl[t]); + } +} + +void 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 */ + @@ -0,0 +1,7 @@ +case $OSTYPE in +cygwin) echo no root user on cygwin; exit 1 ;; +Interix) echo Administrator:+Administrators ;; +darwin) echo root:wheel ;; +solaris*) echo root:bin ;; +*) echo root:root ;; +esac diff --git a/unprotect b/unprotect new file mode 100755 index 0000000..8decc76 --- /dev/null +++ b/unprotect @@ -0,0 +1 @@ +chmod -R u+w miralib @@ -0,0 +1,88 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "utf8.h" + +/* defines outUTF8(), fromUTF8() + to translate Unicode chars to, from UTF-8 byte sequences - DAT 12.4.2009 */ + +#define out(u,fil) putc((int)(u),(fil)) + +/* +FILE *f; +int nextch() +{ return getc(f); } +*/ + +static char errs[24]; +char *p; + +void utf8report() +{ fprintf(stderr,"protocol error - %s sequence:%s\n", + strstr(errs,"EOF")?"incomplete":"invalid",errs); + exit(1); +} + +#define foo(a) if(a==EOF)strcat(p," EOF"),p+=4;else sprintf(p," %#x",a),p+=strlen(p) +#define err(a) {*errs='\0';p=errs;foo(a); utf8report(); } +#define err2(a,b) {*errs='\0';p=errs;foo(a);foo(b); utf8report(); } +#define err3(a,b,c) {*errs='\0';p=errs;foo(a);foo(b);foo(c); utf8report(); } +#define err4(a,b,c,d) {*errs='\0';p=errs;foo(a);foo(b);foo(c);foo(d); utf8report(); } + +#define nextch(x) ((x)=getc(fil)) + +/* +#define nextch(x) ((x)=*(*p)++) +unicode scanUTF8(char **p) +*/ + +unicode fromUTF8(FILE *fil) +/* returns a unicode value or EOF for end of input */ +{ unsigned c0,c1,c2,c3; + if((nextch(c0))==EOF)return(EOF); + if(c0<=0x7f) /* ascii */ + return(c0); + if((c0&0xe0)==0xc0) + { /* 2 bytes */ + if((nextch(c1))==EOF)err2(c0,c1); + if((c1&0xc0)!=0x80)err2(c0,c1); + return((c0&0x1f)<<6|c1&0x3f); + } + if((c0&0xf0)==0xe0) + { /* 3 bytes */ + if((nextch(c1))==EOF)err2(c0,c1); + if((c1&0xc0)!=0x80)err2(c0,c1); + if((nextch(c2))==EOF)err3(c0,c1,c2); + if((c2&0xc0)!=0x80)err3(c0,c1,c2); + return((c0&0xf)<<12|(c1&0x3f)<<6|c2&0x3f); + } + if((c0&0xf8)==0xf0) + { /* 4 bytes */ + if((nextch(c1))==EOF)err2(c0,c1); + if((c1&0xc0)!=0x80)err2(c0,c1); + if((nextch(c2))==EOF)err3(c0,c1,c2); + if((c2&0xc0)!=0x80)err3(c0,c1,c2); + if((nextch(c3))==EOF)err4(c0,c1,c2,c3); + if((c3&0xc0)!=0x80)err4(c0,c1,c2,c3); + return((c0&7)<<18|(c1&0x3f)<<12|(c2&0x3f)<<6|c3&0x3f); + } + err(c0); +} + +void outUTF8(unicode u, FILE *fil) +{ if(u<=0x7f) + /* ascii */ + out(u,fil); else + if(u<=0x7ff) + /* latin1 and other chars requiring 2 octets */ + out(0xc0|(u&0x7c0)>>6,fil),out(0x80|u&0x3f,fil); else + if(u<=0xffff) + /* to here is basic multilingual plane */ + out(0xe0|(u&0xf000)>>12,fil),out(0x80|(u&0xfc0)>>6,fil),out(0x80|u&0x3f,fil); else + if(u<=0x10ffff) + /* other planes - rarely used - 4 octets */ + out(0xf0|(u&0x1c0000)>>18,fil),out(0x80|(u&0x3f000)>>12,fil),out(0x80|(u&0xfc0)>>6,fil), + out(0x80|u&0x3f,fil); else + /* codes above 0x10ffff not valid */ + fprintf(stderr,"char 0x%lx out of unicode range\n",u),exit(1); +} @@ -0,0 +1,9 @@ +typedef unsigned long unicode; +/* must be big enough to store codes up to UMAX */ + +#define UMAX 0x10ffff /* last unicode value */ +#define BMPMAX 0xffff + +#include <stdio.h> +unicode fromUTF8(FILE *); +void outUTF8(unicode, FILE *); diff --git a/version.c b/version.c new file mode 100644 index 0000000..eec70ac --- /dev/null +++ b/version.c @@ -0,0 +1,3 @@ +int version=VERS; +char *vdate=VDATE; +char *host=HOST; @@ -0,0 +1,3665 @@ +/* original parser id follows */ +/* yysccsid[] = "@(#)yaccpar 1.9 (Berkeley) 02/21/93" */ +/* (use YYMAJOR/YYMINOR for ifdefs dependent on parser version) */ + +#define YYBYACC 1 +#define YYMAJOR 1 +#define YYMINOR 9 +#define YYPATCH 20140715 + +#define YYEMPTY (-1) +#define yyclearin (yychar = YYEMPTY) +#define yyerrok (yyerrflag = 0) +#define YYRECOVERING() (yyerrflag != 0) +#define YYENOMEM (-2) +#define YYEOF 0 +#define YYPREFIX "yy" + +#define YYPURE 0 + +#line 34 "rules.y" +/* 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"}; + +#line 94 "rules.y" +#include "data.h" +#include "big.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; +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; +{ 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); +} + +int eprod(word); + +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 ? */ +word x; +{ 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); +} + +#line 340 "y.tab.c" + +#if ! defined(YYSTYPE) && ! defined(YYSTYPE_IS_DECLARED) +/* Default: YYSTYPE is the semantic value type. */ +typedef int YYSTYPE; +# define YYSTYPE_IS_DECLARED 1 +#endif + +/* compatibility with bison */ +#ifdef YYPARSE_PARAM +/* compatibility with FreeBSD */ +# ifdef YYPARSE_PARAM_TYPE +# define YYPARSE_DECL() yyparse(YYPARSE_PARAM_TYPE YYPARSE_PARAM) +# else +# define YYPARSE_DECL() yyparse(void *YYPARSE_PARAM) +# endif +#else +# define YYPARSE_DECL() yyparse(void) +#endif + +/* Parameters sent to lex. */ +#ifdef YYLEX_PARAM +# define YYLEX_DECL() yylex(void *YYLEX_PARAM) +# define YYLEX yylex(YYLEX_PARAM) +#else +# define YYLEX_DECL() yylex(void) +# define YYLEX yylex() +#endif + +/* Parameters sent to yyerror. */ +#ifndef YYERROR_DECL +#define YYERROR_DECL() yyerror(const char *s) +#endif +#ifndef YYERROR_CALL +#define YYERROR_CALL(msg) yyerror(msg) +#endif + +extern int YYPARSE_DECL(); + +#define VALUE 257 +#define EVAL 258 +#define WHERE 259 +#define IF 260 +#define TO 261 +#define LEFTARROW 262 +#define COLONCOLON 263 +#define COLON2EQ 264 +#define TYPEVAR 265 +#define NAME 266 +#define CNAME 267 +#define CONST 268 +#define DOLLAR2 269 +#define OFFSIDE 270 +#define ELSEQ 271 +#define ABSTYPE 272 +#define WITH 273 +#define DIAG 274 +#define EQEQ 275 +#define FREE 276 +#define INCLUDE 277 +#define EXPORT 278 +#define TYPE 279 +#define OTHERWISE 280 +#define SHOWSYM 281 +#define PATHNAME 282 +#define BNF 283 +#define LEX 284 +#define ENDIR 285 +#define ERRORSY 286 +#define ENDSY 287 +#define EMPTYSY 288 +#define READVALSY 289 +#define LEXDEF 290 +#define CHARCLASS 291 +#define ANTICHARCLASS 292 +#define LBEGIN 293 +#define ARROW 294 +#define PLUSPLUS 295 +#define MINUSMINUS 296 +#define DOTDOT 297 +#define VEL 298 +#define GE 299 +#define NE 300 +#define LE 301 +#define REM 302 +#define DIV 303 +#define INFIXNAME 304 +#define INFIXCNAME 305 +#define CMBASE 306 +#define YYERRCODE 256 +typedef short YYINT; +static const YYINT yylhs[] = { -1, + 0, 0, 0, 0, 0, 0, 1, 1, 2, 2, + 4, 4, 4, 6, 6, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 8, 8, 8, 8, 8, 8, 9, 9, 10, + 10, 10, 10, 11, 11, 11, 15, 15, 15, 13, + 13, 17, 18, 19, 19, 14, 20, 20, 5, 5, + 5, 5, 5, 5, 5, 5, 23, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 23, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 26, 26, 26, 27, 27, 27, 27, 27, + 28, 28, 21, 21, 24, 24, 24, 30, 29, 29, + 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, + 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, + 35, 37, 31, 31, 33, 33, 39, 39, 36, 36, + 36, 38, 38, 34, 34, 40, 40, 40, 41, 41, + 42, 42, 42, 42, 43, 43, 43, 43, 43, 43, + 44, 44, 32, 32, 32, 32, 45, 45, 46, 46, + 3, 3, 47, 47, 47, 47, 47, 47, 47, 47, + 63, 47, 57, 60, 60, 65, 65, 66, 66, 61, + 61, 67, 67, 68, 68, 68, 16, 54, 49, 12, + 12, 69, 69, 69, 69, 70, 70, 48, 48, 71, + 71, 71, 71, 71, 72, 72, 73, 73, 73, 73, + 73, 73, 73, 73, 55, 55, 74, 74, 75, 75, + 76, 76, 77, 77, 77, 77, 77, 79, 79, 79, + 80, 80, 58, 58, 58, 58, 58, 58, 58, 58, + 59, 59, 50, 52, 52, 84, 82, 83, 83, 51, + 51, 53, 53, 53, 53, 81, 81, 78, 78, 85, + 85, 56, 86, 86, 87, 87, 89, 89, 89, 88, + 88, 90, 90, 62, 62, 64, 64, 64, 64, 91, + 92, 94, 92, 93, 95, 95, 95, 97, 97, 98, + 100, 98, 96, 101, 96, 99, 99, 103, 99, 102, + 102, 104, 104, 104, 104, 105, 105, 105, 105, 106, + 106, 106, 106, 107, 108, 106, 106, +}; +static const YYINT yylen[] = { 2, + 1, 1, 2, 2, 3, 3, 0, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, + 3, 1, 1, 4, 3, 4, 2, 5, 4, 0, + 1, 0, 1, 1, 1, 0, 1, 3, 2, 3, + 3, 3, 3, 3, 1, 1, 2, 3, 2, 3, + 2, 3, 2, 3, 2, 3, 2, 1, 1, 2, + 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 1, 2, 2, 3, 2, 3, 2, 3, 2, 3, + 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, + 2, 1, 3, 3, 1, 3, 2, 3, 2, 1, + 2, 1, 3, 3, 3, 2, 3, 0, 4, 1, + 1, 1, 1, 1, 1, 2, 3, 5, 7, 5, + 4, 7, 6, 5, 5, 3, 3, 4, 2, 5, + 0, 0, 11, 1, 0, 3, 1, 2, 0, 2, + 2, 6, 0, 3, 1, 3, 2, 1, 2, 1, + 2, 2, 2, 1, 3, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 3, 3, 3, 1, 3, 6, + 1, 2, 7, 1, 7, 8, 8, 5, 5, 4, + 0, 7, 1, 0, 3, 2, 1, 5, 7, 0, + 1, 2, 1, 3, 3, 2, 0, 0, 0, 1, + 2, 1, 3, 3, 7, 1, 3, 1, 3, 3, + 2, 3, 3, 1, 1, 2, 1, 1, 1, 2, + 3, 2, 3, 5, 1, 3, 3, 1, 1, 1, + 2, 2, 1, 1, 3, 3, 5, 0, 1, 3, + 1, 3, 2, 3, 2, 2, 1, 2, 1, 1, + 2, 1, 6, 2, 1, 0, 7, 3, 1, 4, + 2, 2, 2, 3, 3, 1, 1, 1, 1, 0, + 2, 1, 1, 3, 4, 1, 3, 2, 2, 1, + 2, 2, 1, 0, 2, 1, 1, 2, 2, 6, + 0, 0, 4, 2, 1, 1, 3, 1, 4, 1, + 0, 7, 1, 0, 7, 1, 2, 0, 2, 1, + 2, 1, 3, 2, 2, 1, 2, 2, 2, 1, + 1, 1, 1, 0, 0, 5, 1, +}; +static const YYINT yydefred[] = { 0, + 1, 0, 0, 289, 0, 0, 239, 217, 217, 0, + 0, 288, 0, 0, 0, 2, 0, 0, 217, 191, + 219, 194, 0, 0, 0, 0, 235, 0, 130, 131, + 132, 135, 38, 134, 133, 17, 18, 19, 20, 21, + 32, 33, 39, 35, 36, 37, 16, 0, 23, 24, + 26, 25, 27, 28, 29, 30, 31, 0, 0, 0, + 0, 3, 9, 0, 13, 15, 22, 34, 0, 0, + 91, 0, 122, 0, 0, 0, 283, 282, 0, 0, + 0, 0, 231, 237, 238, 240, 226, 0, 242, 0, + 192, 201, 203, 0, 52, 0, 217, 218, 281, 0, + 0, 0, 0, 236, 0, 0, 0, 0, 0, 0, + 59, 0, 136, 0, 0, 0, 0, 149, 0, 0, + 0, 0, 0, 0, 0, 78, 79, 112, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 121, 163, 6, + 5, 291, 0, 0, 0, 219, 0, 0, 52, 0, + 207, 0, 0, 0, 0, 0, 213, 0, 241, 0, + 243, 304, 0, 0, 219, 0, 217, 229, 230, 232, + 233, 284, 285, 0, 0, 0, 137, 0, 0, 0, + 0, 0, 146, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 147, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 90, 0, 113, + 114, 0, 0, 0, 272, 0, 0, 218, 205, 206, + 0, 0, 216, 54, 55, 200, 53, 212, 227, 0, + 0, 267, 269, 270, 0, 0, 217, 280, 0, 0, + 183, 0, 0, 184, 188, 141, 0, 0, 0, 57, + 0, 0, 0, 0, 0, 0, 148, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 129, 0, 217, 52, 0, 199, 271, 0, 0, 214, + 215, 244, 305, 0, 268, 263, 265, 266, 0, 198, + 0, 0, 287, 0, 0, 0, 245, 0, 0, 250, + 254, 0, 0, 0, 0, 0, 0, 145, 140, 0, + 0, 138, 144, 0, 150, 157, 0, 0, 0, 0, + 0, 275, 52, 0, 0, 0, 0, 306, 307, 264, + 0, 0, 0, 253, 251, 0, 0, 0, 0, 0, + 252, 273, 0, 0, 0, 219, 0, 0, 293, 217, + 0, 0, 0, 0, 187, 186, 185, 143, 0, 0, + 58, 158, 156, 181, 182, 176, 177, 178, 179, 0, + 52, 0, 0, 0, 0, 180, 0, 0, 195, 274, + 217, 208, 0, 0, 0, 202, 308, 309, 0, 0, + 193, 0, 0, 0, 256, 0, 255, 0, 247, 0, + 0, 299, 0, 301, 0, 0, 0, 298, 0, 0, + 142, 139, 0, 151, 0, 0, 169, 172, 171, 173, + 0, 278, 276, 0, 52, 304, 0, 219, 222, 0, + 220, 51, 45, 0, 0, 217, 0, 0, 0, 297, + 197, 294, 0, 302, 196, 0, 175, 0, 164, 166, + 162, 0, 209, 217, 0, 221, 52, 0, 44, 46, + 0, 0, 257, 295, 190, 0, 0, 0, 0, 313, + 0, 224, 223, 0, 0, 0, 0, 0, 0, 314, + 315, 0, 318, 0, 0, 310, 217, 0, 0, 152, + 277, 52, 340, 342, 341, 347, 343, 0, 0, 330, + 0, 0, 0, 0, 52, 0, 0, 49, 0, 160, + 161, 0, 0, 0, 331, 335, 338, 337, 339, 0, + 0, 317, 0, 0, 48, 153, 217, 333, 345, 319, + 217, 225, 0, 0, 0, 0, 346, 0, 325, 322, +}; +static const YYINT yydgoto[] = { 15, + 16, 351, 17, 63, 64, 65, 66, 67, 68, 352, + 353, 447, 454, 413, 480, 364, 19, 246, 247, 271, + 69, 70, 125, 126, 127, 71, 128, 72, 73, 74, + 232, 263, 293, 391, 468, 510, 532, 233, 337, 392, + 393, 394, 395, 396, 264, 265, 20, 448, 99, 449, + 23, 341, 450, 177, 365, 366, 94, 256, 236, 82, + 165, 251, 172, 347, 160, 161, 166, 167, 451, 88, + 25, 26, 27, 317, 318, 319, 320, 321, 358, 458, + 322, 342, 343, 472, 77, 368, 369, 370, 371, 428, + 349, 404, 489, 405, 500, 501, 502, 503, 504, 525, + 512, 519, 505, 520, 521, 522, 523, 554, +}; +static const YYINT yysindex[] = { 2787, + 0, 2043, 2043, 0, 34, 34, 0, 0, 0, 52, + 4, 0, 1019, 1012, 0, 0, 2644, -48, 0, 0, + 0, 0, 264, 0, 171, -17, 0, -211, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 886, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 500, 886, 1579, + 1770, 0, 0, 21, 0, 0, 0, 0, 659, 2165, + 0, 132, 0, 71, 203, 34, 0, 0, 538, 249, + 630, 364, 0, 0, 0, 0, 0, 38, 0, 126, + 0, 0, 0, 119, 0, 538, 0, 0, 0, 704, + 243, 704, 704, 0, 34, 34, 886, 886, 18, 500, + 0, 426, 0, -22, 886, 500, 886, 0, 443, 485, + 238, 500, 659, 2246, 491, 0, 0, 0, 180, 500, + 500, 500, 500, 500, 886, 886, 886, 886, 886, 886, + 886, 886, 886, 886, 886, 716, 716, 0, 0, 0, + 0, 0, 34, 34, 264, 0, 538, 34, 0, 590, + 0, 540, 550, 340, -27, 364, 0, 704, 0, 704, + 0, 0, 461, 584, 0, 395, 0, 0, 0, 0, + 0, 0, 0, 2043, 1852, 2043, 0, 2043, 18, 0, + 426, 2043, 0, 500, 500, 500, 500, 500, 82, 886, + 886, 886, 886, 886, 886, 886, 886, 886, 886, 886, + 0, 716, 716, 21, 21, 21, -1, 621, 3, 18, + 18, 143, 143, 143, 143, 143, 426, 0, 3, 0, + 0, -44, 374, 423, 0, 795, 639, 0, 0, 0, + 437, 438, 0, 0, 0, 0, 0, 0, 0, 152, + 324, 0, 0, 0, 460, 517, 0, 0, 898, -158, + 0, 61, 80, 0, 0, 0, 611, -41, 139, 0, + 184, 21, 21, 21, -1, 621, 0, 3, 18, 18, + 143, 143, 143, 143, 143, 426, 0, 3, 0, 0, + 0, 473, 0, 0, 486, 0, 0, 2043, 490, 0, + 0, 0, 0, 522, 0, 0, 0, 0, 535, 0, + 2043, 825, 0, 1008, 1008, 502, 0, 531, 825, 0, + 0, -27, 1043, 1008, 2043, 500, 2043, 0, 0, 1892, + 2043, 0, 0, 2043, 0, 0, -29, 446, 766, 798, + 344, 0, 0, -27, 1008, 798, -197, 0, 0, 0, + 14, -27, 587, 0, 0, -25, 10, 808, 1008, 1008, + 0, 0, 1043, 583, 502, 0, 821, 736, 0, 0, + 825, 502, 817, 61, 0, 0, 0, 0, 778, 113, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 446, + 0, 759, 851, 446, 191, 0, 446, 486, 0, 0, + 0, 0, 502, 841, 860, 0, 0, 0, 1203, -83, + 0, 1203, 641, 1008, 0, 1008, 0, 502, 0, 10, + 876, 0, -27, 0, 1043, 619, 892, 0, -27, 2043, + 0, 0, 894, 0, 446, 446, 0, 0, 0, 0, + -27, 0, 0, -27, 0, 0, 1203, 0, 0, 0, + 0, 0, 0, 2043, 1203, 0, 502, 115, 889, 0, + 0, 0, 1008, 0, 0, 642, 0, 643, 0, 0, + 0, 679, 0, 0, 142, 0, 0, 274, 0, 0, + 2043, 1008, 0, 0, 0, 2043, 1008, 644, -27, 0, + 893, 0, 0, 917, 502, 669, 48, 0, 505, 0, + 0, 842, 0, 0, 505, 0, 0, 573, 235, 0, + 0, 0, 0, 0, 0, 0, 0, 359, 505, 0, + 840, 850, 877, 683, 0, 505, 2043, 0, 2043, 0, + 0, -27, 914, 856, 0, 0, 0, 0, 0, 2043, + 702, 0, 925, -27, 0, 0, 0, 0, 0, 0, + 0, 0, 2043, 903, 2043, -27, 0, -27, 0, 0, +}; +static const YYINT yyrindex[] = { 6, + 0, 715, 715, 0, 689, 1415, 0, 0, 0, 289, + 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, + 0, 0, 737, 332, 568, 1159, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1302, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1392, 1438, 715, + 715, 0, 0, 67, 0, 0, 0, 0, 1191, 1231, + 0, 91, 0, 0, 1002, 329, 0, 0, 0, 0, + 0, 141, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 715, 715, 843, 715, + 0, 219, 0, 0, -10, 31, 74, 0, 0, 959, + 965, 101, 72, 201, 0, 0, 0, 0, 1476, 715, + 715, 715, 715, 715, 715, 715, 715, 715, 715, 715, + 715, 715, 715, 715, 715, 715, 715, 0, 0, 0, + 0, 0, 325, 387, 738, 0, 0, -33, 0, 0, + 0, 0, 0, 0, 0, 159, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 715, 715, 715, 0, 715, 2401, 172, + 2356, 715, 0, 40, 55, 60, 122, 123, 0, 715, + 130, 160, 161, 166, 170, 176, 195, 245, 269, 270, + 0, 273, 294, 1466, 1491, 1530, 1339, 1282, 1089, 963, + 1036, 381, 577, 648, 717, 770, 523, 0, 1146, 0, + 0, 623, 431, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 520, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 503, 698, 818, 100, 305, 0, 2715, 2647, 2707, + 2441, 2512, 2522, 2562, 2602, 2431, 1969, 2722, 2240, 2316, + 0, 0, 0, 0, 0, 0, 0, 715, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 715, -3, 0, 0, 985, 288, 0, 281, 564, 0, + 0, 0, 763, 0, 715, 715, 715, 0, 0, 715, + 715, 0, 0, 715, 0, 0, 0, 0, 0, 771, + 0, 0, 0, 0, 0, -16, 0, 0, 0, 0, + 478, 0, 145, 0, 0, 0, 994, 0, 0, 0, + 0, 0, -14, 0, -2, 0, 168, 484, 0, 0, + 487, 504, 609, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 140, -24, 371, 1133, 0, 0, 0, 0, 0, + 0, 0, 504, 0, 0, 0, 0, 0, 0, 1934, + 0, 0, 0, 0, 0, 0, 0, -15, 0, -20, + 0, 0, 0, 0, 763, 0, 1153, 0, 0, 715, + 0, 0, 0, 0, 0, 417, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 530, 0, 0, 527, + 0, 0, 0, 715, 574, 0, 138, 0, 996, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 715, 0, 0, 0, 0, 715, 0, 407, 0, 0, + 0, 0, 0, 465, 954, 575, 0, 165, 448, 0, + 0, 612, 0, 805, 947, 0, 0, 1934, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 947, 1097, 0, + 1583, 1896, 0, 640, 0, 1288, 715, 0, 715, 0, + 0, 0, 0, 1735, 0, 0, 0, 0, 0, 715, + 407, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 715, 0, 715, 0, 0, 0, 0, 0, +}; +static const YYINT yygindex[] = { 0, + 0, 2, 0, 978, 2259, 0, 981, 904, 0, 198, + 0, 631, 541, 0, 0, 1, -12, -249, 0, 720, + 993, 2932, 0, 0, 0, 9, 0, 997, 76, 0, + 0, 858, 0, -350, 0, 0, 0, 0, 0, 0, + -267, 0, 0, 0, 247, 0, 1038, 1201, -21, 510, + 999, 0, 649, 838, 2569, 0, 0, 0, 0, 0, + 0, 636, 0, 0, 0, 924, 0, 920, -394, 918, + 551, 0, 1066, 733, 0, 0, 1285, 8, 0, 684, + 0, -261, 703, 0, 49, 0, -297, 645, 0, 0, + 760, 0, 0, 0, 0, 585, 0, 570, 0, 0, + 0, 610, 0, -449, 598, 0, 0, 0, +}; +#define YYTABLESIZE 3142 +static const YYINT yytable[] = { 95, + 18, 304, 331, 62, 75, 7, 310, 28, 79, 80, + 97, 98, 76, 76, 8, 292, 168, 18, 414, 93, + 259, 186, 14, 312, 28, 246, 258, 52, 246, 253, + 14, 245, 383, 14, 168, 144, 134, 253, 300, 433, + 253, 311, 348, 246, 138, 136, 441, 137, 143, 139, + 144, 332, 476, 416, 78, 253, 300, 410, 134, 138, + 476, 114, 119, 143, 139, 421, 10, 415, 346, 535, + 187, 11, 362, 13, 11, 12, 535, 246, 131, 400, + 69, 168, 174, 76, 469, 407, 28, 406, 28, 253, + 115, 399, 105, 106, 402, 71, 142, 176, 134, 168, + 73, 188, 411, 28, 326, 323, 245, 10, 246, 65, + 10, 142, 182, 183, 12, 65, 324, 12, 131, 134, + 253, 300, 277, 115, 152, 10, 437, 462, 115, 65, + 169, 115, 115, 115, 115, 115, 115, 115, 327, 131, + 74, 15, 234, 63, 15, 237, 238, 148, 115, 115, + 115, 115, 115, 258, 230, 231, 334, 63, 482, 10, + 76, 76, 75, 77, 28, 76, 171, 28, 470, 170, + 95, 61, 328, 461, 81, 144, 452, 260, 261, 465, + 165, 261, 490, 115, 115, 261, 267, 268, 143, 261, + 10, 471, 302, 270, 473, 168, 453, 327, 165, 210, + 97, 99, 78, 43, 148, 432, 101, 483, 250, 59, + 105, 250, 67, 101, 115, 59, 103, 211, 81, 61, + 289, 290, 60, 323, 335, 324, 250, 334, 100, 59, + 261, 333, 439, 438, 92, 107, 142, 382, 66, 506, + 291, 290, 244, 28, 66, 168, 279, 511, 84, 85, + 7, 184, 217, 440, 246, 330, 81, 311, 66, 81, + 81, 81, 81, 81, 81, 81, 253, 300, 359, 168, + 60, 83, 409, 128, 185, 198, 81, 81, 81, 81, + 81, 339, 546, 52, 300, 109, 102, 103, 217, 246, + 253, 250, 52, 338, 552, 195, 133, 217, 4, 344, + 253, 253, 300, 359, 140, 141, 559, 96, 560, 111, + 126, 81, 81, 117, 128, 130, 132, 244, 133, 140, + 141, 248, 325, 128, 248, 10, 373, 10, 376, 10, + 401, 379, 270, 204, 119, 381, 10, 10, 128, 248, + 10, 359, 81, 128, 423, 76, 286, 204, 64, 115, + 429, 115, 115, 115, 149, 130, 132, 128, 133, 10, + 115, 115, 64, 10, 115, 115, 65, 65, 290, 65, + 426, 157, 290, 248, 128, 219, 130, 132, 434, 133, + 84, 444, 245, 115, 128, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 63, 63, 173, 29, 30, 31, + 32, 443, 245, 516, 248, 128, 128, 303, 164, 165, + 210, 170, 34, 128, 43, 56, 28, 170, 84, 28, + 35, 84, 84, 84, 84, 84, 477, 84, 211, 170, + 290, 466, 474, 165, 323, 146, 147, 250, 84, 84, + 84, 84, 84, 128, 128, 29, 30, 31, 32, 128, + 478, 328, 517, 128, 28, 479, 481, 167, 144, 128, + 34, 250, 28, 150, 491, 151, 59, 59, 35, 59, + 154, 250, 250, 84, 488, 167, 154, 81, 128, 81, + 81, 81, 494, 212, 213, 390, 192, 496, 81, 81, + 154, 389, 81, 81, 170, 66, 66, 328, 66, 533, + 328, 530, 531, 254, 84, 255, 326, 527, 326, 22, + 179, 81, 543, 81, 81, 81, 81, 81, 81, 81, + 81, 81, 89, 47, 541, 193, 22, 296, 128, 328, + 545, 211, 194, 196, 108, 197, 42, 492, 344, 61, + 167, 549, 292, 68, 107, 296, 60, 553, 493, 516, + 248, 555, 128, 128, 204, 204, 128, 286, 204, 308, + 89, 309, 219, 89, 89, 89, 89, 89, 89, 89, + 219, 326, 375, 377, 248, 245, 85, 128, 10, 12, + 89, 89, 89, 89, 89, 248, 241, 290, 41, 303, + 60, 290, 290, 244, 219, 52, 242, 290, 517, 64, + 64, 290, 64, 290, 249, 243, 52, 249, 228, 340, + 296, 228, 10, 244, 85, 89, 89, 85, 85, 85, + 85, 85, 249, 85, 513, 110, 514, 518, 228, 162, + 163, 12, 40, 159, 85, 85, 85, 85, 85, 84, + 170, 84, 84, 84, 257, 515, 89, 87, 24, 290, + 84, 84, 180, 181, 84, 84, 249, 259, 134, 290, + 228, 290, 155, 294, 170, 24, 235, 189, 155, 85, + 316, 12, 328, 84, 328, 84, 84, 84, 84, 84, + 84, 84, 84, 84, 217, 87, 167, 249, 87, 87, + 87, 87, 87, 328, 87, 295, 154, 154, 154, 298, + 85, 189, 300, 329, 301, 87, 87, 87, 87, 87, + 167, 384, 385, 386, 239, 154, 86, 326, 46, 43, + 41, 154, 154, 47, 544, 305, 252, 156, 237, 159, + 217, 237, 290, 217, 47, 47, 387, 388, 70, 336, + 87, 61, 253, 14, 175, 297, 237, 42, 11, 237, + 556, 340, 558, 292, 86, 61, 296, 86, 86, 86, + 86, 86, 217, 86, 345, 29, 30, 31, 32, 88, + 513, 87, 514, 219, 86, 86, 86, 86, 86, 237, + 34, 89, 306, 89, 89, 89, 244, 346, 35, 219, + 217, 515, 89, 89, 13, 359, 89, 89, 307, 41, + 350, 217, 4, 153, 154, 156, 60, 88, 159, 86, + 88, 88, 88, 88, 88, 89, 88, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 397, 88, 88, 88, + 88, 88, 452, 249, 360, 85, 12, 85, 85, 85, + 86, 398, 80, 40, 159, 412, 85, 85, 417, 422, + 85, 85, 528, 424, 4, 158, 154, 249, 72, 425, + 430, 62, 88, 320, 315, 321, 12, 249, 249, 85, + 431, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 80, 316, 435, 80, 156, 80, 80, 80, 155, 155, + 155, 538, 537, 88, 4, 158, 154, 436, 445, 446, + 80, 80, 80, 80, 80, 217, 87, 217, 87, 87, + 87, 456, 539, 155, 155, 314, 460, 87, 87, 296, + 108, 87, 87, 463, 464, 61, 217, 217, 320, 498, + 107, 499, 482, 33, 467, 80, 486, 315, 485, 12, + 87, 487, 87, 87, 87, 87, 87, 87, 87, 87, + 87, 290, 290, 507, 237, 237, 237, 42, 44, 45, + 508, 509, 82, 290, 536, 524, 80, 540, 498, 84, + 85, 7, 135, 145, 547, 86, 60, 86, 86, 86, + 548, 29, 30, 31, 32, 551, 86, 86, 314, 499, + 86, 86, 237, 237, 262, 557, 34, 262, 128, 52, + 82, 4, 9, 82, 35, 82, 82, 82, 10, 86, + 52, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 82, 82, 82, 82, 82, 258, 200, 210, 88, 217, + 88, 88, 88, 279, 259, 83, 260, 344, 120, 88, + 88, 122, 455, 88, 88, 269, 262, 315, 529, 12, + 380, 14, 89, 123, 91, 82, 11, 129, 14, 4, + 153, 154, 88, 11, 88, 88, 88, 88, 88, 88, + 88, 88, 88, 83, 320, 299, 83, 155, 83, 83, + 83, 475, 363, 240, 12, 248, 82, 250, 124, 4, + 354, 104, 419, 83, 83, 83, 83, 83, 314, 459, + 442, 80, 13, 80, 80, 80, 408, 484, 542, 13, + 550, 86, 80, 80, 526, 534, 80, 80, 0, 0, + 0, 0, 0, 0, 0, 0, 124, 0, 83, 124, + 0, 0, 124, 314, 0, 80, 0, 80, 80, 80, + 80, 80, 80, 80, 0, 123, 124, 124, 124, 124, + 124, 29, 30, 31, 32, 327, 0, 327, 0, 83, + 0, 0, 4, 312, 0, 0, 34, 0, 0, 0, + 0, 0, 174, 174, 35, 0, 313, 0, 174, 174, + 0, 124, 0, 123, 0, 0, 123, 344, 0, 123, + 65, 174, 303, 303, 303, 0, 0, 0, 0, 234, + 21, 234, 234, 123, 123, 123, 123, 123, 0, 0, + 0, 303, 124, 87, 90, 0, 234, 21, 0, 234, + 327, 82, 0, 82, 82, 82, 0, 0, 65, 0, + 66, 65, 82, 82, 65, 0, 82, 82, 123, 0, + 0, 0, 14, 303, 12, 0, 0, 11, 65, 65, + 0, 234, 0, 0, 0, 82, 174, 82, 82, 82, + 82, 82, 82, 82, 0, 0, 0, 0, 66, 123, + 0, 66, 4, 312, 66, 0, 303, 84, 85, 7, + 0, 64, 0, 65, 84, 85, 7, 0, 66, 66, + 0, 0, 0, 13, 83, 0, 83, 83, 83, 0, + 178, 14, 0, 0, 0, 83, 83, 4, 312, 83, + 83, 0, 0, 0, 65, 0, 0, 0, 0, 0, + 0, 0, 64, 66, 0, 64, 0, 0, 83, 0, + 83, 83, 83, 83, 83, 83, 83, 0, 63, 64, + 64, 0, 14, 0, 0, 14, 329, 124, 329, 124, + 124, 124, 0, 0, 66, 0, 0, 0, 124, 124, + 14, 0, 124, 124, 0, 0, 327, 0, 249, 0, + 87, 0, 0, 0, 64, 0, 0, 0, 344, 63, + 0, 124, 63, 124, 124, 124, 124, 124, 124, 124, + 0, 11, 0, 0, 14, 0, 63, 63, 174, 174, + 174, 0, 174, 0, 123, 64, 123, 123, 123, 0, + 0, 329, 0, 0, 0, 123, 123, 303, 303, 123, + 123, 0, 303, 174, 174, 14, 174, 0, 0, 0, + 0, 63, 11, 0, 0, 11, 0, 12, 123, 0, + 123, 123, 123, 123, 123, 123, 123, 0, 0, 65, + 11, 65, 65, 65, 238, 0, 0, 238, 290, 0, + 65, 65, 63, 0, 65, 60, 0, 4, 5, 6, + 7, 0, 238, 0, 0, 238, 0, 0, 12, 0, + 0, 12, 0, 65, 11, 65, 65, 65, 65, 66, + 61, 66, 66, 66, 0, 0, 12, 0, 0, 0, + 66, 66, 0, 0, 66, 238, 60, 0, 115, 60, + 0, 0, 0, 115, 0, 11, 120, 115, 115, 115, + 115, 115, 115, 66, 60, 66, 66, 66, 66, 62, + 12, 61, 0, 115, 61, 115, 115, 115, 0, 0, + 64, 0, 64, 64, 64, 0, 0, 0, 0, 61, + 0, 64, 64, 0, 0, 64, 0, 329, 60, 0, + 14, 12, 14, 0, 14, 0, 0, 0, 0, 115, + 62, 14, 14, 62, 64, 14, 64, 64, 64, 64, + 0, 0, 0, 61, 0, 128, 0, 0, 62, 60, + 0, 0, 0, 0, 14, 0, 355, 63, 14, 63, + 63, 63, 0, 361, 0, 0, 0, 367, 63, 63, + 0, 55, 63, 59, 61, 0, 40, 0, 61, 0, + 49, 47, 62, 48, 54, 50, 0, 332, 0, 0, + 0, 63, 0, 63, 63, 63, 37, 0, 46, 43, + 41, 332, 0, 332, 0, 0, 0, 367, 0, 0, + 11, 0, 11, 62, 11, 427, 0, 0, 0, 0, + 0, 11, 11, 0, 0, 11, 0, 0, 0, 60, + 0, 113, 53, 332, 0, 128, 332, 290, 290, 0, + 238, 238, 238, 0, 11, 0, 0, 0, 11, 290, + 0, 0, 0, 0, 0, 0, 12, 0, 12, 0, + 12, 0, 0, 0, 58, 332, 332, 12, 12, 367, + 0, 12, 0, 0, 0, 0, 0, 0, 238, 238, + 0, 128, 0, 0, 60, 0, 60, 60, 60, 0, + 12, 0, 0, 0, 12, 60, 60, 0, 0, 60, + 0, 0, 0, 0, 0, 0, 0, 367, 0, 61, + 115, 61, 61, 61, 0, 0, 0, 0, 60, 128, + 61, 61, 60, 0, 61, 0, 0, 0, 0, 0, + 115, 115, 0, 115, 115, 115, 115, 115, 115, 334, + 0, 0, 0, 61, 0, 0, 0, 61, 62, 0, + 62, 62, 62, 334, 0, 334, 0, 0, 0, 62, + 62, 0, 55, 62, 117, 0, 0, 40, 0, 61, + 118, 49, 47, 0, 115, 54, 50, 0, 0, 0, + 0, 0, 62, 0, 0, 334, 62, 37, 334, 46, + 43, 41, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 29, 30, 31, 32, 332, 0, + 332, 0, 332, 33, 0, 0, 0, 334, 334, 34, + 60, 0, 0, 53, 0, 0, 0, 35, 0, 332, + 0, 0, 0, 36, 38, 0, 39, 42, 44, 45, + 51, 52, 56, 57, 55, 0, 59, 0, 0, 40, + 0, 61, 0, 49, 47, 116, 48, 54, 50, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 37, + 0, 46, 43, 41, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 55, 0, 59, 0, 0, 40, + 0, 61, 0, 49, 47, 0, 48, 54, 50, 0, + 336, 0, 60, 0, 266, 53, 0, 0, 0, 37, + 0, 46, 43, 41, 336, 0, 336, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 50, 0, 50, 0, + 0, 50, 0, 50, 0, 50, 50, 58, 50, 50, + 50, 0, 60, 0, 378, 53, 336, 0, 0, 336, + 0, 50, 0, 50, 50, 50, 0, 0, 0, 0, + 334, 90, 334, 0, 334, 0, 90, 0, 0, 110, + 90, 90, 90, 90, 90, 90, 0, 58, 336, 336, + 336, 334, 0, 0, 50, 0, 90, 50, 90, 90, + 90, 0, 0, 0, 0, 29, 30, 31, 32, 0, + 0, 0, 0, 0, 33, 0, 0, 0, 0, 0, + 34, 0, 0, 0, 0, 0, 0, 0, 35, 50, + 0, 0, 90, 0, 36, 38, 0, 39, 42, 44, + 45, 51, 52, 56, 57, 55, 0, 59, 0, 0, + 40, 0, 61, 0, 49, 47, 0, 48, 54, 50, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 37, 0, 46, 43, 41, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 29, 30, 31, + 32, 0, 0, 0, 0, 0, 33, 0, 0, 0, + 0, 0, 34, 60, 0, 0, 53, 0, 0, 0, + 35, 0, 0, 0, 0, 0, 36, 38, 0, 39, + 42, 44, 45, 51, 52, 56, 57, 29, 30, 31, + 32, 336, 0, 336, 0, 336, 33, 0, 58, 0, + 0, 0, 34, 0, 0, 0, 0, 0, 0, 0, + 35, 0, 336, 0, 0, 0, 36, 38, 0, 39, + 42, 44, 45, 51, 52, 56, 57, 144, 0, 50, + 50, 50, 50, 0, 0, 0, 138, 136, 50, 137, + 143, 139, 0, 0, 50, 0, 0, 50, 0, 0, + 0, 0, 50, 0, 46, 43, 41, 0, 50, 50, + 0, 50, 50, 50, 50, 50, 50, 50, 50, 0, + 0, 0, 0, 90, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 142, 0, + 0, 0, 0, 90, 90, 0, 90, 90, 90, 90, + 90, 90, 113, 0, 0, 0, 0, 113, 209, 0, + 116, 113, 113, 113, 113, 113, 113, 203, 201, 0, + 202, 208, 204, 0, 0, 0, 0, 113, 0, 113, + 113, 113, 0, 0, 0, 46, 43, 41, 29, 30, + 31, 32, 0, 0, 0, 0, 111, 33, 0, 121, + 0, 0, 0, 34, 0, 0, 0, 0, 0, 0, + 0, 35, 0, 113, 0, 0, 0, 36, 38, 207, + 39, 42, 44, 45, 51, 52, 56, 57, 114, 0, + 0, 0, 0, 114, 0, 0, 118, 114, 114, 114, + 114, 114, 114, 0, 0, 0, 0, 0, 111, 0, + 0, 0, 0, 114, 190, 114, 114, 114, 0, 0, + 199, 0, 0, 0, 0, 0, 0, 0, 214, 215, + 216, 217, 218, 81, 0, 0, 93, 81, 81, 81, + 81, 81, 81, 0, 0, 0, 0, 0, 0, 114, + 0, 0, 0, 81, 0, 81, 81, 81, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 80, 33, + 0, 92, 262, 80, 80, 80, 262, 0, 0, 81, + 0, 0, 272, 273, 274, 275, 276, 0, 80, 0, + 80, 80, 80, 42, 44, 45, 140, 141, 89, 0, + 0, 108, 89, 89, 89, 89, 89, 89, 84, 0, + 0, 98, 84, 84, 84, 84, 0, 84, 89, 0, + 89, 89, 89, 0, 0, 0, 0, 0, 84, 0, + 84, 84, 84, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 113, 0, 0, 0, 0, 0, + 33, 0, 0, 0, 89, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 113, 113, 0, 113, 113, 113, + 113, 113, 113, 0, 42, 44, 45, 205, 206, 85, + 0, 0, 100, 85, 85, 85, 85, 0, 85, 87, + 0, 0, 104, 87, 87, 87, 87, 0, 87, 85, + 0, 85, 85, 85, 0, 0, 0, 0, 0, 87, + 0, 87, 87, 87, 374, 262, 0, 0, 0, 0, + 114, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 0, 0, 102, 86, 86, 86, 86, 0, 86, 0, + 114, 114, 0, 114, 114, 114, 114, 114, 114, 86, + 0, 86, 86, 86, 0, 0, 0, 0, 0, 0, + 81, 0, 0, 0, 0, 0, 0, 0, 0, 88, + 0, 0, 106, 88, 88, 88, 88, 0, 88, 0, + 81, 81, 0, 81, 81, 81, 81, 81, 81, 88, + 0, 88, 88, 88, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 80, 0, 0, 0, 0, + 0, 0, 0, 14, 82, 12, 0, 94, 11, 82, + 82, 82, 0, 0, 0, 80, 80, 0, 80, 80, + 80, 80, 0, 0, 82, 89, 82, 82, 82, 0, + 0, 0, 0, 0, 0, 84, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 89, 89, 0, 89, 89, + 89, 89, 89, 89, 13, 84, 84, 0, 84, 84, + 84, 84, 84, 84, 83, 0, 0, 96, 0, 83, + 83, 83, 124, 0, 0, 127, 0, 0, 124, 123, + 0, 0, 125, 0, 83, 123, 83, 83, 83, 0, + 0, 0, 124, 0, 124, 124, 124, 0, 0, 123, + 0, 123, 123, 123, 0, 0, 85, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 87, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 85, 85, 0, 85, + 85, 85, 85, 85, 85, 0, 87, 87, 0, 87, + 87, 87, 87, 87, 87, 0, 14, 316, 12, 0, + 0, 11, 0, 0, 0, 0, 86, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 86, 86, 0, 86, + 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 88, 13, 0, 0, + 0, 0, 356, 357, 0, 0, 0, 0, 0, 0, + 0, 0, 372, 0, 0, 0, 88, 88, 0, 88, + 88, 88, 88, 88, 88, 0, 0, 0, 4, 5, + 6, 7, 0, 403, 0, 8, 0, 0, 0, 9, + 10, 82, 0, 0, 0, 0, 0, 418, 0, 0, + 0, 420, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 82, 82, 0, 82, 82, 82, 82, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 109, + 0, 83, 457, 0, 457, 0, 0, 0, 0, 124, + 112, 0, 124, 0, 0, 0, 123, 0, 0, 0, + 0, 83, 83, 0, 83, 83, 83, 83, 0, 124, + 124, 0, 124, 124, 124, 124, 123, 123, 0, 123, + 123, 123, 123, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 109, 112, + 0, 0, 1, 2, 3, 0, 189, 0, 191, 0, + 495, 4, 5, 6, 7, 497, 0, 0, 8, 0, + 0, 0, 9, 10, 0, 0, 219, 220, 221, 222, + 223, 224, 225, 226, 227, 228, 229, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 278, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, +}; +static const YYINT yycheck[] = { 21, + 0, 251, 44, 2, 3, 0, 256, 0, 8, 9, + 23, 24, 5, 6, 0, 60, 41, 17, 44, 19, + 41, 44, 40, 40, 17, 41, 41, 61, 44, 33, + 41, 59, 62, 44, 59, 33, 38, 41, 41, 390, + 44, 58, 304, 59, 42, 43, 397, 45, 46, 47, + 33, 93, 447, 44, 6, 59, 59, 44, 38, 42, + 455, 60, 61, 46, 47, 363, 0, 93, 266, 519, + 93, 41, 322, 91, 44, 42, 526, 93, 58, 341, + 41, 44, 95, 76, 435, 347, 79, 285, 81, 93, + 0, 341, 304, 305, 344, 41, 94, 97, 38, 124, + 41, 124, 352, 96, 44, 264, 59, 41, 124, 38, + 44, 94, 105, 106, 41, 44, 275, 44, 58, 38, + 124, 124, 41, 33, 76, 59, 394, 425, 38, 58, + 93, 41, 42, 43, 44, 45, 46, 47, 59, 58, + 41, 41, 155, 44, 44, 158, 159, 72, 58, 59, + 60, 61, 62, 175, 146, 147, 44, 58, 44, 93, + 153, 154, 41, 41, 157, 158, 41, 160, 436, 44, + 41, 40, 93, 423, 123, 33, 260, 177, 41, 429, + 41, 44, 41, 93, 94, 184, 185, 186, 46, 188, + 124, 441, 41, 192, 444, 44, 280, 59, 59, 59, + 41, 41, 154, 59, 129, 93, 41, 93, 41, 38, + 41, 44, 41, 43, 124, 44, 41, 59, 0, 40, + 212, 213, 91, 59, 41, 61, 59, 44, 58, 58, + 93, 93, 42, 43, 283, 41, 94, 267, 38, 489, + 285, 275, 270, 236, 44, 270, 263, 497, 266, 267, + 268, 274, 267, 63, 270, 297, 38, 257, 58, 41, + 42, 43, 44, 45, 46, 47, 270, 270, 294, 294, + 91, 268, 259, 284, 297, 38, 58, 59, 60, 61, + 62, 294, 532, 278, 305, 41, 304, 305, 283, 305, + 294, 124, 278, 293, 544, 58, 298, 283, 265, 298, + 304, 305, 305, 294, 302, 303, 556, 44, 558, 41, + 41, 93, 94, 41, 284, 295, 296, 270, 298, 302, + 303, 41, 262, 284, 44, 259, 325, 261, 327, 263, + 343, 330, 331, 45, 41, 334, 270, 271, 284, 59, + 274, 294, 124, 284, 366, 41, 59, 59, 44, 259, + 372, 261, 262, 263, 284, 295, 296, 284, 298, 293, + 270, 271, 58, 297, 274, 275, 295, 296, 44, 298, + 370, 123, 44, 93, 284, 44, 295, 296, 391, 298, + 0, 403, 59, 293, 284, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 295, 296, 278, 266, 267, 268, + 269, 401, 59, 45, 124, 284, 284, 266, 45, 270, + 270, 41, 281, 284, 270, 271, 409, 47, 38, 412, + 289, 41, 42, 43, 44, 45, 448, 47, 270, 59, + 44, 430, 445, 294, 270, 304, 305, 270, 58, 59, + 60, 61, 62, 284, 284, 266, 267, 268, 269, 284, + 450, 45, 94, 284, 447, 454, 456, 41, 33, 284, + 281, 294, 455, 261, 477, 263, 295, 296, 289, 298, + 40, 304, 305, 93, 474, 59, 46, 259, 284, 261, + 262, 263, 481, 304, 305, 40, 44, 486, 270, 271, + 60, 46, 274, 275, 124, 295, 296, 91, 298, 512, + 94, 267, 268, 43, 124, 45, 59, 507, 61, 0, + 268, 293, 525, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 0, 59, 524, 41, 17, 41, 284, 123, + 529, 41, 295, 296, 35, 298, 59, 264, 91, 40, + 124, 540, 59, 41, 45, 59, 44, 547, 275, 45, + 270, 551, 284, 284, 266, 267, 284, 270, 270, 43, + 38, 45, 59, 41, 42, 43, 44, 45, 46, 47, + 44, 124, 326, 327, 294, 59, 0, 284, 59, 42, + 58, 59, 60, 61, 62, 305, 47, 263, 59, 266, + 91, 263, 264, 270, 263, 264, 47, 273, 94, 295, + 296, 273, 298, 275, 41, 266, 275, 44, 41, 266, + 124, 44, 93, 270, 38, 93, 94, 41, 42, 43, + 44, 45, 59, 47, 266, 126, 268, 123, 61, 266, + 267, 42, 59, 59, 58, 59, 60, 61, 62, 259, + 270, 261, 262, 263, 61, 287, 124, 0, 0, 263, + 270, 271, 102, 103, 274, 275, 93, 263, 38, 273, + 93, 275, 40, 290, 294, 17, 157, 59, 46, 93, + 59, 42, 266, 293, 268, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 45, 38, 270, 124, 41, 42, + 43, 44, 45, 287, 47, 273, 266, 267, 268, 61, + 124, 93, 266, 93, 267, 58, 59, 60, 61, 62, + 294, 266, 267, 268, 125, 285, 0, 270, 60, 61, + 62, 291, 292, 259, 527, 266, 266, 79, 40, 81, + 91, 43, 44, 94, 270, 271, 291, 292, 41, 267, + 93, 44, 282, 40, 96, 236, 58, 270, 45, 61, + 553, 266, 555, 270, 38, 40, 270, 41, 42, 43, + 44, 45, 123, 47, 275, 266, 267, 268, 269, 0, + 266, 124, 268, 270, 58, 59, 60, 61, 62, 91, + 281, 259, 266, 261, 262, 263, 270, 266, 289, 263, + 264, 287, 270, 271, 91, 294, 274, 275, 282, 270, + 266, 275, 265, 266, 267, 157, 91, 38, 160, 93, + 41, 42, 43, 44, 45, 293, 47, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 61, 58, 59, 60, + 61, 62, 260, 270, 304, 259, 42, 261, 262, 263, + 124, 44, 0, 270, 270, 259, 270, 271, 41, 267, + 274, 275, 280, 33, 265, 266, 267, 294, 41, 124, + 44, 44, 93, 59, 40, 61, 42, 304, 305, 293, + 93, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 38, 270, 124, 41, 236, 43, 44, 45, 266, 267, + 268, 42, 43, 124, 265, 266, 267, 47, 58, 40, + 58, 59, 60, 61, 62, 266, 259, 268, 261, 262, + 263, 271, 63, 291, 292, 91, 41, 270, 271, 125, + 35, 274, 275, 305, 33, 40, 287, 288, 124, 286, + 45, 288, 44, 275, 41, 93, 294, 40, 297, 42, + 293, 263, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 263, 264, 61, 266, 267, 268, 299, 300, 301, + 44, 293, 0, 275, 125, 124, 124, 91, 286, 266, + 267, 268, 69, 70, 61, 259, 91, 261, 262, 263, + 125, 266, 267, 268, 269, 61, 270, 271, 91, 288, + 274, 275, 304, 305, 41, 93, 281, 44, 284, 263, + 38, 0, 44, 41, 289, 43, 44, 45, 44, 293, + 273, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 58, 59, 60, 61, 62, 41, 123, 124, 259, 267, + 261, 262, 263, 263, 41, 0, 41, 91, 61, 270, + 271, 61, 412, 274, 275, 188, 93, 40, 508, 42, + 331, 40, 41, 61, 17, 93, 45, 61, 40, 265, + 266, 267, 293, 45, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 38, 270, 238, 41, 79, 43, 44, + 45, 446, 40, 160, 42, 166, 124, 170, 0, 265, + 266, 26, 360, 58, 59, 60, 61, 62, 91, 416, + 398, 259, 91, 261, 262, 263, 347, 463, 524, 91, + 541, 93, 270, 271, 505, 518, 274, 275, -1, -1, + -1, -1, -1, -1, -1, -1, 38, -1, 93, 41, + -1, -1, 44, 91, -1, 293, -1, 295, 296, 297, + 298, 299, 300, 301, -1, 0, 58, 59, 60, 61, + 62, 266, 267, 268, 269, 59, -1, 61, -1, 124, + -1, -1, 265, 266, -1, -1, 281, -1, -1, -1, + -1, -1, 40, 41, 289, -1, 279, -1, 46, 47, + -1, 93, -1, 38, -1, -1, 41, 91, -1, 44, + 0, 59, 40, 41, 42, -1, -1, -1, -1, 41, + 0, 43, 44, 58, 59, 60, 61, 62, -1, -1, + -1, 59, 124, 13, 14, -1, 58, 17, -1, 61, + 124, 259, -1, 261, 262, 263, -1, -1, 38, -1, + 0, 41, 270, 271, 44, -1, 274, 275, 93, -1, + -1, -1, 40, 91, 42, -1, -1, 45, 58, 59, + -1, 93, -1, -1, -1, 293, 124, 295, 296, 297, + 298, 299, 300, 301, -1, -1, -1, -1, 38, 124, + -1, 41, 265, 266, 44, -1, 124, 266, 267, 268, + -1, 0, -1, 93, 266, 267, 268, -1, 58, 59, + -1, -1, -1, 91, 259, -1, 261, 262, 263, -1, + 100, 0, -1, -1, -1, 270, 271, 265, 266, 274, + 275, -1, -1, -1, 124, -1, -1, -1, -1, -1, + -1, -1, 41, 93, -1, 44, -1, -1, 293, -1, + 295, 296, 297, 298, 299, 300, 301, -1, 0, 58, + 59, -1, 41, -1, -1, 44, 59, 259, 61, 261, + 262, 263, -1, -1, 124, -1, -1, -1, 270, 271, + 59, -1, 274, 275, -1, -1, 270, -1, 168, -1, + 170, -1, -1, -1, 93, -1, -1, -1, 91, 41, + -1, 293, 44, 295, 296, 297, 298, 299, 300, 301, + -1, 0, -1, -1, 93, -1, 58, 59, 266, 267, + 268, -1, 270, -1, 259, 124, 261, 262, 263, -1, + -1, 124, -1, -1, -1, 270, 271, 265, 266, 274, + 275, -1, 270, 291, 292, 124, 294, -1, -1, -1, + -1, 93, 41, -1, -1, 44, -1, 0, 293, -1, + 295, 296, 297, 298, 299, 300, 301, -1, -1, 259, + 59, 261, 262, 263, 40, -1, -1, 43, 44, -1, + 270, 271, 124, -1, 274, 0, -1, 265, 266, 267, + 268, -1, 58, -1, -1, 61, -1, -1, 41, -1, + -1, 44, -1, 293, 93, 295, 296, 297, 298, 259, + 0, 261, 262, 263, -1, -1, 59, -1, -1, -1, + 270, 271, -1, -1, 274, 91, 41, -1, 33, 44, + -1, -1, -1, 38, -1, 124, 41, 42, 43, 44, + 45, 46, 47, 293, 59, 295, 296, 297, 298, 0, + 93, 41, -1, 58, 44, 60, 61, 62, -1, -1, + 259, -1, 261, 262, 263, -1, -1, -1, -1, 59, + -1, 270, 271, -1, -1, 274, -1, 270, 93, -1, + 259, 124, 261, -1, 263, -1, -1, -1, -1, 94, + 41, 270, 271, 44, 293, 274, 295, 296, 297, 298, + -1, -1, -1, 93, -1, 284, -1, -1, 59, 124, + -1, -1, -1, -1, 293, -1, 312, 259, 297, 261, + 262, 263, -1, 319, -1, -1, -1, 323, 270, 271, + -1, 33, 274, 35, 124, -1, 38, -1, 40, -1, + 42, 43, 93, 45, 46, 47, -1, 45, -1, -1, + -1, 293, -1, 295, 296, 297, 58, -1, 60, 61, + 62, 59, -1, 61, -1, -1, -1, 363, -1, -1, + 259, -1, 261, 124, 263, 371, -1, -1, -1, -1, + -1, 270, 271, -1, -1, 274, -1, -1, -1, 91, + -1, 93, 94, 91, -1, 284, 94, 263, 264, -1, + 266, 267, 268, -1, 293, -1, -1, -1, 297, 275, + -1, -1, -1, -1, -1, -1, 259, -1, 261, -1, + 263, -1, -1, -1, 126, 123, 124, 270, 271, 425, + -1, 274, -1, -1, -1, -1, -1, -1, 304, 305, + -1, 284, -1, -1, 259, -1, 261, 262, 263, -1, + 293, -1, -1, -1, 297, 270, 271, -1, -1, 274, + -1, -1, -1, -1, -1, -1, -1, 463, -1, 259, + 275, 261, 262, 263, -1, -1, -1, -1, 293, 284, + 270, 271, 297, -1, 274, -1, -1, -1, -1, -1, + 295, 296, -1, 298, 299, 300, 301, 302, 303, 45, + -1, -1, -1, 293, -1, -1, -1, 297, 259, -1, + 261, 262, 263, 59, -1, 61, -1, -1, -1, 270, + 271, -1, 33, 274, 35, -1, -1, 38, -1, 40, + 41, 42, 43, -1, 45, 46, 47, -1, -1, -1, + -1, -1, 293, -1, -1, 91, 297, 58, 94, 60, + 61, 62, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 266, 267, 268, 269, 266, -1, + 268, -1, 270, 275, -1, -1, -1, 123, 124, 281, + 91, -1, -1, 94, -1, -1, -1, 289, -1, 287, + -1, -1, -1, 295, 296, -1, 298, 299, 300, 301, + 302, 303, 304, 305, 33, -1, 35, -1, -1, 38, + -1, 40, -1, 42, 43, 126, 45, 46, 47, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, + -1, 60, 61, 62, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 33, -1, 35, -1, -1, 38, + -1, 40, -1, 42, 43, -1, 45, 46, 47, -1, + 45, -1, 91, -1, 93, 94, -1, -1, -1, 58, + -1, 60, 61, 62, 59, -1, 61, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 33, -1, 35, -1, + -1, 38, -1, 40, -1, 42, 43, 126, 45, 46, + 47, -1, 91, -1, 93, 94, 91, -1, -1, 94, + -1, 58, -1, 60, 61, 62, -1, -1, -1, -1, + 266, 33, 268, -1, 270, -1, 38, -1, -1, 41, + 42, 43, 44, 45, 46, 47, -1, 126, 123, 124, + 125, 287, -1, -1, 91, -1, 58, 94, 60, 61, + 62, -1, -1, -1, -1, 266, 267, 268, 269, -1, + -1, -1, -1, -1, 275, -1, -1, -1, -1, -1, + 281, -1, -1, -1, -1, -1, -1, -1, 289, 126, + -1, -1, 94, -1, 295, 296, -1, 298, 299, 300, + 301, 302, 303, 304, 305, 33, -1, 35, -1, -1, + 38, -1, 40, -1, 42, 43, -1, 45, 46, 47, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 58, -1, 60, 61, 62, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 266, 267, 268, + 269, -1, -1, -1, -1, -1, 275, -1, -1, -1, + -1, -1, 281, 91, -1, -1, 94, -1, -1, -1, + 289, -1, -1, -1, -1, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, 304, 305, 266, 267, 268, + 269, 266, -1, 268, -1, 270, 275, -1, 126, -1, + -1, -1, 281, -1, -1, -1, -1, -1, -1, -1, + 289, -1, 287, -1, -1, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, 304, 305, 33, -1, 266, + 267, 268, 269, -1, -1, -1, 42, 43, 275, 45, + 46, 47, -1, -1, 281, -1, -1, 284, -1, -1, + -1, -1, 289, -1, 60, 61, 62, -1, 295, 296, + -1, 298, 299, 300, 301, 302, 303, 304, 305, -1, + -1, -1, -1, 275, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 94, -1, + -1, -1, -1, 295, 296, -1, 298, 299, 300, 301, + 302, 303, 33, -1, -1, -1, -1, 38, 33, -1, + 41, 42, 43, 44, 45, 46, 47, 42, 43, -1, + 45, 46, 47, -1, -1, -1, -1, 58, -1, 60, + 61, 62, -1, -1, -1, 60, 61, 62, 266, 267, + 268, 269, -1, -1, -1, -1, 58, 275, -1, 61, + -1, -1, -1, 281, -1, -1, -1, -1, -1, -1, + -1, 289, -1, 94, -1, -1, -1, 295, 296, 94, + 298, 299, 300, 301, 302, 303, 304, 305, 33, -1, + -1, -1, -1, 38, -1, -1, 41, 42, 43, 44, + 45, 46, 47, -1, -1, -1, -1, -1, 110, -1, + -1, -1, -1, 58, 116, 60, 61, 62, -1, -1, + 122, -1, -1, -1, -1, -1, -1, -1, 130, 131, + 132, 133, 134, 38, -1, -1, 41, 42, 43, 44, + 45, 46, 47, -1, -1, -1, -1, -1, -1, 94, + -1, -1, -1, 58, -1, 60, 61, 62, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 38, 275, + -1, 41, 184, 43, 44, 45, 188, -1, -1, 94, + -1, -1, 194, 195, 196, 197, 198, -1, 58, -1, + 60, 61, 62, 299, 300, 301, 302, 303, 38, -1, + -1, 41, 42, 43, 44, 45, 46, 47, 38, -1, + -1, 41, 42, 43, 44, 45, -1, 47, 58, -1, + 60, 61, 62, -1, -1, -1, -1, -1, 58, -1, + 60, 61, 62, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 275, -1, -1, -1, -1, -1, + 275, -1, -1, -1, 94, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 295, 296, -1, 298, 299, 300, + 301, 302, 303, -1, 299, 300, 301, 302, 303, 38, + -1, -1, 41, 42, 43, 44, 45, -1, 47, 38, + -1, -1, 41, 42, 43, 44, 45, -1, 47, 58, + -1, 60, 61, 62, -1, -1, -1, -1, -1, 58, + -1, 60, 61, 62, 326, 327, -1, -1, -1, -1, + 275, -1, -1, -1, -1, -1, -1, -1, -1, 38, + -1, -1, 41, 42, 43, 44, 45, -1, 47, -1, + 295, 296, -1, 298, 299, 300, 301, 302, 303, 58, + -1, 60, 61, 62, -1, -1, -1, -1, -1, -1, + 275, -1, -1, -1, -1, -1, -1, -1, -1, 38, + -1, -1, 41, 42, 43, 44, 45, -1, 47, -1, + 295, 296, -1, 298, 299, 300, 301, 302, 303, 58, + -1, 60, 61, 62, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 275, -1, -1, -1, -1, + -1, -1, -1, 40, 38, 42, -1, 41, 45, 43, + 44, 45, -1, -1, -1, 295, 296, -1, 298, 299, + 300, 301, -1, -1, 58, 275, 60, 61, 62, -1, + -1, -1, -1, -1, -1, 275, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 295, 296, -1, 298, 299, + 300, 301, 302, 303, 91, 295, 296, -1, 298, 299, + 300, 301, 302, 303, 38, -1, -1, 41, -1, 43, + 44, 45, 38, -1, -1, 41, -1, -1, 44, 38, + -1, -1, 41, -1, 58, 44, 60, 61, 62, -1, + -1, -1, 58, -1, 60, 61, 62, -1, -1, 58, + -1, 60, 61, 62, -1, -1, 275, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 275, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, -1, 40, 259, 42, -1, + -1, 45, -1, -1, -1, -1, 275, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 275, 91, -1, -1, + -1, -1, 314, 315, -1, -1, -1, -1, -1, -1, + -1, -1, 324, -1, -1, -1, 295, 296, -1, 298, + 299, 300, 301, 302, 303, -1, -1, -1, 265, 266, + 267, 268, -1, 345, -1, 272, -1, -1, -1, 276, + 277, 275, -1, -1, -1, -1, -1, 359, -1, -1, + -1, 363, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 295, 296, -1, 298, 299, 300, 301, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 48, + -1, 275, 414, -1, 416, -1, -1, -1, -1, 275, + 59, -1, 61, -1, -1, -1, 275, -1, -1, -1, + -1, 295, 296, -1, 298, 299, 300, 301, -1, 295, + 296, -1, 298, 299, 300, 301, 295, 296, -1, 298, + 299, 300, 301, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 107, 108, + -1, -1, 256, 257, 258, -1, 115, -1, 117, -1, + 482, 265, 266, 267, 268, 487, -1, -1, 272, -1, + -1, -1, 276, 277, -1, -1, 135, 136, 137, 138, + 139, 140, 141, 142, 143, 144, 145, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 200, 201, 202, 203, 204, 205, 206, 207, 208, + 209, 210, +}; +#define YYFINAL 15 +#ifndef YYDEBUG +#define YYDEBUG 0 +#endif +#define YYMAXTOKEN 306 +#define YYUNDFTOKEN 417 +#define YYTRANSLATE(a) ((a) > YYMAXTOKEN ? YYUNDFTOKEN : (a)) +#if YYDEBUG +static const char *const yyname[] = { + +"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +"'!'",0,"'#'",0,0,"'&'",0,"'('","')'","'*'","'+'","','","'-'","'.'","'/'",0,0,0, +0,0,0,0,0,0,0,"':'","';'","'<'","'='","'>'","'?'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,"'['",0,"']'","'^'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,"'{'","'|'","'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"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","ARROW","PLUSPLUS","MINUSMINUS","DOTDOT","VEL","GE","NE","LE","REM", +"DIV","INFIXNAME","INFIXCNAME","CMBASE",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,"illegal-symbol", +}; +static const char *const yyrule[] = { +"$accept : entity", +"entity : error", +"entity : script", +"entity : VALUE exp", +"entity : EVAL exp", +"entity : EVAL exp COLONCOLON", +"entity : EVAL exp TO", +"script :", +"script : defs", +"exp : op", +"exp : e1", +"op : '~'", +"op : '#'", +"op : diop", +"diop : '-'", +"diop : diop1", +"diop1 : '+'", +"diop1 : PLUSPLUS", +"diop1 : ':'", +"diop1 : MINUSMINUS", +"diop1 : VEL", +"diop1 : '&'", +"diop1 : relop", +"diop1 : '*'", +"diop1 : '/'", +"diop1 : DIV", +"diop1 : REM", +"diop1 : '^'", +"diop1 : '.'", +"diop1 : '!'", +"diop1 : INFIXNAME", +"diop1 : INFIXCNAME", +"relop : '>'", +"relop : GE", +"relop : eqop", +"relop : NE", +"relop : LE", +"relop : '<'", +"eqop : EQEQ", +"eqop : '='", +"rhs : cases WHERE ldefs", +"rhs : exp WHERE ldefs", +"rhs : exp", +"rhs : cases", +"cases : exp ',' if exp", +"cases : exp ',' OTHERWISE", +"cases : cases reindent ELSEQ alt", +"alt : here exp", +"alt : here exp ',' if exp", +"alt : here exp ',' OTHERWISE", +"if :", +"if : IF", +"indent :", +"outdent : separator", +"separator : OFFSIDE", +"separator : ';'", +"reindent :", +"liste : exp", +"liste : liste ',' exp", +"e1 : '~' e1", +"e1 : e1 PLUSPLUS e1", +"e1 : e1 ':' e1", +"e1 : e1 MINUSMINUS e1", +"e1 : e1 VEL e1", +"e1 : e1 '&' e1", +"e1 : reln", +"e1 : e2", +"es1 : '~' e1", +"es1 : e1 PLUSPLUS e1", +"es1 : e1 PLUSPLUS", +"es1 : e1 ':' e1", +"es1 : e1 ':'", +"es1 : e1 MINUSMINUS e1", +"es1 : e1 MINUSMINUS", +"es1 : e1 VEL e1", +"es1 : e1 VEL", +"es1 : e1 '&' e1", +"es1 : e1 '&'", +"es1 : relsn", +"es1 : es2", +"e2 : '-' e2", +"e2 : '#' e2", +"e2 : e2 '+' e2", +"e2 : e2 '-' e2", +"e2 : e2 '*' e2", +"e2 : e2 '/' e2", +"e2 : e2 DIV e2", +"e2 : e2 REM e2", +"e2 : e2 '^' e2", +"e2 : e2 '.' e2", +"e2 : e2 '!' e2", +"e2 : e3", +"es2 : '-' e2", +"es2 : '#' e2", +"es2 : e2 '+' e2", +"es2 : e2 '+'", +"es2 : e2 '-' e2", +"es2 : e2 '-'", +"es2 : e2 '*' e2", +"es2 : e2 '*'", +"es2 : e2 '/' e2", +"es2 : e2 '/'", +"es2 : e2 DIV e2", +"es2 : e2 DIV", +"es2 : e2 REM e2", +"es2 : e2 REM", +"es2 : e2 '^' e2", +"es2 : e2 '^'", +"es2 : e2 '.' e2", +"es2 : e2 '.'", +"es2 : e2 '!' e2", +"es2 : e2 '!'", +"es2 : es3", +"e3 : comb INFIXNAME e3", +"e3 : comb INFIXCNAME e3", +"e3 : comb", +"es3 : comb INFIXNAME e3", +"es3 : comb INFIXNAME", +"es3 : comb INFIXCNAME e3", +"es3 : comb INFIXCNAME", +"es3 : comb", +"comb : comb arg", +"comb : arg", +"reln : e2 relop e2", +"reln : reln relop e2", +"relsn : e2 relop e2", +"relsn : e2 relop", +"relsn : reln relop e2", +"$$1 :", +"arg : $$1 LEX lexrules ENDIR", +"arg : NAME", +"arg : CNAME", +"arg : CONST", +"arg : READVALSY", +"arg : SHOWSYM", +"arg : DOLLAR2", +"arg : '[' ']'", +"arg : '[' exp ']'", +"arg : '[' exp ',' exp ']'", +"arg : '[' exp ',' exp ',' liste ']'", +"arg : '[' exp DOTDOT exp ']'", +"arg : '[' exp DOTDOT ']'", +"arg : '[' exp ',' exp DOTDOT exp ']'", +"arg : '[' exp ',' exp DOTDOT ']'", +"arg : '[' exp '|' qualifiers ']'", +"arg : '[' exp DIAG qualifiers ']'", +"arg : '(' op ')'", +"arg : '(' es1 ')'", +"arg : '(' diop1 e1 ')'", +"arg : '(' ')'", +"arg : '(' exp ',' liste ')'", +"$$2 :", +"$$3 :", +"lexrules : lexrules lstart here re indent $$2 ARROW exp lpostfix $$3 outdent", +"lexrules : lexdefs", +"lstart :", +"lstart : '<' cnames '>'", +"cnames : CNAME", +"cnames : cnames CNAME", +"lpostfix :", +"lpostfix : LBEGIN CNAME", +"lpostfix : LBEGIN CONST", +"lexdefs : lexdefs LEXDEF indent '=' re outdent", +"lexdefs :", +"re : re1 '|' re", +"re : re1", +"re1 : lterm '/' lterm", +"re1 : lterm '/'", +"re1 : lterm", +"lterm : lfac lterm", +"lterm : lfac", +"lfac : lunit '*'", +"lfac : lunit '+'", +"lfac : lunit '?'", +"lfac : lunit", +"lunit : '(' re ')'", +"lunit : CONST", +"lunit : CHARCLASS", +"lunit : ANTICHARCLASS", +"lunit : '.'", +"lunit : name", +"name : NAME", +"name : CNAME", +"qualifiers : exp", +"qualifiers : generator", +"qualifiers : qualifiers ';' generator", +"qualifiers : qualifiers ';' exp", +"generator : e1 ',' generator", +"generator : generator1", +"generator1 : e1 LEFTARROW exp", +"generator1 : e1 LEFTARROW exp ',' exp DOTDOT", +"defs : def", +"defs : defs def", +"def : v act2 indent '=' here rhs outdent", +"def : spec", +"def : ABSTYPE here typeforms indent WITH lspecs outdent", +"def : typeform indent act1 here EQEQ type act2 outdent", +"def : typeform indent act1 here COLON2EQ construction act2 outdent", +"def : indent setexp EXPORT parts outdent", +"def : FREE here '{' specs '}'", +"def : INCLUDE bindings modifiers outdent", +"$$4 :", +"def : here BNF $$4 names outdent productions ENDIR", +"setexp : here", +"bindings :", +"bindings : '{' bindingseq '}'", +"bindingseq : bindingseq binding", +"bindingseq : binding", +"binding : NAME indent '=' exp outdent", +"binding : typeform indent act1 EQEQ type act2 outdent", +"modifiers :", +"modifiers : negmods", +"negmods : negmods negmod", +"negmods : negmod", +"negmod : NAME '/' NAME", +"negmod : CNAME '/' CNAME", +"negmod : '-' NAME", +"here :", +"act1 :", +"act2 :", +"ldefs : ldef", +"ldefs : ldefs ldef", +"ldef : spec", +"ldef : typeform here EQEQ", +"ldef : typeform here COLON2EQ", +"ldef : v act2 indent '=' here rhs outdent", +"vlist : v", +"vlist : vlist ',' v", +"v : v1", +"v : v1 ':' v", +"v1 : v1 '+' CONST", +"v1 : '-' CONST", +"v1 : v2 INFIXNAME v1", +"v1 : v2 INFIXCNAME v1", +"v1 : v2", +"v2 : v3", +"v2 : v2 v3", +"v3 : NAME", +"v3 : CNAME", +"v3 : CONST", +"v3 : '[' ']'", +"v3 : '[' vlist ']'", +"v3 : '(' ')'", +"v3 : '(' v ')'", +"v3 : '(' v ',' vlist ')'", +"type : type1", +"type : type ARROW type", +"type1 : type2 INFIXNAME type1", +"type1 : type2", +"type2 : tap", +"type2 : argtype", +"tap : NAME argtype", +"tap : tap argtype", +"argtype : NAME", +"argtype : typevar", +"argtype : '(' typelist ')'", +"argtype : '[' type ']'", +"argtype : '[' type ',' typel ']'", +"typelist :", +"typelist : type", +"typelist : type ',' typel", +"typel : type", +"typel : typel ',' type", +"parts : parts NAME", +"parts : parts '-' NAME", +"parts : parts PATHNAME", +"parts : parts '+'", +"parts : NAME", +"parts : '-' NAME", +"parts : PATHNAME", +"parts : '+'", +"specs : specs spec", +"specs : spec", +"spec : typeforms indent here COLONCOLON ttype outdent", +"lspecs : lspecs lspec", +"lspecs : lspec", +"$$5 :", +"lspec : namelist indent here $$5 COLONCOLON type outdent", +"namelist : NAME ',' namelist", +"namelist : NAME", +"typeforms : typeforms ',' typeform act2", +"typeforms : typeform act2", +"typeform : CNAME typevars", +"typeform : NAME typevars", +"typeform : typevar INFIXNAME typevar", +"typeform : typevar INFIXCNAME typevar", +"ttype : type", +"ttype : TYPE", +"typevar : '*'", +"typevar : TYPEVAR", +"typevars :", +"typevars : typevar typevars", +"construction : constructs", +"constructs : construct", +"constructs : constructs '|' construct", +"construct : field here INFIXCNAME field", +"construct : construct1", +"construct1 : '(' construct ')'", +"construct1 : construct1 field1", +"construct1 : here CNAME", +"field : type", +"field : argtype '!'", +"field1 : argtype '!'", +"field1 : argtype", +"names :", +"names : names NAME", +"productions : lspec", +"productions : production", +"productions : productions lspec", +"productions : productions production", +"production : NAME params ':' indent grhs outdent", +"params :", +"$$6 :", +"params : $$6 '(' names ')'", +"grhs : here phrase", +"phrase : error_term", +"phrase : phrase1", +"phrase : phrase1 '|' error_term", +"phrase1 : term", +"phrase1 : phrase1 '|' here term", +"term : count_factors", +"$$7 :", +"term : count_factors $$7 indent '=' here rhs outdent", +"error_term : ERRORSY", +"$$8 :", +"error_term : ERRORSY $$8 indent '=' here rhs outdent", +"count_factors : EMPTYSY", +"count_factors : EMPTYSY factors", +"$$9 :", +"count_factors : $$9 factors", +"factors : factor", +"factors : factors factor", +"factor : unit", +"factor : '{' unit '}'", +"factor : '{' unit", +"factor : unit '}'", +"unit : symbol", +"unit : symbol '*'", +"unit : symbol '+'", +"unit : symbol '?'", +"symbol : NAME", +"symbol : ENDSY", +"symbol : CONST", +"symbol : '^'", +"$$10 :", +"$$11 :", +"symbol : $$10 '[' exp $$11 ']'", +"symbol : '-'", + +}; +#endif + +int yydebug; +int yynerrs; + +int yyerrflag; +int yychar; +YYSTYPE yyval; +YYSTYPE yylval; + +/* define the initial stack-sizes */ +#ifdef YYSTACKSIZE +#undef YYMAXDEPTH +#define YYMAXDEPTH YYSTACKSIZE +#else +#ifdef YYMAXDEPTH +#define YYSTACKSIZE YYMAXDEPTH +#else +#define YYSTACKSIZE 10000 +#define YYMAXDEPTH 10000 +#endif +#endif + +#define YYINITSTACKSIZE 200 + +typedef struct { + unsigned stacksize; + YYINT *s_base; + YYINT *s_mark; + YYINT *s_last; + YYSTYPE *l_base; + YYSTYPE *l_mark; +} YYSTACKDATA; +/* variables for the parser stack */ +static YYSTACKDATA yystack; +#line 1688 "rules.y" +/* end of Miranda rules */ + +#line 1757 "y.tab.c" + +#if YYDEBUG +#include <stdio.h> /* needed for printf */ +#endif + +#include <stdlib.h> /* needed for malloc, etc */ +#include <string.h> /* needed for memset */ + +/* allocate initial stack or double stack size, up to YYMAXDEPTH */ +static int yygrowstack(YYSTACKDATA *data) +{ + int i; + unsigned newsize; + YYINT *newss; + YYSTYPE *newvs; + + if ((newsize = data->stacksize) == 0) + newsize = YYINITSTACKSIZE; + else if (newsize >= YYMAXDEPTH) + return YYENOMEM; + else if ((newsize *= 2) > YYMAXDEPTH) + newsize = YYMAXDEPTH; + + i = (int) (data->s_mark - data->s_base); + newss = (YYINT *)realloc(data->s_base, newsize * sizeof(*newss)); + if (newss == 0) + return YYENOMEM; + + data->s_base = newss; + data->s_mark = newss + i; + + newvs = (YYSTYPE *)realloc(data->l_base, newsize * sizeof(*newvs)); + if (newvs == 0) + return YYENOMEM; + + data->l_base = newvs; + data->l_mark = newvs + i; + + data->stacksize = newsize; + data->s_last = data->s_base + newsize - 1; + return 0; +} + +#if YYPURE || defined(YY_NO_LEAKS) +static void yyfreestack(YYSTACKDATA *data) +{ + free(data->s_base); + free(data->l_base); + memset(data, 0, sizeof(*data)); +} +#else +#define yyfreestack(data) /* nothing */ +#endif + +#define YYABORT goto yyabort +#define YYREJECT goto yyabort +#define YYACCEPT goto yyaccept +#define YYERROR goto yyerrlab + +int +YYPARSE_DECL() +{ + int yym, yyn, yystate; +#if YYDEBUG + const char *yys; + + if ((yys = getenv("YYDEBUG")) != 0) + { + yyn = *yys; + if (yyn >= '0' && yyn <= '9') + yydebug = yyn - '0'; + } +#endif + + yynerrs = 0; + yyerrflag = 0; + yychar = YYEMPTY; + yystate = 0; + +#if YYPURE + memset(&yystack, 0, sizeof(yystack)); +#endif + + if (yystack.s_base == NULL && yygrowstack(&yystack) == YYENOMEM) goto yyoverflow; + yystack.s_mark = yystack.s_base; + yystack.l_mark = yystack.l_base; + yystate = 0; + *yystack.s_mark = 0; + +yyloop: + if ((yyn = yydefred[yystate]) != 0) goto yyreduce; + if (yychar < 0) + { + if ((yychar = YYLEX) < 0) yychar = YYEOF; +#if YYDEBUG + if (yydebug) + { + yys = yyname[YYTRANSLATE(yychar)]; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + } + if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, shifting to state %d\n", + YYPREFIX, yystate, yytable[yyn]); +#endif + if (yystack.s_mark >= yystack.s_last && yygrowstack(&yystack) == YYENOMEM) + { + goto yyoverflow; + } + yystate = yytable[yyn]; + *++yystack.s_mark = yytable[yyn]; + *++yystack.l_mark = yylval; + yychar = YYEMPTY; + if (yyerrflag > 0) --yyerrflag; + goto yyloop; + } + if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { + yyn = yytable[yyn]; + goto yyreduce; + } + if (yyerrflag) goto yyinrecovery; + + YYERROR_CALL("syntax error"); + + goto yyerrlab; + +yyerrlab: + ++yynerrs; + +yyinrecovery: + if (yyerrflag < 3) + { + yyerrflag = 3; + for (;;) + { + if ((yyn = yysindex[*yystack.s_mark]) && (yyn += YYERRCODE) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, error recovery shifting\ + to state %d\n", YYPREFIX, *yystack.s_mark, yytable[yyn]); +#endif + if (yystack.s_mark >= yystack.s_last && yygrowstack(&yystack) == YYENOMEM) + { + goto yyoverflow; + } + yystate = yytable[yyn]; + *++yystack.s_mark = yytable[yyn]; + *++yystack.l_mark = yylval; + goto yyloop; + } + else + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: error recovery discarding state %d\n", + YYPREFIX, *yystack.s_mark); +#endif + if (yystack.s_mark <= yystack.s_base) goto yyabort; + --yystack.s_mark; + --yystack.l_mark; + } + } + } + else + { + if (yychar == YYEOF) goto yyabort; +#if YYDEBUG + if (yydebug) + { + yys = yyname[YYTRANSLATE(yychar)]; + printf("%sdebug: state %d, error recovery discards token %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + yychar = YYEMPTY; + goto yyloop; + } + +yyreduce: +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, reducing by rule %d (%s)\n", + YYPREFIX, yystate, yyn, yyrule[yyn]); +#endif + yym = yylen[yyn]; + if (yym) + yyval = yystack.l_mark[1-yym]; + else + memset(&yyval, 0, sizeof yyval); + switch (yyn) + { +case 2: +#line 367 "rules.y" + { lastname=0; /* outstats(); */ } +break; +case 3: +#line 374 "rules.y" + { lastexp=yystack.l_mark[0]; } +break; +case 4: +#line 377 "rules.y" + { if(!SYNERR&&yychar==0) + { evaluate(yystack.l_mark[0]); } + } +break; +case 5: +#line 385 "rules.y" + { word t=type_of(yystack.l_mark[-1]); + if(t!=wrong_t) + { lastexp=yystack.l_mark[-1]; + if(tag[yystack.l_mark[-1]]==ID&&id_type(yystack.l_mark[-1])==wrong_t)t=wrong_t; + out_type(t); + putchar('\n'); } + } +break; +case 6: +#line 394 "rules.y" + { FILE *fil=NULL,*efil; + word t=type_of(yystack.l_mark[-1]); + char *f=token(),*ef; + if(f)keep(f); ef=token(); /* wasteful of dic space, FIX LATER */ + if(f){ fil= fopen(f,yystack.l_mark[0]?"a":"w"); + if(fil==NULL) + printf("cannot open \"%s\" for writing\n",f); } + else printf("filename missing after \"&>\"\n"); + if(ef) + { efil= fopen(ef,yystack.l_mark[0]?"a":"w"); + if(efil==NULL) + printf("cannot open \"%s\" for writing\n",ef); } + if(t!=wrong_t)yystack.l_mark[-1]=codegen(lastexp=yystack.l_mark[-1]); + if(!polyshowerror&&t!=wrong_t&&fil!=NULL&&(!ef||efil)) + { int 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)?yystack.l_mark[-1]: + cons(ap(standardout,isstring_t(t)?yystack.l_mark[-1]: + ap(mkshow(0,0,t),yystack.l_mark[-1])),NIL)); + putchar('\n'); + outstats(); + exit(0); } } } +break; +case 11: +#line 455 "rules.y" + { yyval = NOT; } +break; +case 12: +#line 457 "rules.y" + { yyval = LENGTH; } +break; +case 14: +#line 462 "rules.y" + { yyval = MINUS; } +break; +case 16: +#line 467 "rules.y" + { yyval = PLUS; } +break; +case 17: +#line 469 "rules.y" + { yyval = APPEND; } +break; +case 18: +#line 471 "rules.y" + { yyval = P; } +break; +case 19: +#line 473 "rules.y" + { yyval = listdiff_fn; } +break; +case 20: +#line 475 "rules.y" + { yyval = OR; } +break; +case 21: +#line 477 "rules.y" + { yyval = AND; } +break; +case 23: +#line 480 "rules.y" + { yyval = TIMES; } +break; +case 24: +#line 482 "rules.y" + { yyval = FDIV; } +break; +case 25: +#line 484 "rules.y" + { yyval = INTDIV; } +break; +case 26: +#line 486 "rules.y" + { yyval = MOD; } +break; +case 27: +#line 488 "rules.y" + { yyval = POWER; } +break; +case 28: +#line 490 "rules.y" + { yyval = B; } +break; +case 29: +#line 492 "rules.y" + { yyval = ap(C,SUBSCRIPT); } +break; +case 32: +#line 498 "rules.y" + { yyval = GR; } +break; +case 33: +#line 500 "rules.y" + { yyval = GRE; } +break; +case 34: +#line 502 "rules.y" + { yyval = EQ; } +break; +case 35: +#line 504 "rules.y" + { yyval = NEQ; } +break; +case 36: +#line 506 "rules.y" + { yyval = ap(C,GRE); } +break; +case 37: +#line 508 "rules.y" + { yyval = ap(C,GR); } +break; +case 40: +#line 516 "rules.y" + { yyval = block(yystack.l_mark[0],compose(yystack.l_mark[-2]),0); } +break; +case 41: +#line 518 "rules.y" + { yyval = block(yystack.l_mark[0],yystack.l_mark[-2],0); } +break; +case 43: +#line 521 "rules.y" + { yyval = compose(yystack.l_mark[0]); } +break; +case 44: +#line 525 "rules.y" + { yyval = cons(ap2(COND,yystack.l_mark[0],yystack.l_mark[-3]),NIL); } +break; +case 45: +#line 527 "rules.y" + { yyval = cons(ap(OTHERWISE,yystack.l_mark[-2]),NIL); } +break; +case 46: +#line 529 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-3]); + if(hd[hd[yystack.l_mark[-3]]]==OTHERWISE) + syntax("\"otherwise\" must be last case\n"); } +break; +case 47: +#line 535 "rules.y" + { errs=yystack.l_mark[-1], + syntax("obsolete syntax, \", otherwise\" missing\n"); + yyval = ap(OTHERWISE,label(yystack.l_mark[-1],yystack.l_mark[0])); } +break; +case 48: +#line 539 "rules.y" + { yyval = label(yystack.l_mark[-4],ap2(COND,yystack.l_mark[0],yystack.l_mark[-3])); } +break; +case 49: +#line 541 "rules.y" + { yyval = ap(OTHERWISE,label(yystack.l_mark[-3],yystack.l_mark[-2])); } +break; +case 50: +#line 545 "rules.y" + { extern word strictif; + if(strictif)syntax("\"if\" missing\n"); } +break; +case 52: +#line 551 "rules.y" + { if(!SYNERR){layout(); setlmargin();} + } +break; +case 53: +#line 559 "rules.y" + { unsetlmargin(); } +break; +case 56: +#line 566 "rules.y" + { if(!SYNERR) + { unsetlmargin(); layout(); setlmargin(); } + } +break; +case 57: +#line 572 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 58: +#line 574 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 59: +#line 578 "rules.y" + { yyval = ap(NOT,yystack.l_mark[0]); } +break; +case 60: +#line 580 "rules.y" + { yyval = ap2(APPEND,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 61: +#line 582 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 62: +#line 584 "rules.y" + { yyval = ap2(listdiff_fn,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 63: +#line 586 "rules.y" + { yyval = ap2(OR,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 64: +#line 588 "rules.y" + { yyval = ap2(AND,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 67: +#line 594 "rules.y" + { yyval = ap(NOT,yystack.l_mark[0]); } +break; +case 68: +#line 596 "rules.y" + { yyval = ap2(APPEND,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 69: +#line 598 "rules.y" + { yyval = ap(APPEND,yystack.l_mark[-1]); } +break; +case 70: +#line 600 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 71: +#line 602 "rules.y" + { yyval = ap(P,yystack.l_mark[-1]); } +break; +case 72: +#line 604 "rules.y" + { yyval = ap2(listdiff_fn,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 73: +#line 606 "rules.y" + { yyval = ap(listdiff_fn,yystack.l_mark[-1]); } +break; +case 74: +#line 608 "rules.y" + { yyval = ap2(OR,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 75: +#line 610 "rules.y" + { yyval = ap(OR,yystack.l_mark[-1]); } +break; +case 76: +#line 612 "rules.y" + { yyval = ap2(AND,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 77: +#line 614 "rules.y" + { yyval = ap(AND,yystack.l_mark[-1]); } +break; +case 80: +#line 620 "rules.y" + { yyval = ap(NEG,yystack.l_mark[0]); } +break; +case 81: +#line 622 "rules.y" + { yyval = ap(LENGTH,yystack.l_mark[0]); } +break; +case 82: +#line 624 "rules.y" + { yyval = ap2(PLUS,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 83: +#line 626 "rules.y" + { yyval = ap2(MINUS,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 84: +#line 628 "rules.y" + { yyval = ap2(TIMES,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 85: +#line 630 "rules.y" + { yyval = ap2(FDIV,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 86: +#line 632 "rules.y" + { yyval = ap2(INTDIV,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 87: +#line 634 "rules.y" + { yyval = ap2(MOD,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 88: +#line 636 "rules.y" + { yyval = ap2(POWER,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 89: +#line 638 "rules.y" + { yyval = ap2(B,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 90: +#line 640 "rules.y" + { yyval = ap2(SUBSCRIPT,yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 92: +#line 645 "rules.y" + { yyval = ap(NEG,yystack.l_mark[0]); } +break; +case 93: +#line 647 "rules.y" + { yyval = ap(LENGTH,yystack.l_mark[0]); } +break; +case 94: +#line 649 "rules.y" + { yyval = ap2(PLUS,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 95: +#line 651 "rules.y" + { yyval = ap(PLUS,yystack.l_mark[-1]); } +break; +case 96: +#line 653 "rules.y" + { yyval = ap2(MINUS,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 97: +#line 655 "rules.y" + { yyval = ap(MINUS,yystack.l_mark[-1]); } +break; +case 98: +#line 657 "rules.y" + { yyval = ap2(TIMES,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 99: +#line 659 "rules.y" + { yyval = ap(TIMES,yystack.l_mark[-1]); } +break; +case 100: +#line 661 "rules.y" + { yyval = ap2(FDIV,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 101: +#line 663 "rules.y" + { yyval = ap(FDIV,yystack.l_mark[-1]); } +break; +case 102: +#line 665 "rules.y" + { yyval = ap2(INTDIV,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 103: +#line 667 "rules.y" + { yyval = ap(INTDIV,yystack.l_mark[-1]); } +break; +case 104: +#line 669 "rules.y" + { yyval = ap2(MOD,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 105: +#line 671 "rules.y" + { yyval = ap(MOD,yystack.l_mark[-1]); } +break; +case 106: +#line 673 "rules.y" + { yyval = ap2(POWER,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 107: +#line 675 "rules.y" + { yyval = ap(POWER,yystack.l_mark[-1]); } +break; +case 108: +#line 677 "rules.y" + { yyval = ap2(B,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 109: +#line 679 "rules.y" + { yyval = ap(B,yystack.l_mark[-1]); } +break; +case 110: +#line 681 "rules.y" + { yyval = ap2(SUBSCRIPT,yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 111: +#line 683 "rules.y" + { yyval = ap2(C,SUBSCRIPT,yystack.l_mark[-1]); } +break; +case 113: +#line 688 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 114: +#line 690 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 116: +#line 695 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 117: +#line 697 "rules.y" + { yyval = ap(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 118: +#line 699 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 119: +#line 701 "rules.y" + { yyval = ap(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 121: +#line 706 "rules.y" + { yyval = ap(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 123: +#line 711 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 124: +#line 713 "rules.y" + { word subject; + subject = hd[hd[yystack.l_mark[-2]]]==AND?tl[tl[yystack.l_mark[-2]]]:tl[yystack.l_mark[-2]]; + yyval = ap2(AND,yystack.l_mark[-2],ap2(yystack.l_mark[-1],subject,yystack.l_mark[0])); + } +break; +case 125: +#line 721 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 126: +#line 723 "rules.y" + { yyval = ap(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 127: +#line 725 "rules.y" + { word subject; + subject = hd[hd[yystack.l_mark[-2]]]==AND?tl[tl[yystack.l_mark[-2]]]:tl[yystack.l_mark[-2]]; + yyval = ap2(AND,yystack.l_mark[-2],ap2(yystack.l_mark[-1],subject,yystack.l_mark[0])); + } +break; +case 128: +#line 732 "rules.y" + { if(!SYNERR)lexstates=NIL,inlex=1; } +break; +case 129: +#line 734 "rules.y" + { 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(yystack.l_mark[-1]==NIL)syntax("%lex with no rules\n"); + else tag[yystack.l_mark[-1]]=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) + */ + yyval = yystack.l_mark[-1]; } +break; +case 133: +#line 758 "rules.y" + { yyval = readvals(0,0); } +break; +case 134: +#line 760 "rules.y" + { yyval = show(0,0); } +break; +case 135: +#line 762 "rules.y" + { yyval = lastexp; + if(lastexp==UNDEF) + syntax("no previous expression to substitute for $$\n"); } +break; +case 136: +#line 766 "rules.y" + { yyval = NIL; } +break; +case 137: +#line 768 "rules.y" + { yyval = cons(yystack.l_mark[-1],NIL); } +break; +case 138: +#line 770 "rules.y" + { yyval = cons(yystack.l_mark[-3],cons(yystack.l_mark[-1],NIL)); } +break; +case 139: +#line 772 "rules.y" + { yyval = cons(yystack.l_mark[-5],cons(yystack.l_mark[-3],reverse(yystack.l_mark[-1]))); } +break; +case 140: +#line 774 "rules.y" + { yyval = ap3(STEPUNTIL,big_one,yystack.l_mark[-1],yystack.l_mark[-3]); } +break; +case 141: +#line 776 "rules.y" + { yyval = ap2(STEP,big_one,yystack.l_mark[-2]); } +break; +case 142: +#line 778 "rules.y" + { yyval = ap3(STEPUNTIL,ap2(MINUS,yystack.l_mark[-3],yystack.l_mark[-5]),yystack.l_mark[-1],yystack.l_mark[-5]); } +break; +case 143: +#line 780 "rules.y" + { yyval = ap2(STEP,ap2(MINUS,yystack.l_mark[-2],yystack.l_mark[-4]),yystack.l_mark[-4]); } +break; +case 144: +#line 782 "rules.y" + { yyval = SYNERR?NIL:compzf(yystack.l_mark[-3],yystack.l_mark[-1],0); } +break; +case 145: +#line 784 "rules.y" + { yyval = SYNERR?NIL:compzf(yystack.l_mark[-3],yystack.l_mark[-1],1); } +break; +case 146: +#line 786 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 147: +#line 788 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 148: +#line 790 "rules.y" + { yyval = (tag[yystack.l_mark[-2]]==AP&&hd[yystack.l_mark[-2]]==C)?ap(tl[yystack.l_mark[-2]],yystack.l_mark[-1]): /* optimisation */ + ap2(C,yystack.l_mark[-2],yystack.l_mark[-1]); } +break; +case 149: +#line 793 "rules.y" + { yyval = Void; } +break; +case 150: +#line 795 "rules.y" + { if(tl[yystack.l_mark[-1]]==NIL)yyval=pair(yystack.l_mark[-3],hd[yystack.l_mark[-1]]); + else { yyval=pair(hd[tl[yystack.l_mark[-1]]],hd[yystack.l_mark[-1]]); + yystack.l_mark[-1]=tl[tl[yystack.l_mark[-1]]]; + while(yystack.l_mark[-1]!=NIL)yyval=tcons(hd[yystack.l_mark[-1]],yyval),yystack.l_mark[-1]=tl[yystack.l_mark[-1]]; + yyval = tcons(yystack.l_mark[-3],yyval); } + /* representation of the tuple (a1,...,an) is + tcons(a1,tcons(a2,...pair(a(n-1),an))) */ + } +break; +case 151: +#line 805 "rules.y" + { if(!SYNERR)inlex=2; } +break; +case 152: +#line 806 "rules.y" + { if(!SYNERR)inlex=1; } +break; +case 153: +#line 807 "rules.y" + { if(yystack.l_mark[-2]<0 && e_re(yystack.l_mark[-7])) + errs=yystack.l_mark[-8], + syntax("illegal lex rule - lhs matches empty\n"); + yyval = cons(cons(cons(yystack.l_mark[-9],1+yystack.l_mark[-2]),cons(yystack.l_mark[-7],label(yystack.l_mark[-8],yystack.l_mark[-3]))),yystack.l_mark[-10]); } +break; +case 154: +#line 812 "rules.y" + { yyval = NIL; } +break; +case 155: +#line 816 "rules.y" + { yyval = 0; } +break; +case 156: +#line 818 "rules.y" + { word ns=NIL; + for(;yystack.l_mark[-1]!=NIL;yystack.l_mark[-1]=tl[yystack.l_mark[-1]]) + { word *x = &lexstates,i=1; + while(*x!=NIL&&hd[hd[*x]]!=hd[yystack.l_mark[-1]])i++,x = &tl[*x]; + if(*x == NIL)*x = cons(cons(hd[yystack.l_mark[-1]],2),NIL); + else tl[hd[*x]] |= 2; + ns = add1(i,ns); } + yyval = ns; } +break; +case 157: +#line 829 "rules.y" + { yyval=cons(yystack.l_mark[0],NIL); } +break; +case 158: +#line 831 "rules.y" + { if(member(yystack.l_mark[-1],yystack.l_mark[0])) + printf("%ssyntax error: repeated name \"%s\" in start conditions\n", + echoing?"\n":"",get_id(yystack.l_mark[0])), + acterror(); + yyval = cons(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 159: +#line 839 "rules.y" + { yyval = -1; } +break; +case 160: +#line 841 "rules.y" + { word *x = &lexstates,i=1; + while(*x!=NIL&&hd[hd[*x]]!=yystack.l_mark[0])i++,x = &tl[*x]; + if(*x == NIL)*x = cons(cons(yystack.l_mark[0],1),NIL); + else tl[hd[*x]] |= 1; + yyval = i; + } +break; +case 161: +#line 848 "rules.y" + { if(!isnat(yystack.l_mark[0])||get_int(yystack.l_mark[0])!=0) + syntax("%begin not followed by IDENTIFIER or 0\n"); + yyval = 0; } +break; +case 162: +#line 854 "rules.y" + { lexdefs = cons(cons(yystack.l_mark[-4],yystack.l_mark[-1]),lexdefs); } +break; +case 163: +#line 856 "rules.y" + { lexdefs = NIL; } +break; +case 164: +#line 860 "rules.y" + { yyval = ap2(LEX_OR,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 166: +#line 865 "rules.y" + { yyval = ap2(LEX_RCONTEXT,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 167: +#line 867 "rules.y" + { yyval = ap2(LEX_RCONTEXT,yystack.l_mark[-1],0); } +break; +case 169: +#line 872 "rules.y" + { yyval = ap2(LEX_SEQ,yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 171: +#line 877 "rules.y" + { if(e_re(yystack.l_mark[-1])) + syntax("illegal regular expression - arg of * matches empty\n"); + yyval = ap(LEX_STAR,yystack.l_mark[-1]); } +break; +case 172: +#line 881 "rules.y" + { yyval = ap2(LEX_SEQ,yystack.l_mark[-1],ap(LEX_STAR,yystack.l_mark[-1])); } +break; +case 173: +#line 883 "rules.y" + { yyval = ap(LEX_OPT,yystack.l_mark[-1]); } +break; +case 175: +#line 888 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 176: +#line 890 "rules.y" + { if(!isstring(yystack.l_mark[0])) + printf("%ssyntax error - unexpected token \"", + echoing?"\n":""), + out(stdout,yystack.l_mark[0]),printf("\" in regular expression\n"), + acterror(); + yyval = yystack.l_mark[0]==NILS?ap(LEX_STRING,NIL): + tl[yystack.l_mark[0]]==NIL?ap(LEX_CHAR,hd[yystack.l_mark[0]]): + ap(LEX_STRING,yystack.l_mark[0]); + } +break; +case 177: +#line 900 "rules.y" + { if(yystack.l_mark[0]==NIL) + syntax("empty character class `` cannot match\n"); + yyval = tl[yystack.l_mark[0]]==NIL?ap(LEX_CHAR,hd[yystack.l_mark[0]]):ap(LEX_CLASS,yystack.l_mark[0]); } +break; +case 178: +#line 904 "rules.y" + { yyval = ap(LEX_CLASS,cons(ANTICHARCLASS,yystack.l_mark[0])); } +break; +case 179: +#line 906 "rules.y" + { yyval = LEX_DOT; } +break; +case 180: +#line 908 "rules.y" + { word x=lexdefs; + while(x!=NIL&&hd[hd[x]]!=yystack.l_mark[0])x=tl[x]; + if(x==NIL) + printf( + "%ssyntax error: undefined lexeme %s in regular expression\n", + echoing?"\n":"", + get_id(yystack.l_mark[0])), + acterror(); + else yyval = tl[hd[x]]; } +break; +case 183: +#line 922 "rules.y" + { yyval = cons(cons(GUARD,yystack.l_mark[0]),NIL); } +break; +case 184: +#line 924 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 185: +#line 926 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 186: +#line 928 "rules.y" + { yyval = cons(cons(GUARD,yystack.l_mark[0]),yystack.l_mark[-2]); } +break; +case 187: +#line 932 "rules.y" + { /* fix syntax to disallow patlist on lhs of iterate generator */ + if(hd[yystack.l_mark[0]]==GENERATOR) + { word e=tl[tl[yystack.l_mark[0]]]; + if(tag[e]==AP&&tag[hd[e]]==AP&& + (hd[hd[e]]==ITERATE||hd[hd[e]]==ITERATE1)) + syntax("ill-formed generator\n"); } + yyval = cons(REPEAT,cons(genlhs(yystack.l_mark[-2]),yystack.l_mark[0])); idsused=NIL; } +break; +case 189: +#line 943 "rules.y" + { yyval = cons(GENERATOR,cons(genlhs(yystack.l_mark[-2]),yystack.l_mark[0])); idsused=NIL; } +break; +case 190: +#line 945 "rules.y" + { word p = genlhs(yystack.l_mark[-5]); idsused=NIL; + yyval = cons(GENERATOR, + cons(p,ap2(irrefutable(p)?ITERATE:ITERATE1, + lambda(p,yystack.l_mark[-1]),yystack.l_mark[-3]))); + } +break; +case 193: +#line 957 "rules.y" + { word l = yystack.l_mark[-6], r = yystack.l_mark[-1]; + 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(yystack.l_mark[-2],r); /* to help locate type errors */ + declare(l,r),lastname=l; } +break; +case 194: +#line 965 "rules.y" + { word h=reverse(hd[yystack.l_mark[0]]),hr=hd[tl[yystack.l_mark[0]]],t=tl[tl[yystack.l_mark[0]]]; + while(h!=NIL&&!SYNERR)specify(hd[h],t,hr),h=tl[h]; + yyval = cons(nill,NIL); } +break; +case 195: +#line 970 "rules.y" + { extern word TABSTRS; + extern char *dicp,*dicq; + word x=reverse(yystack.l_mark[-1]),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(yystack.l_mark[-4]); + while(x!=NIL&&!SYNERR) + { word shfn; + decltype(hd[x],abstract_t,undef_t,yystack.l_mark[-5]); + 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); + yyval = cons(nill,NIL); } +break; +case 196: +#line 995 "rules.y" + { word x=redtvars(ap(yystack.l_mark[-7],yystack.l_mark[-2])); + decltype(hd[x],synonym_t,tl[x],yystack.l_mark[-4]); + yyval = cons(nill,NIL); } +break; +case 197: +#line 1000 "rules.y" + { word rhs = yystack.l_mark[-2], r_ids = yystack.l_mark[-2], n=0; + while(r_ids!=NIL)r_ids=tl[r_ids],n++; + while(rhs!=NIL&&!SYNERR) + { word h=hd[rhs],t=yystack.l_mark[-7],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(yystack.l_mark[-7],algebraic_t,r_ids,yystack.l_mark[-4]); + yyval = cons(nill,NIL); } +break; +case 198: +#line 1030 "rules.y" + { inexplist=0; + if(exports!=NIL) + errs=yystack.l_mark[-3], + syntax("multiple %export statements are illegal\n"); + else { if(yystack.l_mark[-1]==NIL&&exportfiles==NIL&&embargoes!=NIL) + exportfiles=cons(PLUS,NIL); + exports=cons(yystack.l_mark[-3],yystack.l_mark[-1]); } /* cons(hereinfo,identifiers) */ + yyval = cons(nill,NIL); } +break; +case 199: +#line 1040 "rules.y" + { if(freeids!=NIL) + errs=yystack.l_mark[-3], + syntax("multiple %free statements are illegal\n"); else + { word x=reverse(yystack.l_mark[-1]); + 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)) */ + } + yyval = cons(nill,NIL); } +break; +case 200: +#line 1063 "rules.y" + { extern char *dicp; + extern word CLASHES,BAD_DUMP; + includees=cons(cons(yystack.l_mark[-3],cons(yystack.l_mark[-1],yystack.l_mark[-2])),includees); + /* $1 contains file+hereinfo */ + yyval = cons(nill,NIL); } +break; +case 201: +#line 1069 "rules.y" + { startbnf(); inbnf=1;} +break; +case 202: +#line 1071 "rules.y" + { word lhs=NIL,p=yystack.l_mark[-1],subjects,body,startswith=NIL,leftrecs=NIL; + ihlist=inbnf=0; + nonterminals=UNION(nonterminals,yystack.l_mark[-3]); + 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=yystack.l_mark[-6], + member(yystack.l_mark[-3],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=yystack.l_mark[-1];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=yystack.l_mark[-1];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],yystack.l_mark[-1]), + printf("%sfatal error in grammar, ",echoing?"\n":""), + printlist("irremovable left recursion: ",leftrecs), + acterror(); + if(yystack.l_mark[-3]==NIL) /* implied start symbol */ + yystack.l_mark[-3]=cons(dlhs(hd[lastlink(yystack.l_mark[-1])]),NIL); + fnts=1; /* fnts is flag indicating %bnf in use */ + if(tl[yystack.l_mark[-3]]==NIL) /* only one start symbol */ + subjects=getfname(hd[yystack.l_mark[-3]]), + body=ap2(G_CLOSE,str_conv(get_id(hd[yystack.l_mark[-3]])),hd[yystack.l_mark[-3]]); + else + { body=subjects=Void; + while(yystack.l_mark[-3]!=NIL) + subjects=pair(getfname(hd[yystack.l_mark[-3]]),subjects), + body=pair( + ap2(G_CLOSE,str_conv(get_id(hd[yystack.l_mark[-3]])),hd[yystack.l_mark[-3]]), + body), + yystack.l_mark[-3]=tl[yystack.l_mark[-3]]; + } + declare(subjects,label(yystack.l_mark[-6],block(yystack.l_mark[-1],body, 0))); + }} +break; +case 203: +#line 1129 "rules.y" + { yyval=yystack.l_mark[0]; + inexplist=1; } +break; +case 204: +#line 1134 "rules.y" + { yyval = NIL; } +break; +case 205: +#line 1136 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 206: +#line 1140 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 207: +#line 1142 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 208: +#line 1146 "rules.y" + { yyval = cons(yystack.l_mark[-4],yystack.l_mark[-1]); } +break; +case 209: +#line 1148 "rules.y" + { word x=redtvars(ap(yystack.l_mark[-6],yystack.l_mark[-2])); + word arity=0,h=hd[x]; + while(tag[h]==AP)arity++,h=hd[h]; + yyval = ap(h,make_typ(arity,0,synonym_t,tl[x])); + } +break; +case 210: +#line 1156 "rules.y" + { yyval = NIL; } +break; +case 211: +#line 1158 "rules.y" + { word a,b,c=0; + for(a=yystack.l_mark[0];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(); + } +break; +case 212: +#line 1173 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 213: +#line 1175 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 214: +#line 1179 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 215: +#line 1181 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 216: +#line 1183 "rules.y" + { yyval = cons(make_pn(UNDEF),yystack.l_mark[0]); } +break; +case 217: +#line 1188 "rules.y" + { extern word line_no; + lasth = yyval = fileinfo(get_fil(current_file),line_no); + /* (script,line_no) for diagnostics */ + } +break; +case 218: +#line 1195 "rules.y" + { tvarscope=1; } +break; +case 219: +#line 1199 "rules.y" + { tvarscope=0; idsused= NIL; } +break; +case 220: +#line 1203 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); + dval(yystack.l_mark[0]) = tries(dlhs(yystack.l_mark[0]),cons(dval(yystack.l_mark[0]),NIL)); + if(!SYNERR&&get_ids(dlhs(yystack.l_mark[0]))==NIL) + errs=hd[hd[tl[dval(yystack.l_mark[0])]]], + syntax("illegal lhs for local definition\n"); + } +break; +case 221: +#line 1210 "rules.y" + { if(dlhs(yystack.l_mark[0])==dlhs(hd[yystack.l_mark[-1]]) /*&&dval(hd[$1])!=UNDEF*/) + { yyval = yystack.l_mark[-1]; + if(!fallible(hd[tl[dval(hd[yystack.l_mark[-1]])]])) + errs=hd[dval(yystack.l_mark[0])], + printf("%ssyntax error: \ +unreachable case in defn of \"%s\"\n",echoing?"\n":"",get_id(dlhs(yystack.l_mark[0]))), + acterror(); + tl[dval(hd[yystack.l_mark[-1]])]=cons(dval(yystack.l_mark[0]),tl[dval(hd[yystack.l_mark[-1]])]); } + else if(!SYNERR) + { word ns=get_ids(dlhs(yystack.l_mark[0])),hr=hd[dval(yystack.l_mark[0])]; + if(ns==NIL) + errs=hr, + syntax("illegal lhs for local definition\n"); + yyval = cons(yystack.l_mark[0],yystack.l_mark[-1]); + dval(yystack.l_mark[0])=tries(dlhs(yystack.l_mark[0]),cons(dval(yystack.l_mark[0]),NIL)); + while(ns!=NIL&&!SYNERR) /* local nameclash check */ + { nclashcheck(hd[ns],yystack.l_mark[-1],hr); + ns=tl[ns]; } + /* potentially quadratic - fix later */ + } + } +break; +case 222: +#line 1234 "rules.y" + { errs=hd[tl[yystack.l_mark[0]]]; + syntax("`::' encountered in local defs\n"); + yyval = cons(nill,NIL); } +break; +case 223: +#line 1238 "rules.y" + { errs=yystack.l_mark[-1]; + syntax("`==' encountered in local defs\n"); + yyval = cons(nill,NIL); } +break; +case 224: +#line 1242 "rules.y" + { errs=yystack.l_mark[-1]; + syntax("`::=' encountered in local defs\n"); + yyval = cons(nill,NIL); } +break; +case 225: +#line 1246 "rules.y" + { word l = yystack.l_mark[-6], r = yystack.l_mark[-1]; + 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(yystack.l_mark[-2],r); /* to help locate type errors */ + yyval = defn(l,undef_t,r); } +break; +case 226: +#line 1255 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 227: +#line 1257 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 229: +#line 1262 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 230: +#line 1266 "rules.y" + { if(!isnat(yystack.l_mark[0])) + syntax("inappropriate use of \"+\" in pattern\n"); + yyval = ap2(PLUS,yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 231: +#line 1270 "rules.y" + { /* if(tag[$2]==DOUBLE) + $$ = cons(CONST,sto_dbl(-get_dbl($2))); else */ + if(tag[yystack.l_mark[0]]==INT) + yyval = cons(CONST,bignegate(yystack.l_mark[0])); else + syntax("inappropriate use of \"-\" in pattern\n"); } +break; +case 232: +#line 1276 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 233: +#line 1278 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 236: +#line 1284 "rules.y" + { yyval = ap(hd[yystack.l_mark[-1]]==CONST&&tag[tl[yystack.l_mark[-1]]]==ID?tl[yystack.l_mark[-1]]:yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 237: +#line 1290 "rules.y" + { if(sreds&&member(gvars,yystack.l_mark[0]))syntax("illegal use of $num symbol\n"); + /* cannot use grammar variable in a binding position */ + if(memb(idsused,yystack.l_mark[0]))yyval = cons(CONST,yystack.l_mark[0]); + /* picks up repeated names in a template */ + else idsused= cons(yystack.l_mark[0],idsused); } +break; +case 239: +#line 1297 "rules.y" + { if(tag[yystack.l_mark[0]]==DOUBLE) + syntax("use of floating point literal in pattern\n"); + yyval = cons(CONST,yystack.l_mark[0]); } +break; +case 240: +#line 1301 "rules.y" + { yyval = nill; } +break; +case 241: +#line 1303 "rules.y" + { word x=yystack.l_mark[-1],y=nill; + while(x!=NIL)y = cons(hd[x],y), x = tl[x]; + yyval = y; } +break; +case 242: +#line 1307 "rules.y" + { yyval = Void; } +break; +case 243: +#line 1309 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 244: +#line 1311 "rules.y" + { if(tl[yystack.l_mark[-1]]==NIL)yyval=pair(yystack.l_mark[-3],hd[yystack.l_mark[-1]]); + else { yyval=pair(hd[tl[yystack.l_mark[-1]]],hd[yystack.l_mark[-1]]); + yystack.l_mark[-1]=tl[tl[yystack.l_mark[-1]]]; + while(yystack.l_mark[-1]!=NIL)yyval=tcons(hd[yystack.l_mark[-1]],yyval),yystack.l_mark[-1]=tl[yystack.l_mark[-1]]; + yyval = tcons(yystack.l_mark[-3],yyval); } + /* representation of the tuple (a1,...,an) is + tcons(a1,tcons(a2,...pair(a(n-1),an))) */ + } +break; +case 246: +#line 1323 "rules.y" + { yyval = ap2(arrow_t,yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 247: +#line 1327 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 251: +#line 1338 "rules.y" + { yyval = ap(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 252: +#line 1340 "rules.y" + { yyval = ap(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 253: +#line 1344 "rules.y" + { yyval = transtypeid(yystack.l_mark[0]); } +break; +case 254: +#line 1347 "rules.y" + { if(tvarscope&&!memb(idsused,yystack.l_mark[0])) + printf("%ssyntax error: unbound type variable ",echoing?"\n":""), + out_type(yystack.l_mark[0]),putchar('\n'),acterror(); + yyval = yystack.l_mark[0]; } +break; +case 255: +#line 1352 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 256: +#line 1354 "rules.y" + { yyval = ap(list_t,yystack.l_mark[-1]); } +break; +case 257: +#line 1356 "rules.y" + { syntax( + "tuple-type with missing parentheses (obsolete syntax)\n"); } +break; +case 258: +#line 1361 "rules.y" + { yyval = void_t; } +break; +case 260: +#line 1364 "rules.y" + { word x=yystack.l_mark[0],y=void_t; + while(x!=NIL)y = ap2(comma_t,hd[x],y), x = tl[x]; + yyval = ap2(comma_t,yystack.l_mark[-2],y); } +break; +case 261: +#line 1370 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 262: +#line 1372 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 263: +#line 1376 "rules.y" + { yyval = add1(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 264: +#line 1378 "rules.y" + { yyval = yystack.l_mark[-2]; embargoes=add1(yystack.l_mark[0],embargoes); } +break; +case 265: +#line 1380 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 266: +#line 1382 "rules.y" + { yyval = yystack.l_mark[-1]; + exportfiles=cons(PLUS,exportfiles); } +break; +case 267: +#line 1385 "rules.y" + { yyval = add1(yystack.l_mark[0],NIL); } +break; +case 268: +#line 1387 "rules.y" + { yyval = NIL; embargoes=add1(yystack.l_mark[0],embargoes); } +break; +case 269: +#line 1389 "rules.y" + { yyval = NIL; } +break; +case 270: +#line 1391 "rules.y" + { yyval = NIL; + exportfiles=cons(PLUS,exportfiles); } +break; +case 271: +#line 1397 "rules.y" + { word x=yystack.l_mark[-1],h=hd[yystack.l_mark[0]],t=tl[yystack.l_mark[0]]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + yyval = x; } +break; +case 272: +#line 1401 "rules.y" + { word x=NIL,h=hd[yystack.l_mark[0]],t=tl[yystack.l_mark[0]]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + yyval = x; } +break; +case 273: +#line 1407 "rules.y" + { yyval = cons(yystack.l_mark[-5],cons(yystack.l_mark[-3],yystack.l_mark[-1])); } +break; +case 274: +#line 1413 "rules.y" + { word x=yystack.l_mark[-1],h=hd[yystack.l_mark[0]],t=tl[yystack.l_mark[0]]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + yyval = x; } +break; +case 275: +#line 1417 "rules.y" + { word x=NIL,h=hd[yystack.l_mark[0]],t=tl[yystack.l_mark[0]]; + while(h!=NIL)x=cons(cons(hd[h],t),x),h=tl[h]; + yyval = x; } +break; +case 276: +#line 1422 "rules.y" + {inbnf=0;} +break; +case 277: +#line 1423 "rules.y" + { yyval = cons(yystack.l_mark[-6],cons(yystack.l_mark[-4],yystack.l_mark[-1])); } +break; +case 278: +#line 1427 "rules.y" + { yyval = cons(yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 279: +#line 1429 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 280: +#line 1433 "rules.y" + { yyval = cons(yystack.l_mark[-1],yystack.l_mark[-3]); } +break; +case 281: +#line 1435 "rules.y" + { yyval = cons(yystack.l_mark[-1],NIL); } +break; +case 282: +#line 1439 "rules.y" + { syntax("upper case identifier out of context\n"); } +break; +case 283: +#line 1441 "rules.y" + { yyval = yystack.l_mark[-1]; + idsused=yystack.l_mark[0]; + while(yystack.l_mark[0]!=NIL) + yyval = ap(yyval,hd[yystack.l_mark[0]]),yystack.l_mark[0] = tl[yystack.l_mark[0]]; + } +break; +case 284: +#line 1447 "rules.y" + { if(eqtvar(yystack.l_mark[-2],yystack.l_mark[0])) + syntax("repeated type variable in typeform\n"); + idsused=cons(yystack.l_mark[-2],cons(yystack.l_mark[0],NIL)); + yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-2],yystack.l_mark[0]); } +break; +case 285: +#line 1452 "rules.y" + { syntax("upper case identifier cannot be used as typename\n"); } +break; +case 287: +#line 1457 "rules.y" + { yyval = type_t; } +break; +case 288: +#line 1461 "rules.y" + { yyval = mktvar(1); } +break; +case 290: +#line 1466 "rules.y" + { yyval = NIL; } +break; +case 291: +#line 1468 "rules.y" + { if(memb(yystack.l_mark[0],yystack.l_mark[-1])) + syntax("repeated type variable on lhs of type def\n"); + yyval = cons(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 292: +#line 1474 "rules.y" + { extern word SGC; /* keeps track of sui-generis constructors */ + if( tl[yystack.l_mark[0]]==NIL && tag[hd[yystack.l_mark[0]]]!=ID ) + /* 2nd conjunct excludes singularity types */ + SGC=cons(head(hd[yystack.l_mark[0]]),SGC); + } +break; +case 293: +#line 1482 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 294: +#line 1484 "rules.y" + { yyval = cons(yystack.l_mark[0],yystack.l_mark[-2]); } +break; +case 295: +#line 1488 "rules.y" + { yyval = ap2(yystack.l_mark[-1],yystack.l_mark[-3],yystack.l_mark[0]); + id_who(yystack.l_mark[-1])=yystack.l_mark[-2]; } +break; +case 297: +#line 1494 "rules.y" + { yyval = yystack.l_mark[-1]; } +break; +case 298: +#line 1496 "rules.y" + { yyval = ap(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 299: +#line 1498 "rules.y" + { yyval = yystack.l_mark[0]; + id_who(yystack.l_mark[0])=yystack.l_mark[-1]; } +break; +case 301: +#line 1504 "rules.y" + { yyval = ap(strict_t,yystack.l_mark[-1]); } +break; +case 302: +#line 1508 "rules.y" + { yyval = ap(strict_t,yystack.l_mark[-1]); } +break; +case 304: +#line 1513 "rules.y" + { yyval = NIL; } +break; +case 305: +#line 1515 "rules.y" + { if(member(yystack.l_mark[-1],yystack.l_mark[0])) + printf("%ssyntax error: repeated identifier \"%s\" in %s list\n", + echoing?"\n":"",get_id(yystack.l_mark[0]),inbnf?"bnf":"attribute"), + acterror(); + yyval = inbnf?add1(yystack.l_mark[0],yystack.l_mark[-1]):cons(yystack.l_mark[0],yystack.l_mark[-1]); + } +break; +case 306: +#line 1524 "rules.y" + { word h=reverse(hd[yystack.l_mark[0]]),hr=hd[tl[yystack.l_mark[0]]],t=tl[tl[yystack.l_mark[0]]]; + inbnf=1; + yyval=NIL; + while(h!=NIL&&!SYNERR) + ntspecmap=cons(cons(hd[h],hr),ntspecmap), + yyval=add_prod(defn(hd[h],t,UNDEF),yyval,hr), + h=tl[h]; + } +break; +case 307: +#line 1533 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 308: +#line 1535 "rules.y" + { word h=reverse(hd[yystack.l_mark[0]]),hr=hd[tl[yystack.l_mark[0]]],t=tl[tl[yystack.l_mark[0]]]; + inbnf=1; + yyval=yystack.l_mark[-1]; + while(h!=NIL&&!SYNERR) + ntspecmap=cons(cons(hd[h],hr),ntspecmap), + yyval=add_prod(defn(hd[h],t,UNDEF),yyval,hr), + h=tl[h]; + } +break; +case 309: +#line 1544 "rules.y" + { yyval = add_prod(yystack.l_mark[0],yystack.l_mark[-1],hd[dval(yystack.l_mark[0])]); } +break; +case 310: +#line 1549 "rules.y" + { yyval = defn(yystack.l_mark[-5],undef_t,yystack.l_mark[-1]); } +break; +case 311: +#line 1553 "rules.y" + { ihlist=0; } +break; +case 312: +#line 1554 "rules.y" + { inbnf=0; } +break; +case 313: +#line 1555 "rules.y" + { inbnf=1; + if(yystack.l_mark[-1]==NIL)syntax("unexpected token ')'\n"); + ihlist=yystack.l_mark[-1]; } +break; +case 314: +#line 1561 "rules.y" + { yyval = label(yystack.l_mark[-1],yystack.l_mark[0]); } +break; +case 315: +#line 1565 "rules.y" + { yyval = ap2(G_ERROR,G_ZERO,yystack.l_mark[0]); } +break; +case 316: +#line 1567 "rules.y" + { yyval=hd[yystack.l_mark[0]], yystack.l_mark[0]=tl[yystack.l_mark[0]]; + while(yystack.l_mark[0]!=NIL) + yyval=label(hd[yystack.l_mark[0]],yyval),yystack.l_mark[0]=tl[yystack.l_mark[0]], + yyval=ap2(G_ALT,hd[yystack.l_mark[0]],yyval),yystack.l_mark[0]=tl[yystack.l_mark[0]]; + } +break; +case 317: +#line 1573 "rules.y" + { yyval=hd[yystack.l_mark[-2]], yystack.l_mark[-2]=tl[yystack.l_mark[-2]]; + while(yystack.l_mark[-2]!=NIL) + yyval=label(hd[yystack.l_mark[-2]],yyval),yystack.l_mark[-2]=tl[yystack.l_mark[-2]], + yyval=ap2(G_ALT,hd[yystack.l_mark[-2]],yyval),yystack.l_mark[-2]=tl[yystack.l_mark[-2]]; + yyval = ap2(G_ERROR,yyval,yystack.l_mark[0]); } +break; +case 318: +#line 1582 "rules.y" + { yyval=cons(yystack.l_mark[0],NIL); } +break; +case 319: +#line 1584 "rules.y" + { yyval = cons(yystack.l_mark[0],cons(yystack.l_mark[-1],yystack.l_mark[-3])); } +break; +case 320: +#line 1588 "rules.y" + { word n=0,f=yystack.l_mark[0],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]; + yyval = rule; } +break; +case 321: +#line 1598 "rules.y" + {inbnf=2;} +break; +case 322: +#line 1599 "rules.y" + { if(yystack.l_mark[-6]!=NIL&&hd[yystack.l_mark[-6]]==G_END)sreds++; + if(sreds==1&&can_elide(yystack.l_mark[-1])) + inbnf=1,sreds=0,yyval=hd[yystack.l_mark[-6]]; /* optimisation */ + else + { word f=yystack.l_mark[-6],rule=label(yystack.l_mark[-2],yystack.l_mark[-1]),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]; + yyval = rule; } + } +break; +case 323: +#line 1615 "rules.y" + { word rule = ap(K,Void); /* default value of a production is () */ + if(ihlist)rule=ih_abstr(rule); + yyval = rule; } +break; +case 324: +#line 1618 "rules.y" + { inbnf=2,sreds=2; } +break; +case 325: +#line 1619 "rules.y" + { word rule = label(yystack.l_mark[-2],yystack.l_mark[-1]); + if(ihlist)rule=ih_abstr(rule); + yyval = lambda(pair(mkgvar(1),mkgvar(2)),rule); + inbnf=1,sreds=0; } +break; +case 326: +#line 1626 "rules.y" + { sreds=0; yyval=NIL; } +break; +case 327: +#line 1628 "rules.y" + { syntax("unexpected token after empty\n"); + sreds=0; yyval=NIL; } +break; +case 328: +#line 1630 "rules.y" + { obrct=0; } +break; +case 329: +#line 1631 "rules.y" + { word f=yystack.l_mark[0]; + 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[yystack.l_mark[0]]==G_END)sreds--; + yyval = yystack.l_mark[0]; } +break; +case 330: +#line 1641 "rules.y" + { yyval = cons(yystack.l_mark[0],NIL); } +break; +case 331: +#line 1643 "rules.y" + { if(hd[yystack.l_mark[-1]]==G_END) + syntax("unexpected token after end\n"); + yyval = cons(yystack.l_mark[0],yystack.l_mark[-1]); } +break; +case 333: +#line 1650 "rules.y" + { yyval = ap(outdent_fn,ap2(indent_fn,getcol_fn(),yystack.l_mark[-1])); } +break; +case 334: +#line 1652 "rules.y" + { obrct++; + yyval = ap2(indent_fn,getcol_fn(),yystack.l_mark[0]); } +break; +case 335: +#line 1655 "rules.y" + { if(--obrct<0)syntax("unmatched `}' in grammar rule\n"); + yyval = ap(outdent_fn,yystack.l_mark[-1]); } +break; +case 337: +#line 1661 "rules.y" + { yyval = ap(G_STAR,yystack.l_mark[-1]); } +break; +case 338: +#line 1663 "rules.y" + { yyval = ap2(G_SEQ,yystack.l_mark[-1],ap2(G_SEQ,ap(G_STAR,yystack.l_mark[-1]),ap(G_RULE,ap(C,P)))); } +break; +case 339: +#line 1665 "rules.y" + { yyval = ap(G_OPT,yystack.l_mark[-1]); } +break; +case 340: +#line 1669 "rules.y" + { extern word NEW; + nonterminals=newadd1(yystack.l_mark[0],nonterminals); + if(NEW)ntmap=cons(cons(yystack.l_mark[0],lasth),ntmap); } +break; +case 341: +#line 1673 "rules.y" + { yyval = G_END; } +break; +case 342: +#line 1675 "rules.y" + { if(!isstring(yystack.l_mark[0])) + printf("%ssyntax error: illegal terminal ",echoing?"\n":""), + out(stdout,yystack.l_mark[0]),printf(" (should be string-const)\n"), + acterror(); + yyval = ap(G_SYMB,yystack.l_mark[0]); } +break; +case 343: +#line 1681 "rules.y" + { yyval=G_STATE; } +break; +case 344: +#line 1682 "rules.y" + {inbnf=0;} +break; +case 345: +#line 1682 "rules.y" + {inbnf=1;} +break; +case 346: +#line 1683 "rules.y" + { yyval = ap(G_SUCHTHAT,yystack.l_mark[-2]); } +break; +case 347: +#line 1685 "rules.y" + { yyval = G_ANY; } +break; +#line 3607 "y.tab.c" + } + yystack.s_mark -= yym; + yystate = *yystack.s_mark; + yystack.l_mark -= yym; + yym = yylhs[yyn]; + if (yystate == 0 && yym == 0) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state 0 to\ + state %d\n", YYPREFIX, YYFINAL); +#endif + yystate = YYFINAL; + *++yystack.s_mark = YYFINAL; + *++yystack.l_mark = yyval; + if (yychar < 0) + { + if ((yychar = YYLEX) < 0) yychar = YYEOF; +#if YYDEBUG + if (yydebug) + { + yys = yyname[YYTRANSLATE(yychar)]; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, YYFINAL, yychar, yys); + } +#endif + } + if (yychar == YYEOF) goto yyaccept; + goto yyloop; + } + if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yystate) + yystate = yytable[yyn]; + else + yystate = yydgoto[yym]; +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state %d \ +to state %d\n", YYPREFIX, *yystack.s_mark, yystate); +#endif + if (yystack.s_mark >= yystack.s_last && yygrowstack(&yystack) == YYENOMEM) + { + goto yyoverflow; + } + *++yystack.s_mark = (YYINT) yystate; + *++yystack.l_mark = yyval; + goto yyloop; + +yyoverflow: + YYERROR_CALL("yacc stack overflow"); + +yyabort: + yyfreestack(&yystack); + return (1); + +yyaccept: + yyfreestack(&yystack); + return (0); +} @@ -0,0 +1,50 @@ +#define VALUE 257 +#define EVAL 258 +#define WHERE 259 +#define IF 260 +#define TO 261 +#define LEFTARROW 262 +#define COLONCOLON 263 +#define COLON2EQ 264 +#define TYPEVAR 265 +#define NAME 266 +#define CNAME 267 +#define CONST 268 +#define DOLLAR2 269 +#define OFFSIDE 270 +#define ELSEQ 271 +#define ABSTYPE 272 +#define WITH 273 +#define DIAG 274 +#define EQEQ 275 +#define FREE 276 +#define INCLUDE 277 +#define EXPORT 278 +#define TYPE 279 +#define OTHERWISE 280 +#define SHOWSYM 281 +#define PATHNAME 282 +#define BNF 283 +#define LEX 284 +#define ENDIR 285 +#define ERRORSY 286 +#define ENDSY 287 +#define EMPTYSY 288 +#define READVALSY 289 +#define LEXDEF 290 +#define CHARCLASS 291 +#define ANTICHARCLASS 292 +#define LBEGIN 293 +#define ARROW 294 +#define PLUSPLUS 295 +#define MINUSMINUS 296 +#define DOTDOT 297 +#define VEL 298 +#define GE 299 +#define NE 300 +#define LE 301 +#define REM 302 +#define DIV 303 +#define INFIXNAME 304 +#define INFIXCNAME 305 +#define CMBASE 306 |