/* 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)-big_tod(b))); case INT: if(tag[b]==INT)return(big_compare(a,b)); else return(fsign(big_tod(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 = big_subtract(lastarg,arg1); if(big_is_positive(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||big_compare(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(big_fromll(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=big_toll(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=big_toll(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=big_toll(arg1); if(n<=0||(lastarg=reduce(lastarg))==NIL) /* ### */ { simpl(NIL); goto DONE; } setcell(CONS,hd[lastarg],ap2(TAKE,big_fromll(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(big_fromll(buf.st_ino), big_fromll(buf.st_dev) ), big_fromll(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),big_fromll(-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(big_negate(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=big_toll(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,big_log(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,big_log10(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,big_tod(arg1)+get_dbl(lastarg)); else simpl(big_add(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,big_tod(arg1)-get_dbl(lastarg)); else simpl(big_subtract(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,big_tod(arg1)*get_dbl(lastarg)); else simpl(big_multiply(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 big_remainder ? */ simpl(big_divide(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 = big_divide(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 big_remainder ? */ simpl(big_remainder(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=big_tod(lastarg); else if(big_is_negative(lastarg)) fa=big_tod(arg1),fb=big_tod(lastarg); else { simpl(big_pow(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(big_tod(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?big_is_positive(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(big_fromll(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(big_tod(x)+get_dbl(y))); return(big_add(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 */