From 2797eda2e1d90e6de67cc5c2affe8f59a7d1dfef Mon Sep 17 00:00:00 2001 From: Jakob Kaivo Date: Sun, 27 Mar 2022 19:04:43 -0400 Subject: remove unused files --- new/trans.c | 1026 ----------------------------------------------------------- 1 file changed, 1026 deletions(-) delete mode 100644 new/trans.c (limited to 'new/trans.c') diff --git a/new/trans.c b/new/trans.c deleted file mode 100644 index e50eb8a..0000000 --- a/new/trans.c +++ /dev/null @@ -1,1026 +0,0 @@ -/* MIRANDA TRANS */ -/* performs translation to combinatory logic */ - -/************************************************************************** - * Copyright (C) Research Software Limited 1985-90. All rights reserved. * - * The Miranda system is distributed as free software under the terms in * - * the file "COPYING" which is included in the distribution. * - *------------------------------------------------------------------------*/ - -#include "data.h" - - /* miscellaneous declarations */ -extern word nill,Void; -extern word listdiff_fn,count_fn,from_fn; -extern word diagonalise,concat; -extern word lastname,initialising; -extern word current_id,echoing; -extern word errs; -word newtyps=NIL; /* list of typenames declared in current script */ -word SGC=NIL; /* list of user defined sui-generis constructors */ -#define sui_generis(k) (/* k==Void|| */ member(SGC,k)) - /* 3/10/88 decision to treat `()' as lifted */ - -abstract(x,e) /* abstraction of template x from compiled expression e */ -word x,e; -{ switch(tag[x]) - { case ID: - if(isconstructor(x)) - return(sui_generis(x)?ap(K,e): - ap2(Ug,primconstr(x),e)); - else return(abstr(x,e)); - case CONS: - if(hd[x]==CONST) - if(tag[tl[x]]==INT)return(ap2(MATCHINT,tl[x],e)); - else return(ap2(MATCH,tl[x]==NILS?NIL:tl[x],e)); - else return(ap(U_,abstract(hd[x],abstract(tl[x],e)))); - case TCONS: - case PAIR: /* tuples */ - return(ap(U,abstract(hd[x],abstract(tl[x],e)))); - case AP: - if(sui_generis(head(x))) - return(ap(Uf,abstract(hd[x],abstract(tl[x],e)))); - if(tag[hd[x]]==AP&&hd[hd[x]]==PLUS) /* n+k pattern */ - return(ap2(ATLEAST,tl[hd[x]],abstract(tl[x],e))); - while(tag[x]==AP) - { e= abstract(tl[x],e); - x= hd[x]; } - /* now x must be a constructor */ - default: ; } - if(isconstructor(x)) - return(ap2(Ug,primconstr(x),e)); - printf("error in declaration of \"%s\", undeclared constructor in pattern: ", - get_id(current_id)); /* something funny here - fix later */ - out(stdout,x); - printf("\n"); - return(NIL); -} - -primconstr(x) -word x; -{ x=id_val(x); - while(tag[x]!=CONSTRUCTOR)x=tl[x]; - return(x); - /* => constructor values are of the form TRY f k where k is the - original constructor value, and ! constructors are of the form - MKSTRICT i k */ -} - -memb(l,x) /* tests if x is a member of list "l" - used in testing for - repeated names - see rule for "v2" in MIRANDA RULES */ -word l,x; -{ if(tag[x]==TVAR) /* type variable! */ - while(l!=NIL&&!eqtvar(hd[l],x))l= tl[l]; - else while(l!=NIL&&hd[l]!=x)l= tl[l]; - return(l!=NIL); } - -abstr(x,e) /* "bracket abstraction" of variable x from code e */ -word x,e; -{ switch(tag[e]) - { case TCONS: - case PAIR: - case CONS: return(liscomb(abstr(x,hd[e]),abstr(x,tl[e]))); - case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR) - return(ap(K,e)); /* don't go inside error info */ - return(combine(abstr(x,hd[e]),abstr(x,tl[e]))); - case LAMBDA: - case LET: - case LETREC: - case TRIES: - case LABEL: - case SHOW: - case LEXER: - case SHARE: fprintf(stderr,"impossible event in abstr (tag=%d)\n",tag[e]), - exit(1); - default: if(x==e||isvar_t(x)&&isvar_t(e)&&eqtvar(x,e)) - return(I); /* see note */ - return(ap(K,e)); -}} /* note - we allow abstraction wrt tvars - see genshfns() */ - -#define mkindex(i) ((i)<256?(i):make(INT,i,0)) - /* will fall over if i >= IBASE */ - -abstrlist(x,e) /* abstraction of list of variables x from code e */ -word x,e; -{ switch(tag[e]) - { case TCONS: - case PAIR: - case CONS: return(liscomb(abstrlist(x,hd[e]),abstrlist(x,tl[e]))); - case AP: if(hd[e]==BADCASE||hd[e]==CONFERROR) - return(ap(K,e)); /* don't go inside error info */ - else return(combine(abstrlist(x,hd[e]),abstrlist(x,tl[e]))); - case LAMBDA: case LET: case LETREC: case TRIES: case LABEL: case SHOW: - case LEXER: - case SHARE: fprintf(stderr, - "impossible event in abstrlist (tag=%d)\n",tag[e]), - exit(1); - default: { word i=0; - while(x!=NIL&&hd[x]!=e)i++,x=tl[x]; - if(x==NIL)return(ap(K,e)); - return(ap(SUBSCRIPT,mkindex(i))); } -}} - -word rv_script=0; /* flags readvals in use (for garbage collector) */ - -codegen(x) /* returns expression x with abstractions performed */ -word x; -{ extern word debug,commandmode,cook_stdin,common_stdin,common_stdinb,rv_expr; - switch(tag[x]) - { case AP: if(commandmode /* beware of corrupting lastexp */ - &&x!=cook_stdin&&x!=common_stdin&&x!=common_stdinb) /* but share $+ $- */ - return(make(AP,codegen(hd[x]),codegen(tl[x]))); - if(tag[hd[x]]==AP&&hd[hd[x]]==APPEND&&tl[hd[x]]==NIL) - return(codegen(tl[x])); /* post typecheck reversal of HR bug fix */ - hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]); - /* otherwise do in situ */ - return(tag[hd[x]]==AP&&hd[hd[x]]==G_ALT?leftfactor(x):x); - case TCONS: - case PAIR: return(make(CONS,codegen(hd[x]),codegen(tl[x]))); - case CONS: if(commandmode) - return(make(CONS,codegen(hd[x]),codegen(tl[x]))); - /* otherwise do in situ (see declare) */ - hd[x]=codegen(hd[x]); tl[x]=codegen(tl[x]); - return(x); - case LAMBDA: return(abstract(hd[x],codegen(tl[x]))); - case LET: return(translet(hd[x],tl[x])); - case LETREC: return(transletrec(hd[x],tl[x])); - case TRIES: return(transtries(hd[x],tl[x])); - case LABEL: return(codegen(tl[x])); - case SHOW: return(makeshow(hd[x],tl[x])); - case LEXER: - { word r=NIL,uses_state=0;; - while(x!=NIL) - { word rule=abstr(mklexvar(0),codegen(tl[tl[hd[x]]])); - rule=abstr(mklexvar(1),rule); - if(!(tag[rule]==AP&&hd[rule]==K))uses_state=1; - r=cons(cons(hd[hd[x]], /* start condition stuff */ - cons(ap(hd[tl[hd[x]]],NIL), /* matcher [] */ - rule)), - r); - x=tl[x]; } - if(!uses_state) /* strip off (K -) from each rule */ - { for(x=r;x!=NIL;x=tl[x])tl[tl[hd[x]]]=tl[tl[tl[hd[x]]]]; - r = ap(LEX_RPT,ap(LEX_TRY,r)); } - else r = ap(LEX_RPT1,ap(LEX_TRY1,r)); - return(ap(r,0)); } /* 0 startcond */ - case STARTREADVALS: - if(ispoly(tl[x])) - { extern word cook_stdin,polyshowerror,ND; - printf("type error - %s used at polymorphic type :: [", - cook_stdin&&x==hd[cook_stdin]?"$+":"readvals or $+"); - out_type(redtvars(tl[x])),printf("]\n"); - polyshowerror=1; - if(current_id) - ND=add1(current_id,ND), - id_type(current_id)=wrong_t, - id_val(current_id)=UNDEF; - if(hd[x])sayhere(hd[x],1); } - if(commandmode)rv_expr=1; else rv_script=1; - return(x); - case SHARE: if(tl[x]!= -1) /* arbitrary flag for already visited */ - hd[x]=codegen(hd[x]),tl[x]= -1; - return(hd[x]); - default: if(x==NILS)return(NIL); - return(x); /* identifier, private name, or constant */ -}} - -word lfrule=0; - -leftfactor(x) - -/* grammar optimisations - x is of the form ap2(G_ALT,...) - G_ALT(G_SEQ a b) a => G_SEQ a (G_ALT b G_UNIT) - G_ALT(G_SEQ a b)(G_SEQ a c) => G_SEQ a (G_ALT b c) - G_ALT(G_SEQ a b)(G_ALT a d) => G_ALT(G_SEQ a (G_ALT b G_UNIT)) d - G_ALT(G_SEQ a b)(G_ALT(G_SEQ a c) d) => G_ALT(G_SEQ a (G_ALT b c)) d -*/ -word x; -{ word a,b,c,d; - if(tag[c=tl[hd[x]]]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ) - a=tl[hd[c]],b=tl[c]; else return(x); - if(same(a,d=tl[x])) - { hd[x]=ap(G_SEQ,a), tl[x]=ap2(G_ALT,b,G_UNIT); lfrule++; - /* printob("rule1: ",x); */ - return(x); } - if(tag[d]==AP&&tag[hd[d]]==AP) - c=hd[hd[d]]; else return(x); - if(c==G_SEQ&&same(a,tl[hd[d]])) - { c=tl[d], - hd[x]=ap(G_SEQ,a), tl[x]=leftfactor(ap2(G_ALT,b,c)); lfrule++; - /* printob("rule2: ",x); */ - return(x); } - if(c!=G_ALT)return(x); - if(same(a,c=tl[hd[d]])) - { d=tl[d]; - hd[x]=ap(G_ALT,ap2(G_SEQ,a,ap2(G_ALT,b,G_UNIT))); - tl[x]=d; lfrule++; - /* printob("rule3: ",x); */ - return(leftfactor(x)); } - if(tag[c]==AP&&tag[hd[c]]==AP&&hd[hd[c]]==G_SEQ - &&same(a,tl[hd[c]])) - { c=tl[c],d=tl[d], - hd[x]=ap(G_ALT,ap2(G_SEQ,a,leftfactor(ap2(G_ALT,b,c)))); - tl[x]=d; lfrule++; - /* printob("rule4: ",x); */ - return(leftfactor(x)); } - return(x); -} - -same(x,y) /* structural equality */ -word x,y; -{ if(x==y)return(1); - if(tag[x]==ATOM||tag[y]==ATOM||tag[x]!=tag[y])return(0); - if(tag[x]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]]