remove unused files

1 files changed, 0 insertions, 1613 deletions

diff --git a/new/types.c b/new/types.c
deleted file mode 100644
index f20627f..0000000
--- a/new/types.c
+++ /dev/null
@@ -1,1613 +0,0 @@
-/* MIRANDA TYPECHECKER  */
-
-/**************************************************************************
- * Copyright (C) Research Software Limited 1985-90.  All rights reserved. *
- * The Miranda system is distributed as free software under the terms in  *
- * the file "COPYING" which is included in the distribution.              *
- *------------------------------------------------------------------------*/
-
-#include "data.h"
-#include "big.h"
-word R=NIL;  /* direct-and-indirect dependency graph */
-word TABSTRS=NIL; /* list of abstype declarations */
-word ND;  /* undefined names used in script */
-word SBND; /* names specified but not defined (handled separately) */
-word FBS; /* list of bindings caused by parameterised %include's */
-word ATNAMES; /* global var set by abstr_check */
-word NT=NIL;  /* undefined typenames used in script */
-word TYPERRS;
-word bnf_t=0;
-word current_id=0,lastloc=0,lineptr=0;   /* used to locate type errors */
-word showchain=NIL; /* links together all occurrences of special forms (show)
-		      encountered during typecheck */
-extern word rfl;
-
-#include <setjmp.h>
-jmp_buf env1; /* for longjmp - see man (3) setjmp */
-
-checktypes() /* outcome indicated by setting of flags SYNERR, TYPERRS, ND */
-{ word s;
-  extern word freeids,SYNERR,fnts;
-  ATNAMES=TYPERRS=0;
-  NT=R=SBND=ND=NIL;  /* NT=R= added 4/6/88 */
-  if(setjmp(env1)==1)goto L;
-  if(rfl!=NIL)readoption();
-  for(s=reverse(fil_defs(hd[files]));s!=NIL;s=tl[s])
-     comp_deps(hd[s]);  /* for each identifier in current script, compute
-			      dependencies to form R */
-  R=tclos(sortrel(R));
-  if(FBS!=NIL)mcheckfbs();
-  abstr_mcheck(TABSTRS);
-L:if(TYPERRS)
-    { /* badly formed types, so give up */
-      TABSTRS=NT=R=NIL;
-      printf("typecheck cannot proceed - compilation abandoned\n");
-      SYNERR=1;
-      return; }
-  if(freeids!=NIL)redtfr(freeids);
-  /* printgraph("dependency analysis:",R); /* for debugging */
-  genshfns();
-  if(fnts!=NIL)genbnft();
-  R=msc(R);
-  /* printgraph("strong components:",R); /* for debugging */
-  s=tsort(R);
-  /* printlist("topological sort:",s); /* for debugging */
-  NT=R=NIL; /* must be invariant across the call */
-  while(s!=NIL)infer_type(hd[s]),s=tl[s];
-  checkfbs();
-  while(TABSTRS!=NIL)
-       abstr_check(hd[TABSTRS]),TABSTRS=tl[TABSTRS];
-  if(SBND!=NIL)
-    printlist("SPECIFIED BUT NOT DEFINED: ",alfasort(SBND)),SBND=NIL;
-  fixshows();
-  lastloc=0;
-  return;
-}
-
-/* NOTES
-   let element ::= id | list(id)
-   let graph1 ::= list(cons(id,list(id)))
-   let graph2 ::= list(cons(element,list(id)))
-   we define:
-   comp_deps(id)->builds R::graph1, direct dependencies
-   R=tclos(sortrel(R))::graph1, direct and indirect dependencies
-   msc(R)->collects maximal strong components in R, now R::graph2
-   tsort(graph2)->list(element), topologically sorted
-   infer_type(element)->fills in the id_type field(s) of element
-*/
-/* R occupies quadratic worst-case space - does anyone know a better way? */
-
-comp_deps(n) /* adds to R an entry of the form cons(n,RHS) where n is an
-		identifier and RHS is a list of all the identifiers in the
-                current script upon which n directly depends */
-/* it also meta-typechecks type specifications, and puts them in reduced
-   form, as it goes */
-word n;
-{ word rhs=NIL,r;
-  /* printf("comp_deps(%s)\n",get_id(n)); /* DEBUG */
-  if(id_type(n)==type_t)
-    { if(t_class(n)==algebraic_t)
-        { r=t_info(n);
-          while(r!=NIL) /* meta type check constructors */
-            { current_id=hd[r];
-              id_type(hd[r])=redtvars(meta_tcheck(id_type(hd[r])));
-              r=tl[r]; }
-        }
-      else if(t_class(n)==synonym_t)
-	     current_id=n,t_info(n)=meta_tcheck(t_info(n));
-      else if(t_class(n)==abstract_t)
-	   if(t_info(n)==undef_t)
-	     printf("error: script contains no binding for abstract typename\
- \"%s\"\n",get_id(n)),sayhere(id_who(n),1),TYPERRS++;
-	   else current_id=n,t_info(n)=meta_tcheck(t_info(n));
-	   /* placeholder types - no action */
-      current_id=0;
-      return; }
-  if(tag[id_val(n)]==CONSTRUCTOR)return;
-    /* primitive constructors require no type analysis */
-  if(id_type(n)!=undef_t) /* meta typecheck spec, if present */
-    { current_id=n;
-      if(tag[id_type(n)]==CONS)
-	{ /* signature identifier */
-	  if(id_val(n)==UNDEF)SBND=add1(n,SBND);
-	  id_type(n)=redtvars(meta_tcheck(hd[id_type(n)]));
-	  current_id=0;
-	  return; }  /* typechecked separately, under TABSTRS */
-      id_type(n)=redtvars(meta_tcheck(id_type(n)));
-      current_id=0; }
-  if(id_val(n)==FREE)return; /* no further analysis required */
-  if(id_val(n)==UNDEF) /* name specified but not defined */
-    { SBND=add1(n,SBND); /* change of policy (as for undefined sigid, above) */
-      return; }  /* now not added to ND, so script can be %included */
-  r=deps(id_val(n));
-  while(r!=NIL)
-    { if(id_val(hd[r])!=UNDEF&&id_type(hd[r])==undef_t)
-        /* only defined names without explicitly assigned types
-	   cause dependency */
-        rhs=add1(hd[r],rhs);
-      r=tl[r]; }
-  R=cons(cons(n,rhs),R);
-}
-
-tsort(g) /* topological sort - returns a list of the elements in the domain
-  of relation g, in an order such that each element is preceded by everything
-  it depends on */
-word g;  /* the structure of g is "graph2" see NOTES above */
-{ word NP=NIL; /* NP is set of elements with no predecessor */
-  word g1=g, r=NIL; /* r is result */
-  g=NIL;
-  while(g1!=NIL)
-    { if(tl[hd[g1]]==NIL)NP=cons(hd[hd[g1]],NP);
-      else g=cons(hd[g1],g);
-      g1=tl[g1]; }
-  while(NP!=NIL)
-  { word D=NIL; /* ids to be removed from range of g */
-    while(NP!=NIL)
-    { r=cons(hd[NP],r);
-      if(tag[hd[NP]]==ID)D=add1(hd[NP],D);
-      else D=UNION(D,hd[NP]);
-      NP=tl[NP]; }
-    g1=g;g=NIL;
-    while(g1!=NIL)
-    { word rhs=setdiff(tl[hd[g1]],D);
-      if(rhs==NIL)NP=cons(hd[hd[g1]],NP);
-      else tl[hd[g1]]=rhs,g=cons(hd[g1],g);
-      g1=tl[g1]; }
-  }
-  if(g!=NIL)fprintf(stderr,"error: impossible event in tsort\n");
-  return(reverse(r));
-}
-
-msc(R) /* collects maximal strong components in R, converting it from "graph1"
-          to "graph2" form - destructive in R */
-word R;
-{ word R1=R;
-  while(R1!=NIL)
-  { word *r= &tl[hd[R1]],l=hd[hd[R1]];
-    if(remove1(l,r))
-      { hd[hd[R1]]=cons(l,NIL);
-	while(*r!=NIL)
-	{  word n=hd[*r],*R2= &tl[R1];
-           while(*R2!=NIL&&hd[hd[*R2]]!=n)R2= &tl[*R2]; /* find n-entry in R */
-	   if(*R2!=NIL&&member(tl[hd[*R2]],l))
-	     { *r=tl[*r]; /* remove n from r */
-               *R2=tl[*R2]; /* remove n's entry from R */
-	       hd[hd[R1]]=add1(n,hd[hd[R1]]);
-	     }
-	   else r= &tl[*r];
-	}
-      }
-    R1=tl[R1];
-  }
-  return(R);
-}
-
-word meta_pending=NIL;
-
-meta_tcheck(t) /* returns type t with synonyms substituted out and checks that
-                  the result is well formed */
-word t;
-{ word tn=t,i=0;
-  /* TO DO -- TIDY UP ERROR MESSAGES AND SET ERRLINE (ERRS) IF POSS */
-  while(iscompound_t(tn))
-     tl[tn]=meta_tcheck(tl[tn]),i++,tn=hd[tn];
-  if(tag[tn]==STRCONS)goto L; /* patch to handle free type bindings */
-  if(tag[tn]!=ID)
-    { if(i>0&&(isvar_t(tn)||tn==bool_t||tn==num_t||tn==char_t))
-        { TYPERRS++;
-	  if(tag[current_id]==DATAPAIR)
-	    locate_inc(),
-            printf("badly formed type \""),out_type(t),
-            printf("\" in binding for \"%s\"\n",(char *)hd[current_id]),
-            printf("("),out_type(tn),printf(" has zero arity)\n");
-	  else
-          printf("badly formed type \""),out_type(t),
-          printf("\" in %s for \"%s\"\n",
-            id_type(current_id)==type_t?"== binding":"specification",
-            get_id(current_id)),
-          printf("("),out_type(tn),printf(" has zero arity)\n"),
-	  sayhere(getspecloc(current_id),1); 
-	  sterilise(t); }
-        return(t); }
-  if(id_type(tn)==undef_t&&id_val(tn)==UNDEF)
-    { TYPERRS++;
-      if(!member(NT,tn))
-	{ if(tag[current_id]==DATAPAIR)locate_inc();
-	  printf("undeclared typename \"%s\" ",get_id(tn));
-	  if(tag[current_id]==DATAPAIR)
-	    printf("in binding for %s\n",(char *)hd[current_id]);
-	  else sayhere(getspecloc(current_id),1);
-          NT=add1(tn,NT); }
-      return(t); }else
-  if(id_type(tn)!=type_t||t_arity(tn)!=i)
-    { TYPERRS++;
-      if(tag[current_id]==DATAPAIR)
-	locate_inc(),
-        printf("badly formed type \""),out_type(t),
-        printf("\" in binding for \"%s\"\n",(char *)hd[current_id]);
-      else
-        printf("badly formed type \""),out_type(t),
-        printf("\" in %s for \"%s\"\n",
-          id_type(current_id)==type_t?"== binding":"specification",
-          get_id(current_id));
-      if(id_type(tn)!=type_t)
-        printf("(%s not defined as typename)\n",get_id(tn));
-      else printf("(typename %s has arity %d)\n",get_id(tn),t_arity(tn));
-      if(tag[current_id]!=DATAPAIR)
-        sayhere(getspecloc(current_id),1);
-      sterilise(t);
-      return(t); }
-L:if(t_class(tn)!=synonym_t)return(t);
-  if(member(meta_pending,tn))
-    { TYPERRS++;/* report cycle */
-      if(tag[current_id]==DATAPAIR)locate_inc();
-      printf("error: cycle in type \"==\" definition%s ",
-              meta_pending==NIL?"":"s");
-      printelement(meta_pending); putchar('\n');
-      if(tag[current_id]!=DATAPAIR)
-        sayhere(id_who(tn),1);
-      longjmp(env1,1); /* fatal error - give up */
-/*    t_class(tn)=algebraic_t;t_info(tn)=NIL;
-          /* to make sure we dont fall in here again! */
-      return(t); }
-  meta_pending=cons(tn,meta_pending);
-  tn=NIL;
-  while(iscompound_t(t))
-    tn=cons(tl[t],tn),t=hd[t];
-  t=meta_tcheck(ap_subst(t_info(t),tn));
-  meta_pending=tl[meta_pending];
-  return(t);
-}
-/* needless inefficiency - we recheck the rhs of a synonym every time we
-   use it */
-
-sterilise(t) /* to prevent multiple reporting of metatype errors from
-			namelist :: type	*/
-word t;
-{ if(tag[t]==AP)hd[t]=list_t,tl[t]=num_t;
-}
-
-word tvcount=1;
-#define NTV mktvar(tvcount++)
-  /* brand new type variable */
-#define reset_SUBST  (current_id=tvcount>=hashsize?clear_SUBST():0)
-
-infer_type(x) /* deduces the types of the identifiers in x - no result,
-                  works by filling in id_type fields */
-word x; /* x is an "element" */
-{ if(tag[x]==ID)
-    { word t,oldte=TYPERRS;
-      current_id=x;
-      t = subst(etype(id_val(x),NIL,NIL));
-      if(id_type(x)==undef_t)id_type(x)=redtvars(t);
-      else /* x already has assigned type */
-      if(!subsumes(t,instantiate(id_type(x))))
-	{ TYPERRS++;
-	  printf("incorrect declaration ");
-	  sayhere(getspecloc(x),1); /* or: id_who(x) to locate defn */
-          printf("specified, "); report_type(x); putchar('\n');
-	  printf("inferred,  %s :: ",get_id(x)); out_type(redtvars(t));
-	  putchar('\n'); }
-      if(TYPERRS>oldte)id_type(x)=wrong_t,
-		       id_val(x)=UNDEF,
-		       ND=add1(x,ND);
-      reset_SUBST; }
-  else{ /* recursive group of names */
-	word x1,oldte,ngt=NIL;
-	for(x1=x;x1!=NIL;x1=tl[x1])
-	   ngt=cons(NTV,ngt),
-	   id_type(hd[x1])=ap(bind_t,hd[ngt]);
-	for(x1=x;x1!=NIL;x1=tl[x1])
-	   { oldte=TYPERRS,
-             current_id=hd[x1],
-	     unify(tl[id_type(hd[x1])],etype(id_val(hd[x1]),NIL,ngt));
-	     if(TYPERRS>oldte)
-	       id_type(hd[x1])=wrong_t,
-		id_val(hd[x1])=UNDEF,ND=add1(hd[x1],ND); }
-	for(x1=x;x1!=NIL;x1=tl[x1])
-	   if(id_type(hd[x1])!=wrong_t)
-	     id_type(hd[x1])=redtvars(ult(tl[id_type(hd[x1])]));
-        reset_SUBST;
-      } 
-}
-
-word hereinc; /* location of currently-being-processed %include */
-word lasthereinc;
-
-mcheckfbs()
-{ word ff,formals,n;
-  lasthereinc=0;
-  for(ff=FBS;ff!=NIL;ff=tl[ff])
-     { hereinc=hd[hd[FBS]];
-       for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals])
-          { word t=tl[tl[hd[formals]]];
-            if(t!=type_t)continue;
-            current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
-	    t_info(hd[hd[formals]])=meta_tcheck(t_info(hd[hd[formals]]));
-	    /*ATNAMES=cons(hd[hd[formals]],ATNAMES?ATNAMES:NIL); */
-            current_id=0;
-          }
-       if(TYPERRS)return; /* to avoid misleading error messages */
-       for(formals=tl[hd[ff]];formals!=NIL;formals=tl[formals])
-          { word t=tl[tl[hd[formals]]];
-            if(t==type_t)continue;
-            current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
-            tl[tl[hd[formals]]]=redtvars(meta_tcheck(t));
-            current_id=0;
-          }
-     /* above double traverse is very inefficient way of doing types first
-	would be better to have bindings sorted in this order beforehand */
-     }
-  /* all imported names must now have their types reduced to
-     canonical form wrt the parameter bindings */
-  /* alternative method - put info in ATNAMES, see above and in abstr_check */
-  /* a problem with this is that types do not print in canonical form */
-  if(TYPERRS)return;
-  for(ff=tl[files];ff!=NIL;ff=tl[ff])
-  for(formals=fil_defs(hd[ff]);formals!=NIL;formals=tl[formals])
-  if(tag[n=hd[formals]]==ID)
-  if(id_type(n)==type_t)
-    { if(t_class(n)==synonym_t)t_info(n)=meta_tcheck(t_info(n)); }
-  else id_type(n)=redtvars(meta_tcheck(id_type(n)));
-} /* wasteful if many includes */
-
-redtfr(x) /* ensure types of freeids are in reduced form */
-word x;
-{ for(;x!=NIL;x=tl[x])
-     tl[tl[hd[x]]] = id_type(hd[hd[x]]);
-}
-
-checkfbs()
-/* FBS is list of entries of form cons(hereinfo,formals) where formals
-   has elements of form cons(id,cons(datapair(orig,0),type)) */
-{ word oldte=TYPERRS,formals;
-  lasthereinc=0;
-  for(;FBS!=NIL;FBS=tl[FBS])
-  for(hereinc=hd[hd[FBS]],formals=tl[hd[FBS]];
-      formals!=NIL;formals=tl[formals])
-  { word t,t1=fix_type(tl[tl[hd[formals]]]);
-    if(t1==type_t)continue;
-    current_id=hd[tl[hd[formals]]]; /* nb datapair(orig,0) not id */
-    t = subst(etype(the_val(hd[hd[formals]]),NIL,NIL));
-    if(!subsumes(t,instantiate(t1)))
-	{ TYPERRS++;
-	  locate_inc();
-	  printf("binding for parameter `%s' has wrong type\n",
-		 (char *)hd[current_id]);
-	  printf(  "required :: "); out_type(tl[tl[hd[formals]]]);
-	  printf("\n  actual :: "); out_type(redtvars(t));
-	  putchar('\n'); }
-    the_val(hd[hd[formals]])=codegen(the_val(hd[hd[formals]])); }
-  if(TYPERRS>oldte)
-    { /* badly typed parameter bindings, so give up */
-      extern word SYNERR;
-      TABSTRS=NT=R=NIL;
-      printf("compilation abandoned\n");
-      SYNERR=1; }
-  reset_SUBST;
-}
-
-fix_type(t,x)  /* substitute out any indirected typenames in t */
-word t,x;
-{ switch(tag[t])
-  { case AP: 
-    case CONS: tl[t]=fixtype(tl[t],x);
-               hd[t]=fixtype(hd[t],x);
-    default:   return(t);
-    case STRCONS: while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/
-		  return(t);
-  }
-}
-
-locate_inc()
-{ if(lasthereinc==hereinc)return;
-  printf("incorrect %%include directive ");
-  sayhere(lasthereinc=hereinc,1);
-}
-
-abstr_mcheck(tabstrs) /* meta-typecheck abstract type declarations */
-word tabstrs;
-{ while(tabstrs!=NIL)
-     { word atnames=hd[hd[tabstrs]],sigids=tl[hd[tabstrs]],rtypes=NIL;
-       if(cyclic_abstr(atnames))return;
-       while(sigids!=NIL) /* compute representation types */
-          { word rt=rep_t(id_type(hd[sigids]),atnames);
-          /*if(rt==id_type(hd[sigids]))
-     	 printf("abstype declaration error: \"%s\" has a type unrelated to \
-the abstraction\n",get_id(hd[sigids])),
-	       sayhere(getspecloc(hd[sigids]),1),
-	       TYPERRS++; /* suppressed June 89, see karen.m, secret.m */
-            rtypes=cons(rt,rtypes);
-	    sigids=tl[sigids]; }
-       rtypes=reverse(rtypes);
-       hd[hd[tabstrs]]=cons(hd[hd[tabstrs]],rtypes);
-       tabstrs=tl[tabstrs];
-     }
-}
-
-abstr_check(x) /* typecheck the implementation equations of a type abstraction
-		  with the given signature */
-word x;
-{ word rtypes=tl[hd[x]],sigids=tl[x];
-/*int holdat=ATNAMES;
-  ATNAMES=shunt(hd[hd[x]],ATNAMES); */
-  ATNAMES=hd[hd[x]];
-  txchange(sigids,rtypes);  /* install representation types */
-  /* report_types("concrete signature:\n",sigids); /* DEBUG */
-  for(x=sigids;x!=NIL;x=tl[x])
-     { word t,oldte=TYPERRS;
-       current_id=hd[x];
-       t=subst(etype(id_val(hd[x]),NIL,NIL));
-       if(!subsumes(t,instantiate(id_type(hd[x]))))
-	 { TYPERRS++;
-	   printf("abstype implementation error\n");
-	   printf("\"%s\" is bound to value of type: ",get_id(hd[x]));
-	   out_type(redtvars(t));
-	   printf("\ntype expected: ");
-	   out_type(id_type(hd[x]));
-	   putchar('\n');
-	   sayhere(id_who(hd[x]),1); }
-       if(TYPERRS>oldte)
-	 id_type(hd[x])=wrong_t,id_val(hd[x])=UNDEF,ND=add1(hd[x],ND);
-       reset_SUBST; }
-  /* restore the abstract types - for "finger" */
-  for(x=sigids;x!=NIL;x=tl[x],rtypes=tl[rtypes])
-     if(id_type(hd[x])!=wrong_t)id_type(hd[x])=hd[rtypes];
-  ATNAMES= /* holdat */ 0;
-}
-
-cyclic_abstr(atnames) /* immediately-cyclic acts of dta are illegal */
-word atnames;
-{ word x,y=NIL;
-  for(x=atnames;x!=NIL;x=tl[x])y=ap(y,t_info(hd[x]));
-  for(x=atnames;x!=NIL;x=tl[x])
-  if(occurs(hd[x],y))
-    { printf("illegal type abstraction: cycle in \"==\" binding%s ",
-	     tl[atnames]==NIL?"":"s");
-      printelement(atnames); putchar('\n');
-      sayhere(id_who(hd[x]),1);
-      TYPERRS++; return(1); }
-  return(0);
-}
-
-txchange(ids,x)  /* swap the id_type of each id with the corresponding type 
-		    in the list x */
-word ids,x;
-{ while(ids!=NIL)
-       { word t=id_type(hd[ids]);
-	 id_type(hd[ids])=hd[x],hd[x]=t;
-	 ids=tl[ids],x=tl[x]; }
-}
-
-report_type(x)
-word x;
-{ printf("%s",get_id(x));
-  if(id_type(x)==type_t)
-  if(t_arity(x)>5)printf("(arity %d)",t_arity(x));
-  else { word i,j;
-	 for(i=1;i<=t_arity(x);i++)
-	    { putchar(' ');
-	      for(j=0;j<i;j++)putchar('*'); }
-       }
-  printf(" :: ");
-  out_type(id_type(x));
-}
-
-report_types(header,x)
-char *header;
-word x;
-{ printf("%s",header);
-  while(x!=NIL)
-       report_type(hd[x]),putchar(';'),x=tl[x];
-  putchar('\n');
-}
-
-typesfirst(x)  /* rearrange list of ids to put types first */
-word x;
-{ word *y= &x,z=NIL;
-  while(*y!=NIL)
-       if(id_type(hd[*y])==type_t)
-         z=cons(hd[*y],z),*y=tl[*y];
-       else y= &tl[*y];
-  return(shunt(z,x));
-}
-
-rep_t1(T,L) /* computes the representation type corresponding to T, wrt the
-              abstract typenames in L */
-	   /* will need to apply redtvars to result, see below */
-           /* if no substitutions found, result is identically T */
-word T,L;
-{ word args=NIL,t1,new=0;
-  for(t1=T;iscompound_t(t1);t1=hd[t1])
-     { word a=rep_t1(tl[t1],L);
-       if(a!=tl[t1])new=1;
-       args=cons(a,args); }
-  if(member(L,t1))return(ap_subst(t_info(t1),args));
-    	/* call to redtvars removed 26/11/85
-       	   leads to premature normalisation of subterms */
-  if(!new)return(T);
-  while(args!=NIL)
-       t1=ap(t1,hd[args]),args=tl[args];
-  return(t1);
-}
-
-rep_t(T,L) /* see above */
-word T,L;
-{ word t=rep_t1(T,L);
-  return(t==T?t:redtvars(t));
-}
-
-type_of(x)  /* returns the type of expression x, in reduced form */
-word x;
-{ word t;
-  TYPERRS=0;
-  t=redtvars(subst(etype(x,NIL,NIL)));
-  fixshows();
-  if(TYPERRS>0)t=wrong_t;
-  return(t);
-}
-
-checktype(x)  /* is expression x well-typed ? */
-           /* not currently used */
-word x;
-{ TYPERRS=0;
-  etype(x,NIL,NIL);
-  reset_SUBST;
-  return(!TYPERRS);
-}
-
-#define bound_t(t) (iscompound_t(t)&&hd[t]==bind_t)
-#define tf(a,b) ap2(arrow_t,a,b)
-#define tf2(a,b,c) tf(a,tf(b,c))
-#define tf3(a,b,c,d) tf(a,tf2(b,c,d))
-#define tf4(a,b,c,d,e) tf(a,tf3(b,c,d,e))
-#define lt(a) ap(list_t,a)
-#define pair_t(x,y) ap2(comma_t,x,ap2(comma_t,y,void_t))
-
-word tfnum,tfbool,tfbool2,tfnum2,tfstrstr,tfnumnum,ltchar,
-    tstep,tstepuntil;
-
-tsetup()
-{ tfnum=tf(num_t,num_t);
-  tfbool=tf(bool_t,bool_t);
-  tfnum2=tf(num_t,tfnum);
-  tfbool2=tf(bool_t,tfbool);
-  ltchar=lt(char_t);
-  tfstrstr=tf(ltchar,ltchar);
-  tfnumnum=tf(num_t,num_t);
-  tstep=tf2(num_t,num_t,lt(num_t));
-  tstepuntil=tf(num_t,tstep);
-}
-
-word exec_t=0,read_t=0,filestat_t=0; /* set lazily, when used */
-
-genlstat_t() /* type of %lex state */
-{ return(pair_t(num_t,num_t)); }
-
-genbnft()  /* if %bnf used, find out input type of parsing fns */
-{ word bnftokenstate=findid("bnftokenstate");
-  if(bnftokenstate!=NIL&&id_type(bnftokenstate)==type_t)
-  if(t_arity(bnftokenstate)==0)
-    bnf_t=t_class(bnftokenstate)==synonym_t?
-          t_info(bnftokenstate):bnftokenstate;
-  else printf("warning - bnftokenstate has arity>0 (ignored by parser)\n"),
-       bnf_t=void_t;
-  else bnf_t=void_t;  /* now bnf_t holds the state type */
-  bnf_t=ap2(comma_t,ltchar,ap2(comma_t,bnf_t,void_t));
-} /* the input type for parsers is lt(bnf_t)
-     note that tl[hd[tl[bnf_t]]] holds the state type */
-
-extern word col_fn;
-
-checkcolfn()  /* if offside rule used, check col_fn has right type */
-{ word t=id_type(col_fn),f=tf(tl[hd[tl[bnf_t]]],num_t);
-  if(t==undef_t||t==wrong_t 
-      /* will be already reported - do not generate further typerrs
-         in both cases col_fn will behave as undefined name */
-    ||subsumes(instantiate(t),f))
-    { col_fn=0; return; } /* no further action required */
-  printf("`bnftokenindentation' has wrong type for use in offside rule\n");
-  printf("type required :: "); out_type(f); putchar('\n');
-  printf("  actual type :: "); out_type(t); putchar('\n');
-  sayhere(getspecloc(col_fn),1);
-  TYPERRS++;
-  col_fn= -1; /* error flag */
-} /* note that all parsing fns get type wrong_t if offside rule used
-     anywhere and col_fn has wrong type - strictly this is overkill */
-
-etype(x,env,ngt) /* infer a type for an expression, by using unification */
-word x,env;   /* env is list of local bindings of variables to types */
-word ngt;     /* ngt is list of non-generic type variables */
-{ word a,b,c,d; /* initialise to 0 ? */
-  switch(tag[x])
-  { case AP: if(hd[x]==BADCASE||hd[x]==CONFERROR)return(NTV);
-	     /* don't type check insides of error messages */
-             { word ft=etype(hd[x],env,ngt),at=etype(tl[x],env,ngt),rt=NTV;
-               if(!unify1(ft,ap2(arrow_t,at,rt)))
-                 { ft=subst(ft);
-                   if(isarrow_t(ft))
-                     if(tag[hd[x]]==AP&&hd[hd[x]]==G_ERROR)
-                        type_error8(at,tl[hd[ft]]);
-                     else
-                     type_error("unify","with",at,tl[hd[ft]]);
-                   else type_error("apply","to",ft,at);
-		   return(NTV); }
-	       return(rt); }
-    case CONS: { word ht=etype(hd[x],env,ngt),rt=etype(tl[x],env,ngt);
-		 if(!unify1(ap(list_t,ht),rt))
-                   { type_error("cons","to",ht,rt);
-		     return(NTV); }
-		 return(rt); }
-    case LEXER: { word hold=lineptr;
-                  lineptr=hd[tl[tl[hd[x]]]];
-                  tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label(hereinf,-)*/
-                  a=etype(tl[tl[hd[x]]],env,ngt);
-                  while((x=tl[x])!=NIL)
-                       { lineptr=hd[tl[tl[hd[x]]]];
-                         tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]];/*discard label... */
-                         if(!unify1(a,b=etype(tl[tl[hd[x]]],env,ngt)))
-                           { type_error7(a,b);
-                             lineptr=hold;
-                             return(NTV); }
-                       }
-                  lineptr=hold;
-                  return(tf(ltchar,lt(a))); }
-    case TCONS: return(ap2(comma_t,etype(hd[x],env,ngt),
-		       etype(tl[x],env,ngt)));
-    case PAIR: return(ap2(comma_t,etype(hd[x],env,ngt),
-		      ap2(comma_t,etype(tl[x],env,ngt),void_t)));
-    case DOUBLE:
-    case INT: return(num_t);
-    case ID:  a=env;
-	      while(a!=NIL) /* take local binding, if present */
-		   if(hd[hd[a]]==x)
-		     return(linst(tl[hd[a]]=subst(tl[hd[a]]),ngt));
-		   else a=tl[a];
-	      a=id_type(x); /* otherwise pick up global binding */
-	      if(bound_t(a))return(tl[a]);
-              if(a==type_t)type_error1(x);
-	      if(a==undef_t)
-	        { extern word commandmode;
-		  if(commandmode)type_error2(x);
-		  else
-		  if(!member(ND,x))  /* report first occurrence only */
-		    { if(lineptr)sayhere(lineptr,0);
-                      else if(tag[current_id]==DATAPAIR) /* see checkfbs */
-			   locate_inc();
-		      printf("undefined name \"%s\"\n",get_id(x));
-                      ND=add1(x,ND); }
-		  return(NTV); }
-	      if(a==wrong_t)return(NTV);
-              return(instantiate(ATNAMES?rep_t(a,ATNAMES):a));
-    case LAMBDA: a=NTV; b=NTV;
-		 d=cons(a,ngt);
-		 c=conforms(hd[x],a,env,d);
-		 if(c==-1||!unify(b,etype(tl[x],c,d)))return(NTV);
-		 return(tf(a,b));
-    case LET: { word e,def=hd[x];
-		a=NTV,e=conforms(dlhs(def),a,env,cons(a,ngt));
-		current_id=cons(dlhs(def),current_id);
-	        c=lineptr; lineptr=dval(def);
-		b = unify(a,etype(dval(def),env,ngt));
-		lineptr=c;
-		current_id=tl[current_id];
-		if(e==-1||!b)return(NTV);
-		return(etype(tl[x],e,ngt)); }
-    case LETREC: { word e=env,s=NIL;
-		   a=NIL; c=ngt;
-		   for(d=hd[x];d!=NIL;d=tl[d])
-		      if(dtyp(hd[d])==undef_t)
-		         a=cons(hd[d],a), /* unspecified defs */
-			 dtyp(hd[d])=(b=NTV),
-		         c=cons(b,c),  /* collect non-generic tvars */
-		         e=conforms(dlhs(hd[d]),b,e,c);
-		      else dtyp(hd[d])=meta_tcheck(dtyp(hd[d])),
-		           /* should do earlier, and locate errs properly*/
-			   s=cons(hd[d],s), /* specified defs */
-			   e=cons(cons(dlhs(hd[d]),dtyp(hd[d])),e);
-		   if(e==-1)return(NTV);
-		   b=1;
-		   for(;a!=NIL;a=tl[a])
-		      { current_id=cons(dlhs(hd[a]),current_id);
-		        d=lineptr; lineptr=dval(hd[a]);
-		        b &= unify(dtyp(hd[a]),etype(dval(hd[a]),e,c));
-		        lineptr=d; current_id=tl[current_id]; }
-		   for(;s!=NIL;s=tl[s])
-		      { current_id=cons(dlhs(hd[s]),current_id);
-		        d=lineptr; lineptr=dval(hd[s]);
-		        if(!subsumes(a=etype(dval(hd[s]),e,ngt),
-				       linst(dtyp(hd[s]),ngt)))
-		       /* would be better to set lineptr to spec here */
-			  b=0,type_error6(dlhs(hd[s]),dtyp(hd[s]),a);
-		        lineptr=d; current_id=tl[current_id]; }
-		   if(!b)return(NTV);
-		   return(etype(tl[x],e,ngt)); }
-    case TRIES: { word hold=lineptr;
-		  a=NTV;
-		  x=tl[x];
-		  while(x!=NIL&&(lineptr=hd[hd[x]],
-		                 unify(a,etype(tl[hd[x]],env,ngt)))
-		       )x=tl[x];
-		  lineptr=hold;
-		  if(x!=NIL)return(NTV);
-		  return(a); }
-    case LABEL: { word hold=lineptr,t;
-		  lineptr=hd[x];
-		  t=etype(tl[x],env,ngt);
-		  lineptr=hold;
-		  return(t); }
-    case STARTREADVALS: if(tl[x]==0)
-			  hd[x]=lineptr, /* insert here-info */
-			  tl[x]=NTV,
-	                  showchain=cons(x,showchain);
-	                return(tf(ltchar,lt(tl[x])));
-    case SHOW: hd[x]=lineptr; /* insert here-info */
-	       showchain=cons(x,showchain);
-	       return(tf(tl[x]=NTV,ltchar));
-    case SHARE: if(tl[x]==undef_t)
-		  { word h=TYPERRS;
-		    tl[x]=subst(etype(hd[x],env,ngt));
-		    if(TYPERRS>h)hd[x]=UNDEF,tl[x]=wrong_t; }
-		if(tl[x]==wrong_t)
-		  { TYPERRS++; return(NTV); }
-		return(tl[x]);
-    case CONSTRUCTOR: a=id_type(tl[x]);
-                      return(instantiate(ATNAMES?rep_t(a,ATNAMES):a));
-    case UNICODE: return(char_t);
-    case ATOM: if(x<256)return(char_t);
-               switch(x)
-               { 
-               case S:a=NTV,b=NTV,c=NTV;
-                      d=tf3(tf2(a,b,c),tf(a,b),a,c);
-                      return(d);
-               case K:a=NTV,b=NTV;
-                      return(tf2(a,b,a));
-               case Y:a=NTV;
-                      return(tf(tf(a,a),a));
-               case C:a=NTV,b=NTV,c=NTV;
-                      return(tf3(tf2(a,b,c),b,a,c));
-               case B:a=NTV,b=NTV,c=NTV;
-		      return(tf3(tf(a,b),tf(c,a),c,b));
-	       case FORCE:
-	       case G_UNIT:
-	       case G_RULE:
-               case I:a=NTV;
-                      return(tf(a,a));
-               case G_ZERO:return(NTV);
-               case HD:a=NTV;
-                       return(tf(lt(a),a));
-               case TL:a=lt(NTV);
-                       return(tf(a,a));
-               case BODY:a=NTV,b=NTV;
-			 return(tf(ap(a,b),a));
-               case LAST:a=NTV,b=NTV;
-			 return(tf(ap(a,b),b));
-               case S_p:a=NTV,b=NTV;
-			c=lt(b);
-			return(tf3(tf(a,b),tf(a,c),a,c));
-               case U:
-               case U_: a=NTV,b=NTV;
-			c=lt(a);
-			return(tf2(tf2(a,c,b),c,b));
-               case Uf: a=NTV,b=NTV,c=NTV;
-                        return(tf2(tf2(tf(a,b),a,c),b,c));
-               case COND: a=NTV;
-			  return(tf3(bool_t,a,a,a));
-               case EQ:case GR:case GRE:
-               case NEQ: a=NTV;
-			 return(tf2(a,a,bool_t));
-	       case NEG: return(tfnum);
-               case AND:
-               case OR: return(tfbool2);
-               case NOT: return(tfbool);
-	       case MERGE:
-               case APPEND: a=lt(NTV);
-			    return(tf2(a,a,a));
-	       case STEP: return(tstep);
-	       case STEPUNTIL: return(tstepuntil);
-	       case MAP: a=NTV; b=NTV;
-			 return(tf2(tf(a,b),lt(a),lt(b)));
-	       case FLATMAP: a=NTV,b=lt(NTV);
-			     return(tf2(tf(a,b),lt(a),b));
-	       case FILTER: a=NTV; b=lt(a);
-			    return(tf2(tf(a,bool_t),b,b));
-  	       case ZIP: a=NTV; b=NTV;
-			 return(tf2(lt(a),lt(b),lt(pair_t(a,b))));
-	       case FOLDL: a=NTV; b=NTV;
-			   return(tf3(tf2(a,b,a),a,lt(b),a));
-	       case FOLDL1: a=NTV;
-			    return(tf2(tf2(a,a,a),lt(a),a));
-	       case LIST_LAST: a=NTV;
-			       return(tf(lt(a),a));
-	       case FOLDR: a=NTV; b=NTV;
-			   return(tf3(tf2(a,b,b),b,lt(a),b));
-	       case MATCHINT:
-               case MATCH: a=NTV,b=NTV;
-			   return(tf3(a,b,a,b));
-               case TRY: a=NTV;
-			 return(tf2(a,a,a));
-	       case DROP:
-               case TAKE: a=lt(NTV);
-			  return(tf2(num_t,a,a));
-               case SUBSCRIPT:a=NTV;
-			      return(tf2(num_t,lt(a),a));
-               case P: a=NTV;
-		       b=lt(a);
-		       return(tf2(a,b,b));
-               case B_p: a=NTV,b=NTV;
-			 c=lt(a);
-			 return(tf3(a,tf(b,c),b,c));
-               case C_p: a=NTV,b=NTV;
-			 c=lt(b);
-			 return(tf3(tf(a,b),c,a,c));
-               case S1: a=NTV,b=NTV,c=NTV,d=NTV;
-			return(tf4(tf2(a,b,c),tf(d,a),tf(d,b),d,c));
-               case B1: a=NTV,b=NTV,c=NTV,d=NTV;
-			return(tf4(tf(a,b),tf(c,a),tf(d,c),d,b));
-               case C1: a=NTV,b=NTV,c=NTV,d=NTV;
-			return(tf4(tf2(a,b,c),tf(d,a),b,d,c));
-	       case SEQ: a=NTV,b=NTV;
-			 return(tf2(a,b,b));
-	       case ITERATE1:
-	       case ITERATE: a=NTV;
-			     return(tf2(tf(a,a),a,lt(a)));
-               case EXEC: { if(!exec_t)
-                              a=ap2(comma_t,ltchar,ap2(comma_t,num_t,void_t)),
-                              exec_t=tf(ltchar,ap2(comma_t,ltchar,a));
-                            return(exec_t); }
-	       case READBIN:
-               case READ: { if(!read_t)
-                              read_t=tf(char_t,ltchar);
-                            /* $- is ap(READ,0) */
-                            return(read_t); }
-               case FILESTAT: { if(!filestat_t)
-                  filestat_t=tf(ltchar,pair_t(pair_t(num_t,num_t),num_t));
-                                return(filestat_t); }
-	       case FILEMODE:
-	       case GETENV:
-	       case NB_STARTREAD:
-	       case STARTREADBIN:
-	       case STARTREAD: return(tfstrstr);
-               case GETARGS: return(tf(char_t,lt(ltchar)));
-               case SHOWHEX:
-               case SHOWOCT:
-	       case SHOWNUM: return(tf(num_t,ltchar));
-	       case SHOWFLOAT:
-	       case SHOWSCALED: return(tf2(num_t,num_t,ltchar));
-	       case NUMVAL: return(tf(ltchar,num_t));
-	       case INTEGER: return(tf(num_t,bool_t));
-	       case CODE: return(tf(char_t,num_t));
-	       case DECODE: return(tf(num_t,char_t));
-	       case LENGTH: return(tf(lt(NTV),num_t));
-	       case ENTIER_FN: case ARCTAN_FN: case EXP_FN: case SIN_FN:
-	       case COS_FN: case SQRT_FN: case LOG_FN: case LOG10_FN:
-			    return(tfnumnum);
-               case MINUS:case PLUS:case TIMES:case INTDIV:case FDIV:
-               case MOD:case POWER: return(tfnum2);
-	       case True: case False: return(bool_t);
-	       case NIL: a=lt(NTV);
-                         return(a);
-	       case NILS: return(ltchar);
-               case MKSTRICT: a=NTV;
-			      return(tf(char_t,tf(a,a)));
-/* the following are not the true types of the G_fns, which have the action
-   	Ai->lt(bnf_t)->(B:lt(bnf_t))
-   here represented by the type Ai->B.  G_CLOSE interfaces the parser fns to
-   the outside world */
-	       case G_ALT: a=NTV;
-			   return(tf2(a,a,a));
-	       case G_ERROR: a=NTV;
-			     return(tf2(a,tf(lt(bnf_t),a),a));
-	       case G_OPT:
-	       case G_STAR: a=NTV;
-			    return(tf(a,lt(a)));
-	       case G_FBSTAR: a=NTV; b=tf(a,a);
-			      return(tf(b,b));
-	       case G_SYMB: return(tfstrstr);
-	       case G_ANY: return(ltchar);
-	       case G_SUCHTHAT: return(tf(tf(ltchar,bool_t),ltchar));
-	       case G_END: return(lt(bnf_t));
-	       case G_STATE: return(tl[hd[tl[bnf_t]]]);
-	       case G_SEQ: a=NTV; b=NTV;
-			   return(tf2(a,tf(a,b),b));
-	       /* G_RULE has same type as I */
-	       case G_CLOSE: a=NTV;
-			     if(col_fn) /* offside rule used */
-			     if(col_fn== -1) /* arbitrary flag */
-			       TYPERRS++; /*overkill, see note on checkcolfn*/
-			     else checkcolfn();
-			     return(tf3(ltchar,a,lt(bnf_t),a));
-	       case OFFSIDE: return(ltchar);
-			     /* pretend, used by indent, see prelude */
-	       case FAIL: /* compiled from last guard on rhs */
-	       case CONFERROR:
-	       case BADCASE:
-	       case UNDEF: return(NTV);
-	       case ERROR: return(tf(ltchar,NTV));
-               default: printf("do not know type of ");
-                        out(stdout,x);
-                        putchar('\n');
-                        return(wrong_t);
-               }
-    default: printf("unexpected tag in etype ");
-	     out(stdout,tag[x]);
-	     putchar('\n');
-	     return(wrong_t);
-  }
-}
-
-rhs_here(r)
-word r;
-{ if(tag[r]==LABEL)return(hd[r]);
-  if(tag[r]==TRIES)return(hd[hd[lastlink(tl[r])]]);
-  return(0); /* something wrong */
-} /* efficiency hack, sometimes we set lineptr to rhs, can extract here_info
-     as above when needed */
-
-conforms(p,t,e,ngt) /* returns new environment of local type bindings obtained
-		       by conforming pattern p to type t; -1 means failure */
-word p,t,e,ngt;
-{ if(e==-1)return(-1);
-  if(tag[p]==ID&&!isconstructor(p))return(cons(cons(p,t),e));
-  if(hd[p]==CONST)
-    { unify(etype(tl[p],e,ngt),t); return(e); }
-  if(tag[p]==CONS)
-    { word at=NTV;
-      if(!unify(lt(at),t))return(-1);
-      return(conforms(tl[p],t,conforms(hd[p],at,e,ngt),ngt)); }
-  if(tag[p]==TCONS)
-    { word at=NTV,bt=NTV;
-      if(!unify(ap2(comma_t,at,bt),t))return(-1);
-      return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); }
-  if(tag[p]==PAIR)
-    { word at=NTV,bt=NTV;
-      if(!unify(ap2(comma_t,at,ap2(comma_t,bt,void_t)),t))return(-1);
-      return(conforms(tl[p],bt,conforms(hd[p],at,e,ngt),ngt)); }
-  if(tag[p]==AP&&tag[hd[p]]==AP&&hd[hd[p]]==PLUS) /* n+k pattern */
-    { if(!unify(num_t,t))return(1);
-      return(conforms(tl[p],num_t,e,ngt)); }
-{ word p_args=NIL,pt;
-  while(tag[p]==AP)p_args=cons(tl[p],p_args),p=hd[p];
-  if(!isconstructor(p))
-    { type_error4(p); return(-1); }
-  if(id_type(p)==undef_t)
-    { type_error5(p); return(-1); }
-  pt= /*instantiate(id_type(p)); */
-     instantiate(ATNAMES?rep_t(id_type(p),ATNAMES):id_type(p));
-  while(p_args!=NIL&&isarrow_t(pt))
-       { e=conforms(hd[p_args],tl[hd[pt]],e,ngt),pt=tl[pt],p_args=tl[p_args];
-	 if(e==-1)return(-1); }
-  if(p_args!=NIL||isarrow_t(pt)){ type_error3(p); return(-1); }
-  if(!unify(pt,t))return(-1);
-  return(e);
-}}
-
-locate(s) /* for locating type errors */
-char *s;
-{ TYPERRS++;
-  if(TYPERRS==1||lastloc!=current_id) /* avoid tedious repetition */
-    if(current_id)
-    if(tag[current_id]==DATAPAIR) /* see checkfbs */
-      { locate_inc();
-        printf("%s in binding for %s\n",s,(char *)hd[current_id]);
-	return; }
-    else
-      { extern word fnts;
-	word x=current_id;
-        printf("%s in definition of ",s);
-        while(tag[x]==CONS)
-	     if(tag[tl[x]]==ID&&member(fnts,tl[x]))
-	       printf("nonterminal "),x=hd[x]; else /*note1*/
-	     out_formal1(stdout,hd[x]),printf(", subdef of "),
-	     x=tl[x];
-        printf("%s",get_id(x));
-        putchar('\n'); }
-    else printf("%s in expression\n",s);
-  if(lineptr)sayhere(lineptr,0); else
-  if(current_id&&id_who(current_id)!=NIL)sayhere(id_who(current_id),0);
-  lastloc=current_id;
-}
-/* note1: this is hack to suppress extra `subdef of <fst start symb>' when
-   reporting error in defn of non-terminal in %bnf stuff */
-
-sayhere(h,nl) /* h is hereinfo - reports location (in parens, newline if nl)
-	         and sets errline/errs if not already set */
-word h,nl;
-{ extern word errs,errline;
-  extern char *current_script;
-  if(tag[h]!=FILEINFO)
-    { h=rhs_here(h); 
-      if(tag[h]!=FILEINFO)
-        { fprintf(stderr,"(impossible event in sayhere)\n"); return; }}
-  printf("(line %3d of %s\"%s\")",tl[h],
-          (char *)hd[h]==current_script?"":"%insert file ",(char *)hd[h]);
-  if(nl)putchar('\n'); else putchar(' ');
-  if((char *)hd[h]==current_script)
-    { if(!errline) /* tells editor where first error is */
-        errline=tl[h]; }
-  else { if(!errs)errs=h; }
-}
-
-type_error(a,b,t1,t2)
-char *a,*b;
-word t1,t2;
-{ t1=redtvars(ap(subst(t1),subst(t2)));
-  t2=tl[t1];t1=hd[t1];
-  locate("type error");
-  printf("cannot %s ",a);out_type(t1);
-  printf(" %s ",b);out_type(t2);putchar('\n');
-}
-
-type_error1(x)    /* typename in expression */
-word x;
-{ locate("type error");
-  printf("typename used as identifier (%s)\n",get_id(x));
-}
-
-type_error2(x)    /* undefined name in expression */
-word x;
-{ if(compiling)return; /* treat as type error only in $+ data */
-  TYPERRS++;
-  printf("undefined name - %s\n",get_id(x));
-}
-
-type_error3(x)    /* constructor used at wrong arity in formal */
-word x;
-{ locate("error");
-  printf("constructor \"%s\" used at wrong arity in formal\n", get_id(x));
-}
-
-type_error4(x) /* non-constructor as head of formal */
-word x;
-{ locate("error");
-  printf("illegal object \""); out_pattern(stdout,x);
-  printf("\" as head of formal\n");
-}
-
-type_error5(x) /* undeclared constructor in formal */
-word x;
-{ locate("error");
-  printf("undeclared constructor \""); out_pattern(stdout,x);
-  printf("\" in formal\n");
-  ND=add1(x,ND);
-}
-
-type_error6(x,f,a)
-word x,f,a;
-{ TYPERRS++;
-  printf("incorrect declaration "); sayhere(lineptr,1);
-  printf("specified, %s :: ",get_id(x)); out_type(f); putchar('\n');
-  printf("inferred,  %s :: ",get_id(x)); out_type(redtvars(subst(a)));
-  putchar('\n');
-}
-
-type_error7(t,args)
-word t,args;
-{ word i=1;
-  while((args=tl[args])!=NIL)i++;
-  locate("type error");
-  printf(i==1?"1st":i==2?"2nd":i==3?"3rd":"%dth",i);
-  printf(" arg of zip has type :: ");
-  out_type(redtvars(subst(t)));
-  printf("\n - should be list\n");
-}
-
-type_error8(t1,t2)
-word t1,t2;
-{ word big;
-  t1=subst(t1); t2=subst(t2);
-  if(same(hd[t1],hd[t2]))
-    t1=tl[t1],t2=tl[t2]; /* discard `[bnf_t]->' */
-  t1=redtvars(ap(t1,t2));
-  t2=tl[t1];t1=hd[t1];
-  big = size(t1)>=10 || size(t2)>=10;
-  locate("type error");
-  printf("cannot unify%s ",big?"\n ":"");out_type(t1);
-  printf(big?"\nwith\n  ":" with ");out_type(t2);putchar('\n');
-}
-
-unify(t1,t2) /* works by side-effecting SUBST, returns 1,0 as it succeeds
-		or fails */
-word t1,t2;
-{ t1=subst(t1),t2=subst(t2);
-  if(t1==t2)return(1);
-  if(isvar_t(t1)&&!occurs(t1,t2))
-  { addsubst(t1,t2); return(1); }
-  if(isvar_t(t2)&&!occurs(t2,t1))
-  { addsubst(t2,t1); return(1); }
-  if(iscompound_t(t1)&&iscompound_t(t2)&&
-      unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2]))return(1);
-  type_error("unify","with",t1,t2);
-  return(0);
-}
-
-unify1(t1,t2) /* inner call - exactly like unify, except error reporting is
-                 done only by top level, see above */
-         /* we do this to avoid printing inner parts of types */
-word t1,t2;
-{ t1=subst(t1),t2=subst(t2);
-  if(t1==t2)return(1);
-  if(isvar_t(t1)&&!occurs(t1,t2))
-  { addsubst(t1,t2); return(1); }
-  if(isvar_t(t2)&&!occurs(t2,t1))
-  { addsubst(t2,t1); return(1); }
-  if(iscompound_t(t1)&&iscompound_t(t2))
-  return(unify1(hd[t1],hd[t2])&&unify1(tl[t1],tl[t2]));
-  return(0);
-}
-
-subsumes(t1,t2) /* like unify but lop-sided; returns 1,0 as t2 falls, doesnt
-		   fall under t1 */
-word t1,t2;
-{ if(t2==wrong_t)return(1);
-  /* special case, shows up only when compiling prelude (changetype etc) */
-  return(subsu1(t1,t2,t2)); }
-
-subsu1(t1,t2,T2)
-word t1,t2,T2;
-{ t1=subst(t1);
-  if(t1==t2)return(1);
-  if(isvar_t(t1)&&!occurs(t1,T2))
-    { addsubst(t1,t2); return(1); }
-  if(iscompound_t(t1)&&iscompound_t(t2))
-    return(subsu1(hd[t1],hd[t2],T2)&&subsu1(tl[t1],tl[t2],T2));
-  return(0);
-}
-
-walktype(t,f)  /* make a copy of t with f applied to its variables */
-word t;
-word (*f)();
-{ if(isvar_t(t))return((*f)(t));
-  if(iscompound_t(t))
-  { word h1=walktype(hd[t],f);
-    word t1=walktype(tl[t],f);
-    return(h1==hd[t]&&t1==tl[t]?t:ap(h1,t1)); }
-  return(t);
-}
-
-occurs(tv,t)  /* does tv occur in type t? */
-word tv,t;
-{ while(iscompound_t(t))
-  { if(occurs(tv,tl[t]))return(1);
-    t=hd[t]; }
-  return(tv==t);
-}
-
-ispoly(t) /* does t contain tvars? (should call subst first) */
-word t;
-{ while(iscompound_t(t))
-  { if(ispoly(tl[t]))return(1);
-    t=hd[t]; }
-  return(isvar_t(t));
-}
-
-word SUBST[hashsize];  /* hash table of substitutions */
-
-clear_SUBST()
-/* To save time and space we call this after a type inference to clear  out
-   substitutions in extinct variables.  Calling this too often can slow you
-   down - whence #define reset_SUBST, see above */
-{ word i;
-  fixshows();
-  for(i=0;i<hashsize;i++)SUBST[i]=0;
-  /*printf("tvcount=%d\n",tvcount);  /* probe */
-  tvcount=1;
-  return(0);  /* see defn of reset_SUBST */
-}
-/* doubling hashsize from 512 to 1024  speeded  typecheck  by  only  3%  on
-   parser.m (=350 line block, used c. 5000 tvars) - may be worth increasing
-   for very large programs however.  Guesstimate -  further  increase  from 
-   512 would be worthwhile on blocks>2000 lines */
-
-fixshows()
-{ while(showchain!=NIL)
-       { tl[hd[showchain]]=subst(tl[hd[showchain]]);
-         showchain=tl[showchain]; }
-}
-
-lookup(tv)  /* find current substitution for type variable */
-word tv;
-{ word h=SUBST[hashval(tv)];
-  while(h)
-  { if(eqtvar(hd[hd[h]],tv))return(tl[hd[h]]);
-    h=tl[h]; }
-  return(tv);  /* no substitution found, so answer is self */
-}
-
-addsubst(tv,t) /* add new substitution to SUBST */
-word tv,t;
-{ word h=hashval(tv);
-  SUBST[h]=cons(cons(tv,t),SUBST[h]);
-}
-
-ult(tv)  /* fully substituted out value of a type var */
-word tv;
-{ word s=lookup(tv);
-  return(s==tv?tv:subst(s));
-}
-
-subst(t) /* returns fully substituted out value of type expression */
-word t;
-{ return(walktype(t,ult));
-}
-
-word localtvmap=NIL;
-word NGT=0;
-
-lmap(tv)
-word tv;
-{ word l;
-  if(non_generic(tv))return(tv);
-  for(l=localtvmap;l!=NIL;l=tl[l])
-     if(hd[hd[l]]==tv)return(tl[hd[l]]);
-  localtvmap=cons(cons(tv,l=NTV),localtvmap);
-  return(l);
-}
-
-linst(t,ngt) /* local instantiate */
-word t;   /* relevant tvars are those not in ngt */
-{ localtvmap=NIL; NGT=ngt;
-  return(walktype(t,lmap));
-}
-
-non_generic(tv)
-word tv;
-{ word x;
-  for(x=NGT;x!=NIL;x=tl[x])
-     if(occurs(tv,subst(hd[x])))return(1);
-  return(0);
-} /* note that when a non-generic tvar is unified against a texp, all tvars
-     in texp become non-generic; this is catered for by call to subst above
-     (obviating the need for unify to directly side-effect NGT) */
-
-word tvmap=NIL;
-
-mapup(tv)
-word tv;
-{ word *m= &tvmap;
-  tv=gettvar(tv);
-  while(--tv)m= &tl[*m];
-  if(*m==NIL)*m=cons(NTV,NIL);
-  return(hd[*m]);
-}
-
-instantiate(t) /* make a copy of t with a new set of type variables */
-word t;  /* t MUST be in reduced form - see redtvars */
-{ tvmap=NIL;
-  return(walktype(t,mapup));
-}
-
-ap_subst(t,args) /* similar, but with a list of substitions for the type
-               variables provided (args).  Again, t must be in reduced form */
-word t,args;
-{ word r;
-  tvmap=args;
-  r=walktype(t,mapup);
-  tvmap=NIL; /* ready for next use */
-  return(r);
-}
-
-
-mapdown(tv)
-word tv;
-{ word *m= &tvmap;
-  word i=1;
-  while(*m!=NIL&&!eqtvar(hd[*m],tv))m= &tl[*m],i++;
-  if(*m==NIL)*m=cons(tv,NIL);
-  return(mktvar(i));
-}
-
-redtvars(t) /* renames the variables in t, in order of appearance to walktype,
-	       using the numbers 1,2,3... */
-word t;
-{ tvmap=NIL;
-  return(walktype(t,mapdown));
-}
-
-
-remove1(e,ss) /* destructively remove e from set with address ss, returning
-                 1 if e was present, 0 otherwise */
-word e,*ss;
-{ while(*ss!=NIL&&hd[*ss]<e)ss= &tl[*ss]; /* we assume set in address order */
-  if(*ss==NIL||hd[*ss]!=e)return(0);
-  *ss=tl[*ss];
-  return(1);
-}
-
-setdiff(s1,s2) /* destructive on s1, returns set difference */
-word s1,s2; /* both are in ascending address order */
-{ word *ss1= &s1;
-  while(*ss1!=NIL&&s2!=NIL)
-       if(hd[*ss1]==hd[s2])*ss1=tl[*ss1]; else  /* removes element */
-       if(hd[*ss1]<hd[s2])ss1= &tl[*ss1];
-       else s2=tl[s2];
-  return(s1);
-}
-
-add1(e,s) /* inserts e destructively into set s, kept in ascending address
-             order */
-word e,s;
-{ word s1=s;
-  if(s==NIL||e<hd[s])return(cons(e,s));
-  if(e==hd[s])return(s); /* no duplicates! */
-  while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1];
-  if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else
-  if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]);
-  return(s);
-}
-
-word NEW; /* nasty hack, see rules */
-
-newadd1(e,s)  /* as above, but with side-effect on NEW */
-word e,s;
-{ word s1=s;
-  NEW=1;
-  if(s==NIL||e<hd[s])return(cons(e,s));
-  if(e==hd[s]){ NEW=0; return(s); } /* no duplicates! */
-  while(tl[s1]!=NIL&&e>hd[tl[s1]])s1=tl[s1];
-  if(tl[s1]==NIL)tl[s1]=cons(e,NIL);else
-  if(e!=hd[tl[s1]])tl[s1]=cons(e,tl[s1]);
-  else NEW=0;
-  return(s);
-}
-
-UNION(s1,s2) /* destructive on s1; s1, s2 both in address order */
-word s1,s2;
-{ word *ss= &s1;
-  while(*ss!=NIL&&s2!=NIL)
-       if(hd[*ss]==hd[s2])ss= &tl[*ss],s2=tl[s2]; else
-       if(hd[*ss]<hd[s2])ss= &tl[*ss];
-       else *ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2];
-  if(*ss==NIL)
-    while(s2!=NIL)*ss=cons(hd[s2],*ss),ss= &tl[*ss],s2=tl[s2];
-    /* must copy tail of s2, in case of later destructive operations on s1 */
-  return(s1);
-}
-
-intersection(s1,s2)  /* s1, s2 and result all in address order */
-word s1,s2;
-{ word r=NIL;
-  while(s1!=NIL&&s2!=NIL)
-       if(hd[s1]==hd[s2])r=cons(hd[s1],r),s1=tl[s1],s2=tl[s2]; else
-       if(hd[s1]<hd[s2])s1=tl[s1];
-       else s2=tl[s2];
-  return(reverse(r));
-}
-
-deps(x) /* returns list of the free identifiers in expression x */
-word x;
-{ word d=NIL;
-L:switch(tag[x])
-{ case AP:
-  case TCONS:
-  case PAIR:
-  case CONS: d=UNION(d,deps(hd[x]));
-	     x=tl[x];
-	     goto L;
-  case ID: return(isconstructor(x)?d:add1(x,d));
-  case LAMBDA: /* d=UNION(d,patdeps(hd[x])); 
-	       /* should add this - see sahbug3.m */
-	       return(rembvars(UNION(d,deps(tl[x])),hd[x]));
-  case LET: d=rembvars(UNION(d,deps(tl[x])),dlhs(hd[x]));
-            return(UNION(d,deps(dval(hd[x]))));
-  case LETREC: { word y;
-		 d=UNION(d,deps(tl[x]));
-		 for(y=hd[x];y!=NIL;y=tl[y])
-		    d=UNION(d,deps(dval(hd[y])));
-		 for(y=hd[x];y!=NIL;y=tl[y])
-		    d=rembvars(d,dlhs(hd[y]));
-		 return(d); }
-  case LEXER: while(x!=NIL)
-                   d=UNION(d,deps(tl[tl[hd[x]]])),
-                   x=tl[x];
-              return(d);
-  case TRIES:
-  case LABEL: x=tl[x]; goto L;
-  case SHARE: x=hd[x]; goto L;  /* repeated analysis - fix later */
-  default: return(d);
-}}
-
-rembvars(x,p) /* x is list of ids in address order, remove bv's of pattern p
-                 (destructive on x) */
-word x,p;
-{ L:
-  switch(tag[p])
-  { case ID: return(remove1(p,&x),x);
-    case CONS: if(hd[p]==CONST)return(x);
-               x=rembvars(x,hd[p]);p=tl[p];goto L;
-    case AP: if(tag[hd[p]]==AP&&hd[hd[p]]==PLUS)
-               p=tl[p];  /* for n+k patterns */
-             else { x=rembvars(x,hd[p]);p=tl[p]; }
-	     goto L;
-    case PAIR:
-    case TCONS: x=rembvars(x,hd[p]);p=tl[p];goto L;
-    default: fprintf(stderr, "impossible event in rembvars\n");
-	     return(x);
-}}
-
-member(s,x)
-word s,x;
-{ while(s!=NIL&&x!=hd[s])s=tl[s];
-  return(s!=NIL);
-}
-
-printgraph(title,g) /* for debugging info */
-char *title;
-word g;
-{ printf("%s\n",title);
-  while(g!=NIL)
-  { printelement(hd[hd[g]]); putchar(':');
-    printelement(tl[hd[g]]); printf(";\n");
-    g=tl[g]; }
-}
-
-printelement(x)
-word x;
-{ if(tag[x]!=CONS){ out(stdout,x); return; }
-  putchar('(');
-  while(x!=NIL)
-    { out(stdout,hd[x]);
-      x=tl[x];
-      if(x!=NIL)putchar(' '); }
-  putchar(')');
-}
-
-printlist(title,l) /* for debugging */
-char *title;
-word l;
-{ printf("%s",title);
-  while(l!=NIL)
-  { printelement(hd[l]);
-    l=tl[l];
-    if(l!=NIL)putchar(','); }
-  printf(";\n");
-}
-
-printob(title,x) /* for debugging */
-char *title;
-word x;
-{ printf("%s",title); out(stdout,x); putchar('\n');
-  return(x); }
-
-print2obs(title,title2,x,y) /* for debugging */
-char *title,*title2;
-word x,y;
-{ printf("%s",title); out(stdout,x); printf("%s",title2); out(stdout,y); putchar('\n');
-}
-
-word allchars=0; /* flag used by tail */
-
-out_formal1(f,x)
-FILE *f;
-word x;
-{ extern word nill;
-  if(hd[x]==CONST)x=tl[x];
-  if(x==NIL)fprintf(f,"[]"); else
-  if(tag[x]==CONS&&tail(x)==NIL)
-    if(allchars)
-      { fprintf(f,"\"");while(x!=NIL)fprintf(f,"%s",charname(hd[x])),x=tl[x];
-	fprintf(f,"\""); } else
-    { fprintf(f,"[");
-      while(x!=nill&&x!=NIL)
-	   { out_pattern(f,hd[x]);
-	     x=tl[x];
-	     if(x!=nill&&x!=NIL)fprintf(f,","); }
-      fprintf(f,"]"); } else
-  if(tag[x]==AP||tag[x]==CONS)
-    { fprintf(f,"("); out_pattern(f,x);
-      fprintf(f,")"); } else
-  if(tag[x]==TCONS||tag[x]==PAIR)
-    { fprintf(f,"(");
-      while(tag[x]==TCONS)
-	   { out_pattern(f,hd[x]);
-	     x=tl[x]; fprintf(f,","); }
-      out_pattern(f,hd[x]); fprintf(f,","); out_pattern(f,tl[x]); 
-      fprintf(f,")"); } else
-  if(tag[x]==INT&&neg(x)||tag[x]==DOUBLE&&get_dbl(x)<0)
-    { fprintf(f,"("); out(f,x); fprintf(f,")"); } /* -ve numbers */
-  else
-  out(f,x);  /* all other cases */
-}
-
-out_pattern(f,x)
-FILE *f;
-word x;
-{ if(tag[x]==CONS)
-    if(hd[x]==CONST&&(tag[tl[x]]==INT||tag[tl[x]]==DOUBLE))out(f,tl[x]); else
-    if(hd[x]!=CONST&&tail(x)!=NIL)
-    { out_formal(f,hd[x]); fprintf(f,":"); out_pattern(f,tl[x]); }
-    else out_formal(f,x);
-  else out_formal(f,x);
-}
-
-out_formal(f,x)
-FILE *f;
-word x;
-{ if(tag[x]!=AP)
-    out_formal1(f,x); else
-  if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */
-    { out_formal(f,tl[x]); fprintf(f,"+"); out(f,tl[hd[x]]); }
-  else
-    { out_formal(f,hd[x]); fprintf(f," "); out_formal1(f,tl[x]); }
-}
-
-tail(x)
-word x;
-{ allchars=1;
-  while(tag[x]==CONS)allchars&=(is_char(hd[x])),x=tl[x];
-  return(x);
-}
-
-out_type(t) /* for printing external representation of types */
-word t;
-{ while(isarrow_t(t))
-  { out_type1(tl[hd[t]]);
-    printf("->");
-    t=tl[t]; }
-  out_type1(t);
-}
-
-out_type1(t)
-word t;
-{ if(iscompound_t(t)&&!iscomma_t(t)&&!islist_t(t)&&!isarrow_t(t))
-    { out_type1(hd[t]);
-      putchar(' ');
-      t=tl[t]; }
-  out_type2(t);
-}
-
-out_type2(t)
-word t;
-{ if(islist_t(t))
-    { putchar('[');
-      out_type(tl[t]); /* could be out_typel, but absence of parentheses
-			   might be confusing */
-      putchar(']'); }else
-  if(iscompound_t(t))
-    { putchar('(');
-      out_typel(t);
-      if(iscomma_t(t)&&tl[t]==void_t)putchar(',');
-    /* type of a one-tuple -- an anomaly that should never occur */
-      putchar(')'); }else
-  switch(t)
-  {
-  case bool_t: printf("bool"); return;
-  case num_t: printf("num"); return;
-  case char_t: printf("char"); return;
-  case wrong_t: printf("WRONG"); return;
-  case undef_t: printf("UNKNOWN"); return;
-  case void_t: printf("()"); return;
-  case type_t: printf("type"); return;
-  default: if(tag[t]==ID)printf("%s",get_id(t));else
-	   if(isvar_t(t))
-	   { word n=gettvar(t);
-	   /*if(1)printf("t%d",n-1); else /* experiment, suppressed */
-	   /*if(n<=26)putchar('a'+n-1); else /* experiment */
-	     if(n>0&&n<7)while(n--)putchar('*'); /* 6 stars max */
-	     else printf("%d",n); }else
-           if(tag[t]==STRCONS)     /* pname - see hack in privatise */
-	     { extern char *current_script;
-	       if(tag[pn_val(t)]==ID)printf("%s",get_id(pn_val(t))); else
-	       /* ?? one level of indirection sometimes present */
-	       if(strcmp((char *)hd[tl[t_info(t)]],current_script)==0)
-		  printf("%s",(char *)hd[hd[t_info(t)]]); else /* elision */
-	       printf("`%s@%s'",
-		  (char *)hd[hd[t_info(t)]], /* original typename */
-		  (char *)hd[tl[t_info(t)]]); /* sourcefile */ }
-	   else printf("<BADLY FORMED TYPE:%d,%d,%d>",tag[t],hd[t],tl[t]);
-  }
-}
-
-out_typel(t)
-word t;
-{ while(iscomma_t(t))
-  { out_type(tl[hd[t]]);
-    t=tl[t];
-    if(iscomma_t(t))putchar(',');
-    else if(t!=void_t)printf("<>"); } /* "tuple-cons", shouldn't occur free */
-  if(t==void_t)return;
-  out_type(t);
-}
-
-/* end of MIRANDA TYPECHECKER  */
-