From 55f277e77428d7423ae906a8e1f1324d35b07a7d Mon Sep 17 00:00:00 2001 From: Jakob Kaivo Date: Fri, 4 Mar 2022 12:32:20 -0500 Subject: import Miranda 2.066 from upstream --- .date | 1 + .epoch | 1 + .host | 2 + .nextxversion | 5 + .version | 1 + .xversion | 1 + COPYING | 1 + Makefile | 77 + README | 90 ++ allexterns | 143 ++ big.c | 656 ++++++++ big.h | 62 + cmbnms.c | 144 ++ combs.h | 143 ++ data.c | 1315 ++++++++++++++++ data.h | 350 +++++ ex | 1 + fdate.c | 21 + gencdecs | 38 + hostinfo | 5 + just.1 | 130 ++ just.c | 295 ++++ lex.c | 1220 +++++++++++++++ lex.h | 30 + linkmenudriver | 7 + menudriver.c | 320 ++++ mira.1 | 272 ++++ miralib/.version | 1 + miralib/COPYING | 27 + miralib/auxfile | 28 + miralib/ex/README | 54 + miralib/ex/ack.m | 9 + miralib/ex/barry.m | 31 + miralib/ex/box | 1 + miralib/ex/box.m | 244 +++ miralib/ex/divmodtest.m | 11 + miralib/ex/edigits.m | 73 + miralib/ex/fib.m | 4 + miralib/ex/fibs.m | 16 + miralib/ex/genmat.m | 84 + miralib/ex/graphics.m | 164 ++ miralib/ex/hamming.m | 19 + miralib/ex/hanoi.m | 11 + miralib/ex/just.m | 98 ++ miralib/ex/kate.lit.m | 138 ++ miralib/ex/kate.pdf | Bin 0 -> 58803 bytes miralib/ex/kate.tex | 1 + miralib/ex/keith.m | 31 + miralib/ex/makebug.m | 18 + miralib/ex/matrix.m | 70 + miralib/ex/mrev | 22 + miralib/ex/parafs.m | 33 + miralib/ex/polish.m | 34 + miralib/ex/powers.m | 15 + miralib/ex/primes.m | 7 + miralib/ex/pyths.m | 9 + miralib/ex/queens.m | 22 + miralib/ex/queens1.m | 16 + miralib/ex/quicksort.m | 12 + miralib/ex/rational.m | 56 + miralib/ex/refoliate.m | 60 + miralib/ex/selflines.m | 32 + miralib/ex/set.m | 64 + miralib/ex/stack.m | 19 + miralib/ex/topsort.m | 32 + miralib/ex/treesort.m | 20 + miralib/ex/unify.m | 79 + miralib/helpfile | 25 + miralib/manual/.epoch | 1 + miralib/manual/1 | 76 + miralib/manual/10 | 60 + miralib/manual/100 | 578 +++++++ miralib/manual/11 | 86 ++ miralib/manual/12 | 86 ++ miralib/manual/13/1 | 22 + miralib/manual/13/2 | 68 + miralib/manual/13/3 | 33 + miralib/manual/13/contents | 6 + miralib/manual/14 | 66 + miralib/manual/15 | 92 ++ miralib/manual/16 | 174 +++ miralib/manual/17 | 66 + miralib/manual/18 | 114 ++ miralib/manual/19 | 18 + miralib/manual/2 | 23 + miralib/manual/20 | 126 ++ miralib/manual/21 | 133 ++ miralib/manual/22 | 35 + miralib/manual/23 | 55 + miralib/manual/24 | 58 + miralib/manual/25 | 80 + miralib/manual/26 | 72 + miralib/manual/27/1 | 19 + miralib/manual/27/2 | 44 + miralib/manual/27/3 | 286 ++++ miralib/manual/27/4 | 116 ++ miralib/manual/27/5 | 132 ++ miralib/manual/27/contents | 8 + miralib/manual/28 | 1 + miralib/manual/29 | 1 + miralib/manual/29.m | 88 ++ miralib/manual/3 | 55 + miralib/manual/30 | 261 ++++ miralib/manual/31/1 | 92 ++ miralib/manual/31/2 | 138 ++ miralib/manual/31/3 | 42 + miralib/manual/31/4 | 175 +++ miralib/manual/31/5 | 105 ++ miralib/manual/31/6 | 38 + miralib/manual/31/7 | 160 ++ miralib/manual/31/8 | 83 + miralib/manual/31/9 | 54 + miralib/manual/31/contents | 12 + miralib/manual/32 | 98 ++ miralib/manual/33 | 4 + miralib/manual/34 | 87 ++ miralib/manual/4 | 147 ++ miralib/manual/5 | 1 + miralib/manual/6 | 1 + miralib/manual/7 | 81 + miralib/manual/8 | 75 + miralib/manual/9 | 62 + miralib/manual/99 | 5 + miralib/manual/contents | 22 + miralib/manual/howtoprint | 4 + miralib/manual/permission | 6 + miralib/manual/printman | 42 + miralib/menudriver.csh | 104 ++ miralib/menudriver.sh | 102 ++ miralib/prelude | 110 ++ miralib/stdenv.m | 761 +++++++++ new/big.c | 643 ++++++++ new/data.c | 1250 +++++++++++++++ new/lex.c | 1213 +++++++++++++++ new/reduce.c | 2376 ++++++++++++++++++++++++++++ new/rules.y | 1686 ++++++++++++++++++++ new/steer.c | 2208 ++++++++++++++++++++++++++ new/trans.c | 1026 +++++++++++++ new/types.c | 1613 +++++++++++++++++++ protect | 7 + quotehostinfo | 7 + reduce.c | 2394 +++++++++++++++++++++++++++++ revdate | 4 + rules.y | 1689 ++++++++++++++++++++ sources | 1 + steer.c | 2241 +++++++++++++++++++++++++++ toks.m | 9 + trans.c | 1000 ++++++++++++ types.c | 1674 ++++++++++++++++++++ ugroot | 7 + unprotect | 1 + utf8.c | 88 ++ utf8.h | 9 + version.c | 3 + y.tab.c | 3665 ++++++++++++++++++++++++++++++++++++++++++++ y.tab.h | 50 + 156 files changed, 37635 insertions(+) create mode 100644 .date create mode 100644 .epoch create mode 100644 .host create mode 100755 .nextxversion create mode 120000 .version create mode 100644 .xversion create mode 120000 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 allexterns create mode 100644 big.c create mode 100644 big.h create mode 100644 cmbnms.c create mode 100644 combs.h create mode 100644 data.c create mode 100644 data.h create mode 120000 ex create mode 100644 fdate.c create mode 100755 gencdecs create mode 100755 hostinfo create mode 100644 just.1 create mode 100644 just.c create mode 100644 lex.c create mode 100644 lex.h create mode 100755 linkmenudriver create mode 100644 menudriver.c create mode 100644 mira.1 create mode 100644 miralib/.version create mode 100644 miralib/COPYING create mode 100644 miralib/auxfile create mode 100644 miralib/ex/README create mode 100644 miralib/ex/ack.m create mode 100644 miralib/ex/barry.m create mode 120000 miralib/ex/box create mode 100755 miralib/ex/box.m create mode 100644 miralib/ex/divmodtest.m create mode 100644 miralib/ex/edigits.m create mode 100644 miralib/ex/fib.m create mode 100644 miralib/ex/fibs.m create mode 100644 miralib/ex/genmat.m create mode 100644 miralib/ex/graphics.m create mode 100644 miralib/ex/hamming.m create mode 100644 miralib/ex/hanoi.m create mode 100644 miralib/ex/just.m create mode 100644 miralib/ex/kate.lit.m create mode 100644 miralib/ex/kate.pdf create mode 120000 miralib/ex/kate.tex create mode 100644 miralib/ex/keith.m create mode 100644 miralib/ex/makebug.m create mode 100644 miralib/ex/matrix.m create mode 100755 miralib/ex/mrev create mode 100644 miralib/ex/parafs.m create mode 100644 miralib/ex/polish.m create mode 100644 miralib/ex/powers.m create mode 100644 miralib/ex/primes.m create mode 100644 miralib/ex/pyths.m create mode 100644 miralib/ex/queens.m create mode 100644 miralib/ex/queens1.m create mode 100644 miralib/ex/quicksort.m create mode 100644 miralib/ex/rational.m create mode 100644 miralib/ex/refoliate.m create mode 100644 miralib/ex/selflines.m create mode 100644 miralib/ex/set.m create mode 100644 miralib/ex/stack.m create mode 100644 miralib/ex/topsort.m create mode 100644 miralib/ex/treesort.m create mode 100644 miralib/ex/unify.m create mode 100644 miralib/helpfile create mode 100644 miralib/manual/.epoch create mode 100644 miralib/manual/1 create mode 100644 miralib/manual/10 create mode 100644 miralib/manual/100 create mode 100644 miralib/manual/11 create mode 100644 miralib/manual/12 create mode 100644 miralib/manual/13/1 create mode 100644 miralib/manual/13/2 create mode 100644 miralib/manual/13/3 create mode 100644 miralib/manual/13/contents create mode 100644 miralib/manual/14 create mode 100644 miralib/manual/15 create mode 100644 miralib/manual/16 create mode 100644 miralib/manual/17 create mode 100644 miralib/manual/18 create mode 100644 miralib/manual/19 create mode 100644 miralib/manual/2 create mode 100644 miralib/manual/20 create mode 100644 miralib/manual/21 create mode 100644 miralib/manual/22 create mode 100644 miralib/manual/23 create mode 100644 miralib/manual/24 create mode 100644 miralib/manual/25 create mode 100644 miralib/manual/26 create mode 100644 miralib/manual/27/1 create mode 100644 miralib/manual/27/2 create mode 100644 miralib/manual/27/3 create mode 100644 miralib/manual/27/4 create mode 100644 miralib/manual/27/5 create mode 100644 miralib/manual/27/contents create mode 120000 miralib/manual/28 create mode 120000 miralib/manual/29 create mode 100644 miralib/manual/29.m create mode 100644 miralib/manual/3 create mode 100644 miralib/manual/30 create mode 100644 miralib/manual/31/1 create mode 100644 miralib/manual/31/2 create mode 100644 miralib/manual/31/3 create mode 100644 miralib/manual/31/4 create mode 100644 miralib/manual/31/5 create mode 100644 miralib/manual/31/6 create mode 100644 miralib/manual/31/7 create mode 100644 miralib/manual/31/8 create mode 100644 miralib/manual/31/9 create mode 100644 miralib/manual/31/contents create mode 100644 miralib/manual/32 create mode 100644 miralib/manual/33 create mode 100644 miralib/manual/34 create mode 100644 miralib/manual/4 create mode 120000 miralib/manual/5 create mode 120000 miralib/manual/6 create mode 100644 miralib/manual/7 create mode 100644 miralib/manual/8 create mode 100644 miralib/manual/9 create mode 100755 miralib/manual/99 create mode 100644 miralib/manual/contents create mode 100644 miralib/manual/howtoprint create mode 100644 miralib/manual/permission create mode 100755 miralib/manual/printman create mode 100755 miralib/menudriver.csh create mode 100755 miralib/menudriver.sh create mode 100644 miralib/prelude create mode 100644 miralib/stdenv.m create mode 100644 new/big.c create mode 100644 new/data.c create mode 100644 new/lex.c create mode 100644 new/reduce.c create mode 100644 new/rules.y create mode 100644 new/steer.c create mode 100644 new/trans.c create mode 100644 new/types.c create mode 100755 protect create mode 100755 quotehostinfo create mode 100644 reduce.c create mode 100755 revdate create mode 100644 rules.y create mode 100644 sources create mode 100644 steer.c create mode 100755 toks.m create mode 100644 trans.c create mode 100644 types.c create mode 100755 ugroot create mode 100755 unprotect create mode 100644 utf8.c create mode 100644 utf8.h create mode 100644 version.c create mode 100644 y.tab.c create mode 100644 y.tab.h diff --git a/.date b/.date new file mode 100644 index 0000000..83eb0bd --- /dev/null +++ b/.date @@ -0,0 +1 @@ +2020.01.31 diff --git a/.epoch b/.epoch new file mode 100644 index 0000000..363d3b9 --- /dev/null +++ b/.epoch @@ -0,0 +1 @@ +1580476718 diff --git a/.host b/.host new file mode 100644 index 0000000..179f8ae --- /dev/null +++ b/.host @@ -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 diff --git a/COPYING b/COPYING new file mode 120000 index 0000000..103a266 --- /dev/null +++ b/COPYING @@ -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 diff --git a/README b/README new file mode 100644 index 0000000..b4fcc82 --- /dev/null +++ b/README @@ -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; diff --git a/big.c b/big.c new file mode 100644 index 0000000..05f346b --- /dev/null +++ b/big.c @@ -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 + +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)<=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=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>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>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 */ + diff --git a/big.h b/big.h new file mode 100644 index 0000000..ce8b91c --- /dev/null +++ b/big.h @@ -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}; diff --git a/combs.h b/combs.h new file mode 100644 index 0000000..ddddc45 --- /dev/null +++ b/combs.h @@ -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) diff --git a/data.c b/data.c new file mode 100644 index 0000000..b2a1bea --- /dev/null +++ b/data.c @@ -0,0 +1,1315 @@ +/* MIRANDA DATA REPRESENTATIONS */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "big.h" +#include "lex.h" +#define INITSPACE 1250000 +word SPACE=INITSPACE; /* false ceiling in heap to improve paging behaviour + during compilation */ +extern word SPACELIMIT; /* see steer.c for default value */ + /* SPACELIMIT controls the size of the heap (i.e. the number of list + cells available) - the minimum survivable number given the need to + compile the prelude etc is probably about 6000 */ + /* Note: the size of a list cell is 2 ints + 1 char */ +#define BIGTOP (SPACELIMIT + ATOMLIMIT) +word listp=ATOMLIMIT-1; +word *hdspace,*tlspace; +long long cellcount=0; +long claims=0; +long nogcs=0; +extern int atgc,loading; /* flags, set in steer.c */ + +word *dstack=0,*stackp,*dlim; +/* stackp=dstack; /* if load_script made interruptible, add to reset */ + +#define poschar(c) !(negchar((c)-1)) +#define negchar(c) (c&128) + /* safest to test for -ve chars this way, since not all m/c's do sign + extension - DT Jan 84 */ + +static void bases(void); +static void bindparams(word,word); +static void dsetup(void); +static void dump_defs(word,FILE *); +static void dump_ob(word,FILE *); +static word hdsort(word); +static word load_defs(FILE *); +static void mark(word); +static void unscramble(word); + +word trueheapsize() +{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); } + +void setupheap() +{ hdspace=(word *)malloc(SPACELIMIT*sizeof(word)); + tlspace=(word *)malloc(SPACELIMIT*sizeof(word)); + hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT; + if(SPACE>SPACELIMIT)SPACE=SPACELIMIT; + tag=(char *)calloc(BIGTOP+1,sizeof(char)); + /* NB use calloc because it sets contents to zero */ + /* tag[TOP] must be zero and exists as a sentinel */ + if(hdspace==NULL||tlspace==NULL||tag==NULL)mallocfail("heap"); +} + +void resetheap() /* warning - cannot do this dynamically, because both the + compiler and the reducer hold onto absolute heap addresses + during certain space consuming computations */ +{ if(SPACELIMITSPACELIMIT)SPACE=SPACELIMIT; + if(SPACE1) + { /* 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<>\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<>\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,"<>\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>\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])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 + integer INT_X <4n bytes> (-1) + double DBL_X <8 bytes> + unicode_char UNICODE_X <4 bytes> + typevar TVAR_X + ap(x,y) [x] [y] AP_X + cons(x,y) [y] [x] CONS_X + id (=occurrence) ID_X + pname (=occurrence) PN_X <2 bytes> + PN1_X <4 bytes> + datapair(string,0) AKA_X + fileinfo(script,line_no) HERE_X <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 + mtime + + 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' + (=errline) + ... (rest as normal script) + + syntax-error script __WORDSIZE + XVERSION + `\0' + (=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)<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++ = ch127?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",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 */ + diff --git a/data.h b/data.h new file mode 100644 index 0000000..6975f37 --- /dev/null +++ b/data.h @@ -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) /* execl */ +#include /* malloc, calloc, realloc, getenv */ +#include /* MAX_DBL */ +#include +#include +typedef void (*sighandler)(); +#include +#include +#include +#define index(s,c) strchr(s,c) +#define rindex(s,c) strrchr(s,c) +#if IBMRISC | sparc7 +union wait { word w_status; }; +#else +#include +#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 */ + diff --git a/ex b/ex new file mode 120000 index 0000000..9c8cf15 --- /dev/null +++ b/ex @@ -0,0 +1 @@ +miralib/ex \ No newline at end of file diff --git a/fdate.c b/fdate.c new file mode 100644 index 0000000..5a25803 --- /dev/null +++ b/fdate.c @@ -0,0 +1,21 @@ +/* reads a filename from stdin and prints its time-last-modified, + in format [d]d yyyy */ + +#include +#include +#include +#include +#include + +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 diff --git a/just.1 b/just.1 new file mode 100644 index 0000000..10d89dd --- /dev/null +++ b/just.1 @@ -0,0 +1,130 @@ +.TH JUST 1 +.UC 4 +.SH NAME +just \- text justification program +.SH SYNOPSIS +.nf +just [-] [-t] [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 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 +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 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). diff --git a/just.c b/just.c new file mode 100644 index 0000000..014a758 --- /dev/null +++ b/just.c @@ -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 [-] [-t] [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 +#include +#include +#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 +#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') + { /* 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-buf0 */ + 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); +} diff --git a/lex.c b/lex.c new file mode 100644 index 0000000..0eb44c9 --- /dev/null +++ b/lex.c @@ -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 + +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,),...)*/ +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 +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 */ + 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 */ +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)&&countUMAX?-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)&&countUMAX?-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=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(""); } + 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 */ + diff --git a/lex.h b/lex.h new file mode 100644 index 0000000..59e3a14 --- /dev/null +++ b/lex.h @@ -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 +#include +#include +#include +#include +#include +#include +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 +#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 +#include +#else +#include +#include +#endif + +void clrscr() +{ if(ok!=1)return; + putp(clear_screen); + fflush(stdout); +} +/* end of clrscr method using curses */ +#endif + diff --git a/mira.1 b/mira.1 new file mode 100644 index 0000000..fa9845d --- /dev/null +++ b/mira.1 @@ -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 will then have to explicitly %include , +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\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 + +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 { 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 ) thus:- +|| %include +|| { 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 yx1 + = [spaces (x1-x) ++ p ++ "\n" | p <- a], if xnum->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 ab + +||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 - 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 - 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 new file mode 100644 index 0000000..606a4c8 Binary files /dev/null and b/miralib/ex/kate.pdf differ 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 + +%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 +||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 +||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 \/ ab + = setdiff x y, otherwise +setdiff x y = x +intersect2 (a:x) (b:y) = intersect2 x (b:y), if ab + = a : intersect2 x y, otherwise +intersect2 x y = [] +intersect = foldl1 intersect2 +add1 a (b:x) = a:b:x, if a[*] +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 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 + 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) + 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 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 a0 + _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 ab + = 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 :: +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 , instead of "string_quotes" is relative to +the miralib directory. In particular note that the Miranda session +command + /cd +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=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 + + + +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 "". + +(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 "". + +(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(;) + 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 +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", + 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 + +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 .) +------------------------------------------------------------------------ + +%_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, , 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 ab + = 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 is not loaded (because you invoked mira with +-stdenv, and the script does not explicitly %include 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] <> 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 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 . + + 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 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 +"" (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[*]->[*] +++ -- 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  #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 ; "./$n" + else echo  #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 = "" + showabstract::*->[char] + showabstract x = "" + 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 + +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)<=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=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>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>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(SPACELIMITSPACELIMIT)SPACE=SPACELIMIT; + if(SPACE1) + { /* 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<>\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<>\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,"<>\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>\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])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 + integer INT_X <4n bytes> (-1) + double DBL_X <8 bytes> + unicode_char UNICODE_X <4 bytes> + typevar TVAR_X + ap(x,y) [x] [y] AP_X + cons(x,y) [y] [x] CONS_X + id (=occurrence) ID_X + pname (=occurrence) PN_X <2 bytes> + PN1_X <4 bytes> + datapair(string,0) AKA_X + fileinfo(script,line_no) HERE_X <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 + 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++ = ch127?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",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 + +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,),...)*/ +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 +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 */ + 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 */ +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)&&countUMAX?-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)&&countUMAX?-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=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(""); } + 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 +#include +#include +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&&nBUFSIZE) + { 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\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 => */ + 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(""); + 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(""); 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 = , fails(f toks') + = , 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-linebuf60||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(""); + 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(""); 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 +#include +#ifndef CLK_TCK +#define CLK_TCK sysconf(_SC_CLK_TCK) +#endif +#else +/* this is ANSII C, POSIX */ +#include +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(n0?"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 +#include +/* #include /* seems not needed, oct 05 */ +struct stat buf; /* see man(2) stat - gets file status */ + +#include "data.h" +#include "lex.h" +#include +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 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 /* for longjmp() - see man (3) setjmp */ +jmp_buf env; + +#ifdef sparc8 +#include +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 + /.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(;i999999)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(versionscript 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<>\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("<>\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 + +filequote(p) /* write p to stdout with 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) + { 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;col0)); } + else + for(r=wp-1-r,col=0;col6) /* 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)=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 , 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 , 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 ) */ + 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 ) */ + +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||t20)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 +#include + +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 + +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]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 = 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]] +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;j0)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 ' 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;i2000 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]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||ehd[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]"); + 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("",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 */ + diff --git a/protect b/protect new file mode 100755 index 0000000..40aad7c --- /dev/null +++ b/protect @@ -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 +#include +#include +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&&nBUFSIZE) + { 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\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 => */ + 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(""); + 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(""); 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 = , fails(f toks') + = , 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-linebuf60||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(""); + 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(""); 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 +#include +#ifndef CLK_TCK +#define CLK_TCK sysconf(_SC_CLK_TCK) +#endif +#else +/* this is ANSII C, POSIX */ +#include +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 */ + diff --git a/revdate b/revdate new file mode 100755 index 0000000..4054f43 --- /dev/null +++ b/revdate @@ -0,0 +1,4 @@ +ls -t `make -s sources` | ./fdate + +#output the date of most recently revised source file +#e.g 9 July 2004 diff --git a/rules.y b/rules.y new file mode 100644 index 0000000..cca58d7 --- /dev/null +++ b/rules.y @@ -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(n0?"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/sources b/sources new file mode 100644 index 0000000..14eda57 --- /dev/null +++ b/sources @@ -0,0 +1 @@ +big.c big.h data.h data.c lex.c reduce.c rules.y steer.c trans.c types.c diff --git a/steer.c b/steer.c new file mode 100644 index 0000000..422efbb --- /dev/null +++ b/steer.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 +#include +#include /* creat() */ +/* #include /* 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 +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 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 /* for longjmp() - see man (3) setjmp */ +jmp_buf env; + +#ifdef sparc8 +#include +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 + /.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(;i999999)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(versionscript 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<>\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("<>\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 + +void filequote(p) /* write p to stdout with 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) + { 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;col0)); } + else + for(r=wp-1-r,col=0;col6) /* 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)=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 , 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 , 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||t20)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 +#include + +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 + +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 */ + diff --git a/toks.m b/toks.m new file mode 100755 index 0000000..1906c1c --- /dev/null +++ b/toks.m @@ -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 $$) $# +%% diff --git a/trans.c b/trans.c new file mode 100644 index 0000000..d78c5cd --- /dev/null +++ b/trans.c @@ -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]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 = 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]] +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;j0)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 ' 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;i2000 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]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||ehd[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]"); + 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("",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 */ + diff --git a/ugroot b/ugroot new file mode 100755 index 0000000..3b08e3a --- /dev/null +++ b/ugroot @@ -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 diff --git a/utf8.c b/utf8.c new file mode 100644 index 0000000..6954f96 --- /dev/null +++ b/utf8.c @@ -0,0 +1,88 @@ +#include +#include +#include +#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); +} diff --git a/utf8.h b/utf8.h new file mode 100644 index 0000000..49e0750 --- /dev/null +++ b/utf8.h @@ -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 +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; diff --git a/y.tab.c b/y.tab.c new file mode 100644 index 0000000..63c82e7 --- /dev/null +++ b/y.tab.c @@ -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 /* needed for printf */ +#endif + +#include /* needed for malloc, etc */ +#include /* 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(n0?"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); +} diff --git a/y.tab.h b/y.tab.h new file mode 100644 index 0000000..e2034e5 --- /dev/null +++ b/y.tab.h @@ -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 -- cgit v1.2.1