From 55f277e77428d7423ae906a8e1f1324d35b07a7d Mon Sep 17 00:00:00 2001 From: Jakob Kaivo Date: Fri, 4 Mar 2022 12:32:20 -0500 Subject: import Miranda 2.066 from upstream --- steer.c | 2241 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2241 insertions(+) create mode 100644 steer.c (limited to 'steer.c') diff --git a/steer.c b/steer.c new file mode 100644 index 0000000..422efbb --- /dev/null +++ b/steer.c @@ -0,0 +1,2241 @@ +/* MIRANDA STEER */ +/* initialisation routines and assorted routines for I/O etc */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + * * + * Revised to C11 standard and made 64bit compatible, January 2020 * + *------------------------------------------------------------------------*/ + +/* this stuff is to get the time-last-modified of files */ +#include +#include +#include /* creat() */ +/* #include /* seems not needed, oct 05 */ +struct stat buf; /* see man(2) stat - gets file status */ + +#include "data.h" +#include "big.h" +#include "lex.h" +#include +word nill,Void; +word main_id; /* change to magic scripts 19.11.2013 */ +word message,standardout; +word diagonalise,concat,indent_fn,outdent_fn,listdiff_fn; +word shownum1,showbool,showchar,showlist,showstring,showparen,showpair, + showvoid,showfunction,showabstract,showwhat; + +char PRELUDE[pnlim+10],STDENV[pnlim+9]; + /* if anyone complains, elasticate these buffers! */ + +#define DFLTSPACE 2500000l +#define DFLTDICSPACE 100000l +/* default values for size of heap, dictionary */ +word SPACELIMIT=DFLTSPACE,DICSPACE=DFLTDICSPACE; + +#ifdef CYGWIN +#define EDITOR "joe +!" +#else +#define EDITOR "vi +!" +#endif +/* The name of whatever is locally considered to be the default editor - the + user will be able to override this using the `/editor' command. + It is also overriden by shell/environment variable EDITOR if present */ + +extern FILE *s_out; +int UTF8=0, UTF8OUT=0; +extern char *vdate, *host; +extern word version, ND; +extern word *dstack,*stackp; + +static void allnamescom(void); +static void announce(void); +static int badeditor(void); +static int checkversion(char*); +static void command(void); +static void commandloop(char*); +static void diagnose(char*); +static void editfile(char*,int); +static void ed_warn(void); +static void filecopy(char*); +static void filecp(char*,char*); +static void finger(char*); +static void fixeditor(void); +static void fixexports(void); +static int getln(FILE*,word,char*); +static word isfreeid(word); +static void libfails(void); +static void loadfile(char*); +static void makedump(void); +static void manaction(void); +static void mira_setup(void); +static void missparam(char*); +static char *mkabsolute(char*); +static word mkincludes(word); +static word mktiny(void); +static void namescom(word); +static void primlib(void); +static word privatise(word); +static void privlib(void); +static word publicise(word); +static word rc_read(char*); +static void rc_write(void); +static int src_update(void); +static void stdlib(void); +static char *strvers(int); +static int twidth(void); +static void undump(char*); +static int utf8test(void); +static void unfixexports(void); +static void unlinkx(char*); +static void unload(void); +static void v_info(int); +static void xschars(void); + +char *editor=NULL; +word okprel=0; /* set to 1 when prelude loaded */ +word nostdenv=0; /* if set to 1 mira does not load stdenv at startup */ +/* to allow a NOSTDENV directive _in_the_script_ we would need to + (i) replace isltmess() test in rules by eg is this a list of thing, + where thing is algebraic type originally defined in STDENV + (ii) arrange to pick up when current script not loaded + not implemented */ +word baded=0; /* see fixeditor() */ +char *miralib=NULL; +char *mirahdr,*lmirahdr; +char *promptstr="Miranda "; +char *obsuffix="x"; +FILE *s_in=NULL; +word commandmode=0; /* true only when reading command-level expressions */ +int atobject=0,atgc=0,atcount=0,debug=0; +word magic=0; /* set to 1 means script will start with UNIX magic string */ +word making=0; /* set only for mira -make */ +word mkexports=0; /* set only for mira -exports */ +word mksources=0; /* set only for mira -sources */ +word make_status=0; /* exit status of -make */ +int compiling=1; +/* there are two types of MIRANDA process - compiling (the main process) and +subsidiary processes launched for each evaluation - the above flag tells +us which kind of process we are in */ +int ideep=0; /* depth of %include we are at, see mkincludes() */ +word SYNERR=0; +word initialising=1; +word primenv=NIL; +char *current_script; +word lastexp=UNDEF; /* value of `$$' */ +word echoing=0,listing=0,verbosity; +word strictif=1,rechecking=0; +word errline=0; /* records position of last error, for editor */ +word errs=0; /* secondary error location, in inserted script, if relevant */ +word *cstack; +extern word c; +extern char *dicp,*dicq; +char linebuf[BUFSIZE]; /* used for assorted purposes */ + /* NB cannot share with linebuf in lex.c, or !! goes wrong */ +static char ebuf[pnlim]; +word col; +char home_rc[pnlim+8]; +char lib_rc[pnlim+8]; +char *rc_error=NULL; +#define badval(x) (x<1||x>478000000) + +#include /* for longjmp() - see man (3) setjmp */ +jmp_buf env; + +#ifdef sparc8 +#include +fp_except commonmask = FP_X_INV|FP_X_OFL|FP_X_DZ; /* invalid|ovflo|divzero */ +#endif + +int main(argc,argv) /* system initialisation, followed by call to YACC */ +int argc; +char *argv[]; +{ word manonly=0; + char *home, *prs; + int okhome_rc; /* flags valid HOME/.mirarc file present */ + char *argv0=argv[0]; + char *initscript; + int badlib=0; + extern int ARGC; extern char **ARGV; + extern word newtyps,algshfns; + char *progname=rindex(argv[0],'/'); + cstack= &manonly; +/* used to indicate the base of the C stack for garbage collection purposes */ + verbosity=isatty(0); +/*if(isatty(1))*/ setbuf(stdout,NULL); /* for unbuffered tty output */ + if(home=getenv("HOME")) + { strcpy(home_rc,home); + if(strcmp(home_rc,"/")==0)home_rc[0]=0; /* root is special case */ + strcat(home_rc,"/.mirarc"); + okhome_rc=rc_read(home_rc); } +/*setup policy: + if valid HOME/.mirarc found look no further, otherwise try + /.mirarc + Complaints - if any .mirarc contained bad data, `announce' complains about + the last such looked at. */ + UTF8OUT=UTF8=utf8test(); + while(argc>1&&argv[1][0]=='-') /* strip off flags */ + { if(strcmp(argv[1],"-stdenv")==0)nostdenv=1; else + if(strcmp(argv[1],"-count")==0)atcount=1; else + if(strcmp(argv[1],"-list")==0)listing=1; else + if(strcmp(argv[1],"-nolist")==0)listing=0; else + if(strcmp(argv[1],"-nostrictif")==0)strictif=0; else + if(strcmp(argv[1],"-gc")==0)atgc=1; else + if(strcmp(argv[1],"-object")==0)atobject=1; else + if(strcmp(argv[1],"-lib")==0) + { argc--,argv++; + if(argc==1)missparam("lib"); else miralib=argv[1]; + } else + if(strcmp(argv[1],"-dic")==0) + { argc--,argv++; + if(argc==1)missparam("dic"); else + if(sscanf(argv[1],"%ld",&DICSPACE)!=1||badval(DICSPACE)) + fprintf(stderr,"mira: bad value after flag \"-dic\"\n"),exit(1); + } else + if(strcmp(argv[1],"-heap")==0) + { argc--,argv++; + if(argc==1)missparam("heap"); else + if(sscanf(argv[1],"%ld",&SPACELIMIT)!=1||badval(SPACELIMIT)) + fprintf(stderr,"mira: bad value after flag \"-heap\"\n"),exit(1); + } else + if(strcmp(argv[1],"-editor")==0) + { argc--,argv++; + if(argc==1)missparam("editor"); + else editor=argv[1],fixeditor(); + } else + if(strcmp(argv[1],"-hush")==0)verbosity=0; else + if(strcmp(argv[1],"-nohush")==0)verbosity=1; else + if(strcmp(argv[1],"-exp")==0||strcmp(argv[1],"-log")==0) + fprintf(stderr,"mira: obsolete flag \"%s\"\n" + "use \"-exec\" or \"-exec2\", see manual\n", + argv[1]),exit(1); else + if(strcmp(argv[1],"-exec")==0) /* replaces -exp 26.11.2019 */ + ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; else + if(strcmp(argv[1],"-exec2")==0) /* version of -exec for debugging CGI scripts */ + { if(argc<=2)fprintf(stderr,"incorrect use of -exec2 flag, missing filename\n"),exit(1); + char *logfilname, *p=strrchr(argv[2],'/'); + FILE *fil=NULL; + if(!p)p=argv[2]; /* p now holds last component of prog name */ + if(logfilname=malloc((strlen(p)+9))) + sprintf(logfilname,"miralog/%s",p), + fil=fopen(logfilname,"a"); + else mallocfail("logfile name"); + /* process requires write permission on local directory "miralog" */ + if(fil)dup2(fileno(fil),2); /* redirect stderr to log file */ + else fprintf(stderr,"could not open %s\n",logfilname); + ARGC=argc-2,ARGV=argv+2,magic=1,verbosity=0; } else + if(strcmp(argv[1],"-man")==0){ manonly=1; break; } else + if(strcmp(argv[1],"-version")==0)v_info(0),exit(0); else + if(strcmp(argv[1],"-V")==0)v_info(1),exit(0); else + if(strcmp(argv[1],"-make")==0) making=1,verbosity=0; else + if(strcmp(argv[1],"-exports")==0) making=mkexports=1,verbosity=0; else + if(strcmp(argv[1],"-sources")==0) making=mksources=1,verbosity=0; else + if(strcmp(argv[1],"-UTF-8")==0) UTF8=1; else + if(strcmp(argv[1],"-noUTF-8")==0) UTF8=0; else + fprintf(stderr,"mira: unknown flag \"%s\"\n",argv[1]),exit(1); + argc--,argv++; } + if(argc>2&&!magic&&!making)fprintf(stderr,"mira: too many args\n"),exit(1); + if(!miralib) /* no -lib flag */ + { char *m; + /* note search order */ + if((m=getenv("MIRALIB")))miralib=m; else + if(checkversion(m="/usr/lib/miralib"))miralib=m; else + if(checkversion(m="/usr/local/lib/miralib"))miralib=m; else + if(checkversion(m="miralib"))miralib=m; else + badlib=1; + } + if(badlib) + { fprintf(stderr,"fatal error: miralib version %s not found\n", + strvers(version)); + libfails(); + exit(1); + } + if(!okhome_rc) + { if(rc_error==lib_rc)rc_error=NULL; + (void)strcpy(lib_rc,miralib); + (void)strcat(lib_rc,"/.mirarc"); + rc_read(lib_rc); } + if(editor==NULL) /* .mirarc was absent or unreadable */ + { editor=getenv("EDITOR"); + if(editor==NULL)editor=EDITOR; + else strcpy(ebuf,editor),editor=ebuf,fixeditor(); } + if(prs=getenv("MIRAPROMPT"))promptstr=prs; + if(getenv("RECHECKMIRA")&&!rechecking)rechecking=1; + if(getenv("NOSTRICTIF"))strictif=0; + setupdic(); /* used by mkabsolute */ + s_in=stdin; + s_out=stdout; + miralib=mkabsolute(miralib); /* protection against "/cd" */ + if(manonly)manaction(),exit(0); + (void)strcpy(PRELUDE,miralib); (void)strcat(PRELUDE,"/prelude"); + /* convention - change spelling of "prelude" at each release */ + (void)strcpy(STDENV,miralib); + (void)strcat(STDENV,"/stdenv.m"); + mira_setup(); + if(verbosity)announce(); + files=NIL; + undump(PRELUDE),okprel=1; + mkprivate(fil_defs(hd[files])); + files=NIL; /* don't wish unload() to unsetids on prelude */ + if(!nostdenv) + { undump(STDENV); + while(files!=NIL) /* stdenv may have %include structure */ + primenv=alfasort(append1(primenv,fil_defs(hd[files]))), + files=tl[files]; + primenv=alfasort(primenv); + newtyps=files=NIL; /* don't wish unload() to unsetids */ } + if(!magic)rc_write(); + echoing = verbosity&listing; + initialising=0; + if(mkexports) + { /* making=1, to say if recompiling, also to undump as for %include */ + word f,argcount=argc-1; + extern word exports,freeids; + char *s; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) /* where do error messages go?? */ + { word x=NIL; + s=addextn(1,*++argv); + if(s==dicp)keep(dicp); + undump(s); /* bug, recompile messages goto stdout - FIX LATER */ + if(files==NIL||ND!=NIL)continue; + if(argcount!=1)printf("%s\n",s); + if(exports!=NIL)x=exports; + /* true (if ever) only if just recompiled */ + else for(f=files;f!=NIL;f=tl[f])x=append1(fil_defs(hd[f]),x); + /* method very clumsy, because exports not saved in dump */ + if(freeids!=NIL) + { word f=freeids; + while(f!=NIL) + { word n=findid((char *)hd[hd[tl[hd[f]]]]); + id_type(n)=tl[tl[hd[f]]]; + id_val(n)=the_val(hd[hd[f]]); + hd[f]=n; + f=tl[f]; } + f=freeids=typesfirst(freeids); + printf("\t%%free {\n"); + while(f!=NIL) + putchar('\t'), + report_type(hd[f]), + putchar('\n'), + f=tl[f]; + printf("\t}\n"); } + for(x=typesfirst(alfasort(x));x!=NIL;x=tl[x]) + { putchar('\t'); + report_type(hd[x]); + putchar('\n'); } } + exit(0); } + if(mksources){ extern word oldfiles; + char *s; + word f,x=NIL; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) + if(stat((s=addextn(1,*++argv)),&buf)==0) + { if(s==dicp)keep(dicp); + undump(s); + for(f=files==NIL?oldfiles:files;f!=NIL;f=tl[f]) + if(!member(x,(word)get_fil(hd[f]))) + x=cons((word)get_fil(hd[f]),x), + printf("%s\n",get_fil(hd[f])); + } + exit(0); } + if(making){ extern word oldfiles; + char *s; + setjmp(env); /* will return here on blankerr (via reset) */ + while(--argc) /* where do error messages go?? */ + { s=addextn(1,*++argv); + if(s==dicp)keep(dicp); + undump(s); + if(ND!=NIL||files==NIL&&oldfiles!=NIL) + { if(make_status==1)make_status=0; + make_status=strcons(s,make_status); } + /* keep list of source files with error-dumps */ + } + if(tag[make_status]==STRCONS) + { word h=0,maxw=0,w,n; + printf("errors or undefined names found in:-\n"); + while(make_status) /* reverse to get original order */ + { h=strcons(hd[make_status],h); + w=strlen((char *)hd[h]); + if(w>maxw)maxw=w; + make_status=tl[make_status]; } + maxw++;n=78/maxw;w=0; + while(h) + printf("%*s%s",(int)maxw,(char *)hd[h],(++w%n)?"":"\n"), + h=tl[h]; + if(w%n)printf("\n"); + make_status=1; } + exit(make_status); } + initscript= argc==1?"script.m":magic?argv[1]:addextn(1,argv[1]); + if(initscript==dicp)keep(dicp); +#if sparc8 + fpsetmask(commonmask); +#elif defined sparc + ieee_handler("set","common",(sighandler)fpe_error); +#endif +#if !defined sparc | sparc8 + (void)signal(SIGFPE,(sighandler)fpe_error); /* catch arithmetic overflow */ +#endif + (void)signal(SIGTERM,(sighandler)exit); /* flush buffers if killed */ + commandloop(initscript); + /* parameter is file given as argument */ +} + +int vstack[4]; /* record of miralib versions looked at */ +char *mstack[4]; /* and where found */ +int mvp=0; + +int checkversion(m) +/* returns 1 iff m is directory with .version containing our version number */ +char *m; +{ int v1,read=0,r=0; + FILE *f=fopen(strcat(strcpy(linebuf,m),"/.version"),"r"); + if(f&&fscanf(f,"%u",&v1)==1)r= v1==version, read=1; + if(f)fclose(f); + if(read&&!r)mstack[mvp]=m,vstack[mvp++]=v1; + return r; +} + +void libfails() +{ word i=0; + fprintf(stderr,"found"); + for(;i999999)return "\?\?\?"; + snprintf(vbuf,12,"%.3f",v/1000.0); + return vbuf; +} + +char *mkabsolute(m) /* make sure m is an absolute pathname */ +char *m; +{ if(m[0]=='/')return(m); + if(!getcwd(dicp,pnlim))fprintf(stderr,"panic: cwd too long\n"),exit(1); + (void)strcat(dicp,"/"); + (void)strcat(dicp,m); + m=dicp; + dicp=dicq+=strlen(dicp)+1; + dic_check(); + return(m); +} + +void missparam(s) +char *s; +{ fprintf(stderr,"mira: missing param after flag \"-%s\"\n",s); + exit(1); } + +int oldversion=0; +#define colmax 400 +#define spaces(s) for(j=s;j>0;j--)putchar(' ') + +void announce() +{ extern char *vdate; + word w,j; +/*clrscr(); /* clear screen on start up */ + w=(twidth()-50)/2; + printf("\n\n"); + spaces(w); printf(" T h e M i r a n d a S y s t e m\n\n"); + spaces(w+5-strlen(vdate)/2); + printf(" version %s last revised %s\n\n",strvers(version),vdate); + spaces(w); printf("Copyright Research Software Ltd 1985-2020\n\n"); + spaces(w); printf(" World Wide Web: http://miranda.org.uk\n\n\n"); + if(SPACELIMIT!=DFLTSPACE) + printf("(%ld cells)\n",SPACELIMIT); + if(!strictif)printf("(-nostrictif : deprecated!)\n"); +/*printf("\t\t\t\t%dbit platform\n",__WORDSIZE); /* temporary */ + if(oldversion<1999) /* pre release two */ + printf("\ +WARNING:\n\ +a new release of Miranda has been installed since you last used\n\ +the system - please read the `CHANGES' section of the /man pages !!!\n\n"); + else + if(version>oldversion) + printf("a new version of Miranda has been installed since you last\n"), + printf("used the system - see under `CHANGES' in the /man pages\n\n"); + if(versionscript absent or has syntax errors + ND!=NIL=>script has type errors or undefined names + all reported by undump() or loadfile() on new compile */ + { if(files!=NIL&&ND==NIL&&id_val(main_id)==UNDEF) + fprintf(stderr,"%s: main not defined\n",initscript); + fprintf(stderr,"mira: incorrect use of \"-exec\" flag\n"); + exit(1); } + magic=0; obey(main_id); exit(0); } + /* was obey(lastexp), change to magic scripts 19.11.2013 */ + (void)signal(SIGINT,(sighandler)reset); + undump(initscript); + if(verbosity)printf("for help type /h\n"); } + for(;;) + { resetgcstats(); + if(verbosity)printf("%s",promptstr); + ch = getchar(); + if(rechecking&&src_update())loadfile(current_script); + /* modified behaviour for `2-window' mode */ + while(ch==' '||ch=='\t')ch=getchar(); + switch(ch) + { case '?': ch=getchar(); + if(ch=='?') + { word x; char *aka=NULL; + if(!token()&&!lastid) + { printf("\7identifier needed after `\?\?'\n"); + ch=getchar(); /* '\n' */ + break; } + if(getchar()!='\n'){ xschars(); break; } + if(baded){ ed_warn(); break; } + if(dicp[0])x=findid(dicp); + else printf("??%s\n",get_id(lastid)),x=lastid; + if(x==NIL||id_type(x)==undef_t) + { diagnose(dicp[0]?dicp:get_id(lastid)); + lastid=0; + break; } + if(id_who(x)==NIL) + { /* nb - primitives have NIL who field */ + printf("%s -- primitive to Miranda\n", + dicp[0]?dicp:get_id(lastid)); + lastid=0; + break; } + lastid=x; + x=id_who(x); /* get here info */ + if(tag[x]==CONS)aka=(char *)hd[hd[x]],x=tl[x]; + if(aka)printf("originally defined as \"%s\"\n", + aka); + editfile((char *)hd[x],tl[x]); + break; } + ungetc(ch,stdin); + (void)token(); + lastid=0; + if(dicp[0]=='\0') + { if(getchar()!='\n')xschars(); + else allnamescom(); + break; } + while(dicp[0])finger(dicp),(void)token(); + ch=getchar(); + break; + case ':': /* add (silently) as kindness to Hugs users */ + case '/': (void)token(); + lastid=0; + command(); + break; + case '!': if(!(lb=rdline()))break; /* rdline returns NULL on failure */ + lastid=0; + if(*lb) + { /*system(lb); */ /* always gives /bin/sh */ + static char *shell=NULL; + sighandler oldsig; + word pid; + if(!shell) + { shell=getenv("SHELL"); + if(!shell)shell="/bin/sh"; } + oldsig= signal(SIGINT,SIG_IGN); + if(pid=fork()) + { /* parent */ + if(pid==-1) + perror("UNIX error - cannot create process"); + while(pid!=wait(0)); + (void)signal(SIGINT,oldsig); } + else execl(shell,shell,"-c",lb,(char *)0); + if(src_update())loadfile(current_script); } + else printf( + "No previous shell command to substitute for \"!\"\n"); + break; + case '|': /* lines beginning "||" are comments */ + if((ch=getchar())!='|') + printf("\7unknown command - type /h for help\n"); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + case '\n': break; + case EOF: if(verbosity)printf("\nmiranda logout\n"); + exit(0); + default: ungetc(ch,stdin); + lastid=0; + tl[hd[cook_stdin]]=0; /* unset type of $+ */ + rv_expr=0; + c = EVAL; + echoing=0; + polyshowerror=0; /* gets set by wrong use of $+, readvals */ + commandmode=1; + yyparse(); + if(SYNERR)SYNERR=0; + else if(c!='\n') /* APPARENTLY NEVER TRUE */ + { printf("syntax error\n"); + while(c!='\n'&&c!=EOF) + c=getchar(); /* swallow syntax errors */ + } + commandmode=0; + echoing=verbosity&listing; +}}} + +word parseline(t,f,fil) /* parses next valid line of f at type t, returns EOF + if none found. See READVALS in reduce.c */ +word t; +FILE *f; +word fil; +{ word t1,ch; + lastexp=UNDEF; + for(;;) + { ch=getc(f); + while(ch==' '||ch=='\t'||ch=='\n')ch=getc(f); + if(ch=='|') + { ch=getc(f); + if(ch=='|') /* leading comment */ + { while((ch=getc(f))!='\n'&&ch!=EOF); + if(ch!=EOF)continue; } + else ungetc(ch,f); } + if(ch==EOF)return(EOF); + ungetc(ch,f); + c = VALUE; + echoing=0; + commandmode=1; + s_in=f; + yyparse(); + s_in=stdin; + if(SYNERR)SYNERR=0,lastexp=UNDEF; else + if((t1=type_of(lastexp))==wrong_t)lastexp=UNDEF; else + if(!subsumes(instantiate(t1),t)) + { printf("data has wrong type :: "), out_type(t1), + printf("\nshould be :: "), out_type(t), putc('\n',stdout); + lastexp=UNDEF; } + if(lastexp!=UNDEF)return(codegen(lastexp)); + if(isatty(fileno(f)))printf("please re-enter data:\n"); + else { if(fil)fprintf(stderr,"readvals: bad data in file \"%s\"\n", + getstring(fil,0)); + else fprintf(stderr,"bad data in $+ input\n"); + outstats(); exit(1); } +}} + +void ed_warn() +{ printf( +"The currently installed editor command, \"%s\", does not\n\ +include a facility for opening a file at a specified line number. As a\n\ +result the `\?\?' command and certain other features of the Miranda system\n\ +are disabled. See manual section 31/5 on changing the editor for more\n\ +information.\n",editor); +} + +word fm_time(f) /* time last modified of file f */ +char *f; +{ return(stat(f,&buf)==0?buf.st_mtime:0); + /* non-existent file has conventional mtime of 0 */ +} /* we assume time_t can be stored in a word */ + +#define same_file(x,y) (hd[fil_inodev(x)]==hd[fil_inodev(y)]&& \ + tl[fil_inodev(x)]==tl[fil_inodev(y)]) +#define inodev(f) (stat(f,&buf)==0?datapair(buf.st_ino,buf.st_dev):\ + datapair(0,-1)) + +word oldfiles=NIL; /* most recent set of sources, in case of interrupted or + failed compilation */ +int src_update() /* any sources modified ? */ +{ word ft,f=files==NIL?oldfiles:files; + while(f!=NIL) + { if((ft=fm_time(get_fil(hd[f])))!=fil_time(hd[f])) + { if(ft==0)unlinkx(get_fil(hd[f])); /* tidy up after eg `!rm %' */ + return(1); } + f=tl[f]; } + return(0); +} + +int loading; +char *unlinkme; /* if set, is name of partially created obfile */ + +void reset() /* interrupt catcher - see call to signal in commandloop */ +{ extern word lineptr,ATNAMES,current_id; + extern int blankerr,collecting; + /*if(!making) /* see note below + (void)signal(SIGINT,SIG_IGN); /* dont interrupt me while I'm tidying up */ +/*if(magic)exit(0); *//* signal now not set to reset in magic scripts */ + if(collecting)gcpatch(); + if(loading) + { if(!blankerr) + printf("\n<>\n"); + if(unlinkme)unlink(unlinkme); + /* stackp=dstack; /* add if undump() made interruptible later*/ + oldfiles=files,unload(),current_id=ATNAMES=loading=SYNERR=lineptr=0; + if(blankerr)blankerr=0,makedump(); } + /* magic script cannot be literate so no guard needed on makedump */ + else printf("<>\n"); /* VAX, SUN, ^C does not cause newline */ + reset_state(); /* see LEX */ + if(collecting)collecting=0,gc(); /* to mark stdenv etc as wanted */ + if(making&&!make_status)make_status=1; +#ifdef SYSTEM5 + else (void)signal(SIGINT,(sighandler)reset);/*ready for next interrupt*//*see note*/ +#endif + /* during mira -make blankerr is only use of reset */ + longjmp(env,1); +}/* under BSD and Linux installed signal remains installed after interrupt + and further signals blocked until handler returns */ + +#define checkeol if(getchar()!='\n')break; + +int lose; + +int normal(f) /* s has ".m" suffix */ +char *f; +{ int n=strlen(f); + return n>=2&&strcmp(f+n-2,".m")==0; +} + +void v_info(int full) +{ printf("%s last revised %s\n",strvers(version),vdate); + if(!full)return; + printf("%s",host); + printf("XVERSION %u\n",XVERSION); +} + +void command() +{ char *t; + int ch,ch1; + switch(dicp[0]) + { + case 'a': if(is("a")||is("aux")) + { checkeol; +/* if(verbosity)clrscr(); */ + (void)strcpy(linebuf,miralib); + (void)strcat(linebuf,"/auxfile"); + filecopy(linebuf); + return; } + case 'c': if(is("count")) + { checkeol; atcount=1; return; } + if(is("cd")) + { char *d=token(); + if(!d)d=getenv("HOME"); + else d=addextn(0,d); + checkeol; + if(chdir(d)==-1)printf("cannot cd to %s\n",d); + else if(src_update())undump(current_script); + /* alternative: keep old script and recompute pathname + wrt new directory - LOOK INTO THIS LATER */ + return; } + case 'd': if(is("dic")) + { extern char *dic; + if(!token()) + { lose=getchar(); /* to eat \n */ + printf("%ld chars",DICSPACE); + if(DICSPACE!=DFLTDICSPACE) + printf(" (default=%ld)",DFLTDICSPACE); + printf(" %ld in use\n",(long)(dicq-dic)); + return; } + checkeol; + printf( + "sorry, cannot change size of dictionary while in use\n"); + printf( + "(/q and reinvoke with flag: mira -dic %s ... )\n",dicp); + return; } + case 'e': if(is("e")||is("edit")) + { char *mf=0; + if(t=token())t=addextn(1,t); + else t=current_script; + checkeol; + if(stat(t,&buf)) /* new file */ + { if(!lmirahdr) /* lazy initialisation */ + { dicp=dicq; + (void)strcpy(dicp,getenv("HOME")); + if(strcmp(dicp,"/")==0) + dicp[0]=0; /* root is special case */ + (void)strcat(dicp,"/.mirahdr"); + lmirahdr=dicp; + dicq=dicp=dicp+strlen(dicp)+1; } /* ovflo check? */ + if(!stat(lmirahdr,&buf))mf=lmirahdr; + if(!mf&&!mirahdr) /* lazy initialisation */ + { dicp=dicq; + (void)strcpy(dicp,miralib); + (void)strcat(dicp,"/.mirahdr"); + mirahdr=dicp; + dicq=dicp=dicp+strlen(dicp)+1; } + if(!mf&&!stat(mirahdr,&buf))mf=mirahdr; + /*if(mf)printf("mf=%s\n",mf); /* DEBUG*/ + if(mf&&t!=current_script) + { printf("open new script \"%s\"? [ny]",t); + ch1=ch=getchar(); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + /*eat rest of line */ + if(ch1!='y'&&ch1!='Y')return; } + if(mf)filecp(mf,t); } + editfile(t,strcmp(t,current_script)==0?errline: + errs&&strcmp(t,(char *)hd[errs])==0?tl[errs]: + geterrlin(t)); + return; } + if(is("editor")) + { char *hold=linebuf,*h; + if(!getln(stdin,pnlim-1,hold))break; /*reject if too long*/ + if(!*hold) + { /* lose=getchar(); /* to eat newline */ + printf("%s\n",editor); + return; } + h=hold+strlen(hold); /* remove trailing white space */ + while(h[-1]==' '||h[-1]=='\t')*--h='\0'; + if(*hold=='"'||*hold=='\'') + { printf("please type name of editor without quotation marks\n"); + return; } + printf("change editor to: \"%s\"? [ny]",hold); + ch1=ch=getchar(); + while(ch!='\n'&&ch!=EOF)ch=getchar(); /* eat rest of line */ + if(ch1!='y'&&ch1!='Y') + { printf("editor not changed\n"); + return; } + (void)strcpy(ebuf,hold); + editor=ebuf; + fixeditor(); /* reads "vi" as "vi +!" etc */ + echoing=verbosity&listing; + rc_write(); + printf("editor = %s\n",editor); + return; } + case 'f': if(is("f")||is("file")) + { char *t=token(); + checkeol; + if(t)t=addextn(1,t),keep(t); + /* could get multiple copies of filename in dictionary + - FIX LATER */ + if(t)errs=errline=0; /* moved here from reset() */ + if(t)if(strcmp(t,current_script)||files==NIL&&okdump(t)) + { extern word CLASHES; + CLASHES=NIL; /* normally done by load_script */ + undump(t); /* does not always call load_script */ + if(CLASHES!=NIL)/* pathological case, recompile */ + loadfile(t); } + else loadfile(t); /* force recompilation */ + else printf("%s%s\n",current_script, + files==NIL?" (not loaded)":""); + return; } + if(is("files")) /* info about internal state, not documented */ + { word f=files; + checkeol; + for(;f!=NIL;f=tl[f]) + printf("(%s,%ld,%ld)",get_fil(hd[f]),fil_time(hd[f]), + fil_share(hd[f])),printlist("",fil_defs(hd[f])); + return; } /* DEBUG */ + if(is("find")) + { word i=0; + while(token()) + { word x=findid(dicp),y,f; + i++; + if(x!=NIL) + { char *n=get_id(x); + for(y=primenv;y!=NIL;y=tl[y]) + if(tag[hd[y]]==ID) + if(hd[y]==x||getaka(hd[y])==n) + finger(get_id(hd[y])); + for(f=files;f!=NIL;f=tl[f]) + for(y=fil_defs(hd[f]);y!=NIL;y=tl[y]) + if(tag[hd[y]]==ID) + if(hd[y]==x||getaka(hd[y])==n) + finger(get_id(hd[y])); } + } + ch=getchar(); /* '\n' */ + if(i==0)printf("\7identifier needed after `/find'\n"); + return; } + case 'g': if(is("gc")) + { checkeol; atgc=1; return; } + case 'h': if(is("h")||is("help")) + { checkeol; +/* if(verbosity)clrscr(); */ + (void)strcpy(linebuf,miralib); + (void)strcat(linebuf,"/helpfile"); + filecopy(linebuf); + return; } + if(is("heap")) + { word x; + if(!token()) + { lose=getchar(); /* to eat \n */ + printf("%ld cells",SPACELIMIT); + if(SPACELIMIT!=DFLTSPACE) + printf(" (default=%ld)",DFLTSPACE); + printf("\n"); + return; } + checkeol; + if(sscanf(dicp,"%ld",&x)!=1||badval(x)) + { printf("illegal value (heap unchanged)\n"); return; } + if(x + +void filequote(p) /* write p to stdout with if appropriate */ +char *p; /* p is a pathname */ +{ static int mlen=0; + if(!mlen)mlen=(rindex(PRELUDE,'/')-PRELUDE)+1; + if(strncmp(p,PRELUDE,mlen)==0) + printf("<%s>",p+mlen); + else printf("\"%s\"",p); +} /* PRELUDE is a convenient string with the miralib prefix */ + +void finger(n) /* find info about name stored at dicp */ +char *n; +{ word x; int line; + char *s; + x=findid(n); + if(x!=NIL&&id_type(x)!=undef_t) + { if(id_who(x)!=NIL) + s=(char *)hd[line=get_here(x)],line=tl[line]; + if(!lastid)lastid=x; + report_type(x); + if(id_who(x)==NIL)printf(" ||primitive to Miranda\n"); + else { char *aka=getaka(x); + if(aka==get_id(x))aka=NULL; /* don't report alias to self */ + if(id_val(x)==UNDEF&&id_type(x)!=wrong_t) + printf(" ||(UNDEFINED) specified in "); else + if(id_val(x)==FREE) + printf(" ||(FREE) specified in "); else + if(id_type(x)==type_t&&t_class(x)==free_t) + printf(" ||(free type) specified in "); else + printf(" ||%sdefined in ", + id_type(x)==type_t + && t_class(x)==abstract_t?"(abstract type) ": + id_type(x)==type_t + && t_class(x)==algebraic_t?"(algebraic type) ": + id_type(x)==type_t + && t_class(x)==placeholder_t?"(placeholder type) ": + id_type(x)==type_t + && t_class(x)==synonym_t?"(synonym type) ": + ""); + filequote(s); + if(baded||rechecking)printf(" line %d",line); + if(aka)printf(" (as \"%s\")\n",aka); + else putchar('\n'); + } + if(atobject)printf("%s = ",get_id(x)), + out(stdout,id_val(x)),putchar('\n'); + return; } + diagnose(n); +} + +void diagnose(n) +char *n; +{ int i=0; + if(isalpha(n[0])) + while(n[i]&&okid(n[i]))i++; + if(n[i]){ printf("\"%s\" -- not an identifier\n",n); return; } + for(i=0;presym[i];i++) + if(strcmp(n,presym[i])==0) + { printf("%s -- keyword (see manual, section %d)\n",n,presym_n[i]); + return; } + printf("identifier \"%s\" not in scope\n",n); +} + +int sorted=0; /* flag to avoid repeatedly sorting fil_defs */ +int leftist; /* flag to alternate bias of padding in justification */ +int words[colmax]; /* max plausible size of screen */ + +void allnamescom() +{ word s; + word x=ND; + word y=x,z=0; + leftist=0; + namescom(make_fil(nostdenv?0:(word)STDENV,0,0,primenv)); + if(files==NIL)return; else s=tl[files]; + while(s!=NIL)namescom(hd[s]),s=tl[s]; + namescom(hd[files]); + sorted=1; + /* now print warnings, if any */ + /*if(ND!=NIL&&id_type(hd[ND])==type_t) + { printf("ILLEGAL EXPORT LIST - MISSING TYPENAME%s: ",tl[ND]==NIL?"":"S"); + printlist("",ND); + return; } /* install if incomplete export list is escalated to error */ + while(x!=NIL&&id_type(hd[x])==undef_t)x=tl[x]; + while(y!=NIL&&id_type(hd[y])!=undef_t)y=tl[y]; + if(x!=NIL) + { printf("WARNING, SCRIPT CONTAINS TYPE ERRORS: "); + for(;x!=NIL;x=tl[x]) + if(id_type(hd[x])!=undef_t) + { if(!z)z=1; else putchar(','); + out(stdout,hd[x]); } + printf(";\n"); } + if(y!=NIL) + { printf("%s UNDEFINED NAMES: ",z?"AND":"WARNING, SCRIPT CONTAINS"); + z=0; + for(;y!=NIL;y=tl[y]) + if(id_type(hd[y])==undef_t) + { if(!z)z=1; else putchar(','); + out(stdout,hd[y]); } + printf(";\n"); } +} +/* There are two kinds of entry in ND + undefined names: val=UNDEF, type=undef_t + type errors: val=UNDEF, type=wrong_t +*/ + +#define tolerance 3 + /* max number of extra spaces we are willing to insert */ + +void namescom(l) /* l is an element of `files' */ +word l; +{ word n=fil_defs(l),col=0,undefs=NIL,wp=0; + word scrwd = twidth(); + if(!sorted&&n!=primenv) /* primenv already sorted */ + fil_defs(l)=n=alfasort(n); /* also removes pnames */ + if(n==NIL)return; /* skip empty files */ + if(get_fil(l))filequote(get_fil(l)); + else printf("primitive:"); + printf("\n"); + while(n!=NIL) + { if(id_type(hd[n])==wrong_t||id_val(hd[n])!=UNDEF) + { word w=strlen(get_id(hd[n])); + if(col+w=scrwd) + { word i,r,j; + if(wp>1)i=(scrwd-col)/(wp-1),r=(scrwd-col)%(wp-1); + if(i+(r>0)>tolerance)i=r=0; + if(leftist) + for(col=0;col0)); } + else + for(r=wp-1-r,col=0;col6) /* perhaps cyclic %include */ + fprintf(stderr,"error occurs %d deep in %%include files\n",ideep); + if(ideep)exit(2); + SYNERR=2; /* special code to prevent makedump() */ + printf("compilation of \"%s\" abandoned\n",current_script); + return(NIL); } + while(pid!=wait(&status)); + if((WEXITSTATUS(status))==2) /* child aborted */ + if(ideep)exit(2); /* recursive abortion of parent process */ + else { SYNERR=2; + printf("compilation of \"%s\" abandoned\n",current_script); + return(NIL); } + /* if we get to here child completed normally, so carry on */ + } + else { /* child does equivalent of `mira -make' on each includee */ + extern word oldfiles; + (void)signal(SIGINT,SIG_DFL); /* don't trap interrupts */ + ideep++; making=1; make_status=0; echoing=listing=verbosity=magic=0; + setjmp(env); /* will return here on blankerr (via reset) */ + while(includees!=NIL&&!make_status) /* stop at first bad includee */ + { undump((char *)hd[hd[hd[includees]]]); + if(ND!=NIL||files==NIL&&oldfiles!=NIL)make_status=1; + /* any errors in dump? */ + includees=tl[includees]; + } /* obscure bug - undump above can reinvoke compiler, which + side effects compiler variable `includees' - to fix this + had to make sure child is holding local copy of includees*/ + exit(make_status); } + sigflag=0; + for(;includees!=NIL;includees=tl[includees]) + { word x=NIL; + sighandler oldsig; + FILE *f; + char *fn=(char *)hd[hd[hd[includees]]]; + extern word DETROP,MISSING,ALIASES,TSUPPRESSED; + (void)strcpy(dicp,fn); + (void)strcpy(dicp+strlen(dicp)-1,obsuffix); + if(!making) /* cannot interrupt load_script() */ + oldsig=signal(SIGINT,(sighandler)sigdefer); + if(f=fopen(dicp,"r")) + x=load_script(f,fn,hd[tl[hd[includees]]],tl[tl[hd[includees]]],0), + fclose(f); + ld_stuff=cons(x,ld_stuff); + if(!making)(void)signal(SIGINT,oldsig); + if(sigflag)sigflag=0,(* oldsig)(); /* take deferred interrupt */ + if(f&&!BAD_DUMP&&x!=NIL&&ND==NIL&&CLASHES==NIL&&ALIASES==NIL&& + TSUPPRESSED==NIL&&DETROP==NIL&&MISSING==NIL) + /* i.e. if load_script worked ok */ + { /* stuff here is to share repeated file components + issues: + Consider only includees (fil_share=1), not insertees. + Effect of sharing is to replace value fields in later copies + by (pointers to) corresponding ids in first copy - so sharing + transmitted thru dumps. It is illegal to have more than one + copy of a (non-synonym) type in the same scope, even under + different names. */ + word y,z; + /* printf("start share analysis\n"); /* DEBUG */ + if(TORPHANS)rfl=shunt(x,rfl); /* file has type orphans */ + for(y=x;y!=NIL;y=tl[y])fil_inodev(hd[y])=inodev(get_fil(hd[y])); + for(y=x;y!=NIL;y=tl[y]) + if(fil_share(hd[y])) + for(z=result;z!=NIL;z=tl[z]) + if(fil_share(hd[z])&&same_file(hd[y],hd[z]) + &&fil_time(hd[y])==fil_time(hd[z])) + { word p=fil_defs(hd[y]),q=fil_defs(hd[z]); + for(;p!=NIL&&q!=NIL;p=tl[p],q=tl[q]) + if(tag[hd[p]]==ID) + if(id_type(hd[p])==type_t&& + (tag[hd[q]]==ID||tag[pn_val(hd[q])]==ID)) + { /* typeclash - record in tclashes */ + word w=tclashes; + word orig=tag[hd[q]]==ID?hd[q]:pn_val(hd[q]); + if(t_class(hd[p])==synonym_t)continue; + while(w!=NIL&&((char *)hd[hd[w]]!=get_fil(hd[z]) + ||hd[tl[hd[w]]]!=orig)) + w=tl[w]; + if(w==NIL) + w=tclashes=cons(strcons(get_fil(hd[z]), + cons(orig,NIL)),tclashes); + tl[tl[hd[w]]]=cons(hd[p],tl[tl[hd[w]]]); + } + else the_val(hd[q])=hd[p]; + else the_val(hd[p])=hd[q]; + /*following test redundant - remove when sure is ok*/ + if(p!=NIL||q!=NIL) + fprintf(stderr,"impossible event in mkincludes\n"); + /*break; /* z loop -- NO! (see liftbug) */ + } + if(member(exportfiles,(word)fn)) + { /* move ids of x onto exports */ + for(y=x;y!=NIL;y=tl[y]) + for(z=fil_defs(hd[y]);z!=NIL;z=tl[z]) + if(isvariable(hd[z])) + tl[exports]=add1(hd[z],tl[exports]); + /* skip pnames, constructors (expanded later) */ + } + result=append1(result,x); + /* keep `result' in front-first order */ + if(hd[FBS]==NIL)FBS=tl[FBS]; + else hd[FBS]=cons(tl[hd[hd[includees]]],hd[FBS]); /* hereinfo */ + /* printf("share analysis finished\n"); /* DEBUG */ + continue; } + /* something wrong - find out what */ + if(!f)result=cons(make_fil(hd[hd[hd[includees]]], + fm_time(fn),0,NIL),result); else + if(x==NIL&&BAD_DUMP!= -2)result=append1(result,oldfiles),oldfiles=NIL; + else result=append1(result,x); + /* above for benefit of `oldfiles' */ + /* BAD_DUMP -2 is nameclashes due to aliasing */ + SYNERR=1; + printf("unsuccessful %%include directive "); + sayhere(tl[hd[hd[includees]]],1); +/* if(!f)printf("\"%s\" non-existent or unreadable\n",fn), */ + if(!f)printf("\"%s\" cannot be loaded\n",fn), + CLASHES=DETROP=MISSING=NIL; + /* just in case not cleared from a previous load_script() */ + else + if(BAD_DUMP== -2) + printlist("aliasing causes nameclashes: ",CLASHES), + CLASHES=NIL; else + if(ALIASES!=NIL||TSUPPRESSED!=NIL) + { if(ALIASES!=NIL) + printf("alias fails (name%s not found in file", + tl[ALIASES]==NIL?"":"s"), + printlist("): ",ALIASES),ALIASES=NIL; + if(TSUPPRESSED!=NIL) + { printf("illegal alias (cannot suppress typename%s):", + tl[TSUPPRESSED]==NIL?"":"s"); + while(TSUPPRESSED!=NIL) + printf(" -%s",get_id(hd[TSUPPRESSED])), + TSUPPRESSED=tl[TSUPPRESSED]; + putchar('\n'); } + /* if -typename allowed, remember to look for type orphans */ + }else + if(BAD_DUMP)printf("\"%s\" has bad data in dump file\n",fn); else + if(x==NIL)printf("\"%s\" contains syntax error\n",fn); else + if(ND!=NIL) + printf("\"%s\" contains undefined names or type errors\n",fn); + if(ND==NIL&&CLASHES!=NIL) /* can have this and failed aliasing */ + printf("\"%s\" ",fn),printlist("causes nameclashes: ",CLASHES); + while(DETROP!=NIL&&tag[hd[DETROP]]==CONS) + { word fa=hd[tl[hd[DETROP]]],ta=tl[tl[hd[DETROP]]]; + char *pn=get_id(hd[hd[DETROP]]); + if(fa== -1||ta== -1) + printf("`%s' has binding of wrong kind ",pn), + printf(fa== -1?"(should be \"= value\" not \"== type\")\n" + :"(should be \"== type\" not \"= value\")\n"); + else + printf("`%s' has == binding of wrong arity ",pn), + printf("(formal has arity %ld, actual has arity %ld)\n",fa,ta); + DETROP=tl[DETROP]; } + if(DETROP!=NIL) + printf("illegal parameter binding (name%s not %%free in file", + tl[DETROP]==NIL?"":"s"), + printlist("): ",DETROP),DETROP=NIL; + if(MISSING!=NIL) + printf("missing parameter binding%s: ",tl[MISSING]==NIL?"":"s"); + while(MISSING!=NIL) + printf("%s%s",(char *)hd[hd[MISSING]],tl[MISSING]==NIL?";\n":","), + MISSING=tl[MISSING]; + printf("compilation abandoned\n"); + stackp=dstack; /* in case of BAD_DUMP */ + return(result); } /* for unload() */ + if(tclashes!=NIL) + { printf("TYPECLASH - the following type%s multiply named:\n", + tl[tclashes]==NIL?" is":"s are"); + /* structure of tclashes is list of strcons(filname,list-of-ids) */ + for(;tclashes!=NIL;tclashes=tl[tclashes]) + { printf("\'%s\' of file \"%s\", as: ", + getaka(hd[tl[hd[tclashes]]]), + (char *)hd[hd[tclashes]]); + printlist("",alfasort(tl[hd[tclashes]])); } + printf("typecheck cannot proceed - compilation abandoned\n"); + SYNERR=1; + return(result); } /* for unload */ + return(result); +} + +word tlost=NIL; +word pfrts=NIL; /* list of private free types bound in this script */ + +void readoption() /* readopt type orphans */ +{ word f,t; + extern word TYPERRS,FBS; + pfrts=tlost=NIL; + /* exclude anonymous free types, these dealt with later by mcheckfbs() */ + if(FBS!=NIL) + for(f=FBS;f!=NIL;f=tl[f]) + for(t=tl[hd[f]];t!=NIL;t=tl[t]) + if(tag[hd[hd[t]]]==STRCONS&&tl[tl[hd[t]]]==type_t) + pfrts=cons(hd[hd[t]],pfrts); + /* this may needlessly scan `silent' files - fix later */ + for(;rfl!=NIL;rfl=tl[rfl]) + for(f=fil_defs(hd[rfl]);f!=NIL;f=tl[f]) + if(tag[hd[f]]==ID) + if((t=id_type(hd[f]))==type_t) + { if(t_class(hd[f])==synonym_t) + t_info(hd[f])=fixtype(t_info(hd[f]),hd[f]); } + else id_type(hd[f])=fixtype(t,hd[f]); + if(tlost==NIL)return; + TYPERRS++; + printf("MISSING TYPENAME%s\n",tl[tlost]==NIL?"":"S"); + printf("the following type%s no name in this scope:\n", + tl[tlost]==NIL?" is needed but has":"s are needed but have"); + /* structure of tlost is list of cons(losttype,list-of-ids) */ + for(;tlost!=NIL;tlost=tl[tlost]) + { /* printf("tinfo_tlost=");out(stdout,t_info(hd[hd[tlost]])); + putchar(';'); /*DEBUG */ + printf("\'%s\' of file \"%s\", needed by: ", + (char *)hd[hd[t_info(hd[hd[tlost]])]], + (char *)hd[tl[t_info(hd[hd[tlost]])]]); + printlist("",alfasort(tl[hd[tlost]])); } +} + +word fixtype(t,x) /* substitute out any indirected typenames in t */ +word t,x; +{ switch(tag[t]) + { case AP: + case CONS: tl[t]=fixtype(tl[t],x); + hd[t]=fixtype(hd[t],x); + default: return(t); + case STRCONS: if(member(pfrts,t))return(t); /* see jrcfree.bug */ + while(tag[pn_val(t)]!=CONS)t=pn_val(t);/*at most twice*/ + if(tag[t]!=ID) + { /* lost type - record in tlost */ + word w=tlost; + while(w!=NIL&&hd[hd[w]]!=t)w=tl[w]; + if(w==NIL) + w=tlost=cons(cons(t,cons(x,NIL)),tlost); + tl[hd[w]]=add1(x,tl[hd[w]]); + } + return(t); + } +} + +#define mask(c) (c&0xDF) +/* masks out lower case bit, which is 0x20 */ +word alfa_ls(a,b) /* 'DICTIONARY ORDER' - not currently used */ +char *a,*b; +{ while(*a&&mask(*a)==mask(*b))a++,b++; + if(mask(*a)==mask(*b))return(strcmp(a,b)<0); /* lower case before upper */ + return(mask(*a)=256)putchar('\"'); + if(yychar!=0)out2(stdout,yychar); + if(yychar>=256)putchar('\"'); } + printf("\n"); + SYNERR=1; + reset_lex(); +} + +void syntax(s) /* called by actions after discovering a (context sensitive) syntax + error */ +char *s; +{ if(SYNERR)return; + if(echoing)printf("\n"); + printf("syntax error: %s",s); + SYNERR=1; /* this will stop YACC at its next call to yylex() */ + reset_lex(); +} + +void acterror() /* likewise, but assumes error message output by caller */ +{ if(SYNERR)return; + SYNERR=1; /* to stop YACC at next symbol */ + reset_lex(); +} + +void mira_setup() +{ extern word common_stdin,common_stdinb,cook_stdin; + setupheap(); + tsetup(); + reset_pns(); + bigsetup(); + common_stdin= ap(READ,0); + common_stdinb= ap(READBIN,0); + cook_stdin=ap(readvals(0,0),OFFSIDE); + nill= cons(CONST,NIL); + Void=make_id("()"); + id_type(Void)=void_t; + id_val(Void)=constructor(0,Void); + message=make_id("sys_message"); + main_id=make_id("main"); /* change to magic scripts 19.11.2013 */ + concat=make_id("concat"); + diagonalise=make_id("diagonalise"); + standardout=constructor(0,"Stdout"); + indent_fn=make_id("indent"); + outdent_fn=make_id("outdent"); + listdiff_fn=make_id("listdiff"); + shownum1=make_id("shownum1"); + showbool=make_id("showbool"); + showchar=make_id("showchar"); + showlist=make_id("showlist"); + showstring=make_id("showstring"); + showparen=make_id("showparen"); + showpair=make_id("showpair"); + showvoid=make_id("showvoid"); + showfunction=make_id("showfunction"); + showabstract=make_id("showabstract"); + showwhat=make_id("showwhat"); + primlib(); } /* sets up predefined ids, not referred to by rules.y */ + +void dieclean() /* called if evaluation is interrupted - see rules.y */ +{ printf("<<...interrupt>>\n"); +#ifndef NOSTATSONINT + outstats(); /* suppress in presence of segfault on ^C with /count */ +#endif + exit(0); +} + +/* the function process() creates a process and waits for it to die - + returning 1 in the child and 0 in the parent - it is used in the + evaluation command (see rules.y) */ +word process() +{ int pid; + sighandler oldsig; + oldsig = signal(SIGINT,SIG_IGN); + /* do not let parent receive interrupts intended for child */ + if(pid=fork()) + { /* parent */ + int status; /* see man 2 exit, wait, signal */ + if(pid== -1) + { perror("UNIX error - cannot create process"); + return(0); + } + while(pid!=wait(&status)); + /* low byte of status is termination state of child, next byte is the + (low order byte of the) exit status */ + if(WIFSIGNALED(status)) /* abnormal termination status */ + { char *cd=status&0200?" (core dumped)":""; + char *pc=""; /* "probably caused by stack overflow\n";*/ + switch(WTERMSIG(status)) + { case SIGBUS: printf("\n<<...bus error%s>>\n%s",cd,pc); break; + case SIGSEGV: printf("\n<<...segmentation fault%s>>\n%s",cd,pc); break; + default: printf("\n<<...uncaught signal %d>>\n",WTERMSIG(status)); + } } + /*if(status >>= 8)printf("\n(exit status %d)\n",status); */ + (void)signal(SIGINT,oldsig); /* restore interrupt status */ + return(0); } + else return(1); /* child */ +} + +/* Notice that the Miranda system has a two-level interrupt structure. + 1) Each evaluation (see rules.y) is an interruptible process. + 2) If the command loop is interrupted outside an evaluation or during + compilation it reverts to the top level prompt - see set_jmp and + signal(reset) in commandloop() */ + +void primdef(n,v,t) /* used by "primlib", see below */ +char *n; +word v,t; +{ word x; + x= make_id(n); + primenv=cons(x,primenv); + id_val(x)= v; + id_type(x)=t; } + +void predef(n,v,t) /* used by "privlib" and "stdlib", see below */ +char *n; +word v,t; +{ word x; + x= make_id(n); + addtoenv(x); + id_val(x)= isconstructor(x)?constructor(v,x):v; + id_type(x)=t; +} + +void primlib() /* called by "mira_setup", this routine enters + the primitive identifiers into the primitive environment */ +{ primdef("num",make_typ(0,0,synonym_t,num_t),type_t); + primdef("char",make_typ(0,0,synonym_t,char_t),type_t); + primdef("bool",make_typ(0,0,synonym_t,bool_t),type_t); + primdef("True",1,bool_t); /* accessible only to 'finger' */ + primdef("False",0,bool_t); /* likewise - FIX LATER */ +} + +void privlib() /* called when compiling , adds some + internally defined identifiers to the environment */ +{ extern word ltchar; + predef("offside",OFFSIDE,ltchar); /* used by `indent' in prelude */ + predef("changetype",I,wrong_t); /* wrong_t to prevent being typechecked */ + predef("first",HD,wrong_t); + predef("rest",TL,wrong_t); +/* the following added to make prelude compilable without stdenv */ + predef("code",CODE,undef_t); + predef("concat",ap2(FOLDR,APPEND,NIL),undef_t); + predef("decode",DECODE,undef_t); + predef("drop",DROP,undef_t); + predef("error",ERROR,undef_t); + predef("filter",FILTER,undef_t); + predef("foldr",FOLDR,undef_t); + predef("hd",HD,undef_t); + predef("map",MAP,undef_t); + predef("shownum",SHOWNUM,undef_t); + predef("take",TAKE,undef_t); + predef("tl",TL,undef_t); +} + +void stdlib() /* called when compiling , adds some + internally defined identifiers to the environment */ +{ predef("arctan",ARCTAN_FN,undef_t); + predef("code",CODE,undef_t); + predef("cos",COS_FN,undef_t); + predef("decode",DECODE,undef_t); + predef("drop",DROP,undef_t); + predef("entier",ENTIER_FN,undef_t); + predef("error",ERROR,undef_t); + predef("exp",EXP_FN,undef_t); + predef("filemode",FILEMODE,undef_t); + predef("filestat",FILESTAT,undef_t); /* added Feb 91 */ + predef("foldl",FOLDL,undef_t); + predef("foldl1",FOLDL1,undef_t); /* new at release 2 */ + predef("hugenum",sto_dbl(DBL_MAX),undef_t); + predef("last",LIST_LAST,undef_t); + predef("foldr",FOLDR,undef_t); + predef("force",FORCE,undef_t); + predef("getenv",GETENV,undef_t); + predef("integer",INTEGER,undef_t); + predef("log",LOG_FN,undef_t); + predef("log10",LOG10_FN,undef_t); /* new at release 2 */ + predef("merge",MERGE,undef_t); /* new at release 2 */ + predef("numval",NUMVAL,undef_t); + predef("read",STARTREAD,undef_t); + predef("readb",STARTREADBIN,undef_t); + predef("seq",SEQ,undef_t); + predef("shownum",SHOWNUM,undef_t); + predef("showhex",SHOWHEX,undef_t); + predef("showoct",SHOWOCT,undef_t); + predef("showfloat",SHOWFLOAT,undef_t); /* new at release 2 */ + predef("showscaled",SHOWSCALED,undef_t); /* new at release 2 */ + predef("sin",SIN_FN,undef_t); + predef("sqrt",SQRT_FN,undef_t); + predef("system",EXEC,undef_t); /* new at release 2 */ + predef("take",TAKE,undef_t); + predef("tinynum",mktiny(),undef_t); /* new at release 2 */ + predef("zip2",ZIP,undef_t); /* new at release 2 */ +} + +word mktiny() +{ volatile + double x=1.0,x1=x/2.0; + while(x1>0.0)x=x1,x1/=2.0; + return(sto_dbl(x)); +} + +word size(x) /* measures the size of a compiled expression */ +word x; +{ word s; + s= 0; + while(tag[x]==CONS||tag[x]==AP) + { s= s+1+size(hd[x]); + x= tl[x]; } + return(s); } + +void makedump() +{ char *obf=linebuf; + FILE *f; + (void)strcpy(obf,current_script); + (void)strcpy(obf+strlen(obf)-1,obsuffix); + f=fopen(obf,"w"); + if(!f){ printf("WARNING: CANNOT WRITE TO %s\n",obf); + if(strcmp(current_script,PRELUDE)==0|| + strcmp(current_script,STDENV)==0) + printf( + "TO FIX THIS PROBLEM PLEASE GET SUPER-USER TO EXECUTE `mira'\n"); + if(making&&!make_status)make_status=1; + return; } + /* printf("dumping to %s\n",obf); /* DEBUG */ + unlinkme=obf; + /* fchmod(fileno(f),0666); /* to make dumps writeable by all */ /* no! */ + setprefix(current_script); + dump_script(files,f); + unlinkme=NULL; + fclose(f); +} + +void undump(t) /* restore t from dump, or recompile if necessary */ +char *t; +{ extern word BAD_DUMP,CLASHES; + if(!normal(t)&&!initialising)return loadfile(t); + /* except for prelude, only .m files have dumps */ + char obf[pnlim]; + FILE *f; + sighandler oldsig; + word flen=strlen(t); + time_t t1=fm_time(t),t2; + if(flen>pnlim) + { printf("sorry, pathname too long (limit=%d): %s\n",pnlim,t); + return; } /* if anyone complains, should remove this limit */ + (void)strcpy(obf,t); + (void)strcpy(obf+flen-1,obsuffix); + t2=fm_time(obf); + if(t2&&!t1)t2=0,unlink(obf); /* dump is orphan - remove */ + if(!t2||t20)write(1,fbuf,n); + close(in); +} + +void filecp(fil1,fil2) /* copy file "fil1" to "fil2" (like `cp') */ +char *fil1,*fil2; +{ word in=open(fil1,0),n; + word out=creat(fil2,0644); + if(in== -1||out== -1)return; + while((n=read(in,fbuf,512))>0)write(out,fbuf,n); + close(in); + close(out); +} + +/* to define winsize and TIOCGWINSZ for twidth() */ +#include +#include + +int twidth() /* returns width (in columns) of current window, less 2 */ +{ +#ifdef TIOCGWINSZ + static struct winsize tsize; + ioctl(fileno(stdout),TIOCGWINSZ,&tsize); + return (tsize.ws_col==0)?78:tsize.ws_col-2; +#else +#error TIOCGWINSZ undefined +/* porting note: if you cannot find how to enable use of TIOCGWINSZ + comment out the above #error line */ + return 78; /* give up, we will assume screen width to be 80 */ +#endif +} + +/* was called when Miranda starts up and before /help, /aux + to clear screen - suppressed Oct 2019 */ +/* clrscr() +{ printf("\x1b[2J\x1b[H"); fflush(stdout); +} */ + +/* the following code tests if we are in a UTF-8 locale */ + +#ifdef CYGWIN +#include + +int utf8test() +{ return GetACP()==65001; } +/* codepage 1252 is Windows version of Latin-1; 65001 is UTF-8 */ + +#else + +int utf8test() +{ char *lang; + if(!(lang=getenv("LC_CTYPE"))) + lang=getenv("LANG"); + if(lang&& + (strstr(lang,"UTF-8")||strstr(lang,"UTF8")|| + strstr(lang,"utf-8")||strstr(lang,"utf8"))) + return 1; + return 0; +} +#endif + +/* end of MIRANDA STEER */ + -- cgit v1.2.1