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 --- new/lex.c | 1213 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1213 insertions(+) create mode 100644 new/lex.c (limited to 'new/lex.c') diff --git a/new/lex.c b/new/lex.c new file mode 100644 index 0000000..a4e9d09 --- /dev/null +++ b/new/lex.c @@ -0,0 +1,1213 @@ +/* MIRANDA LEX ANALYSER */ + +/************************************************************************** + * Copyright (C) Research Software Limited 1985-90. All rights reserved. * + * The Miranda system is distributed as free software under the terms in * + * the file "COPYING" which is included in the distribution. * + *------------------------------------------------------------------------*/ + +#include "data.h" +#include "lex.h" +#include + +extern word DICSPACE; /* see steer.c for default value */ +/* capacity in chars of dictionary space for storing identifiers and file names + to get a larger name space just increase this number */ +extern FILE *s_in; +extern word echoing,listing,verbosity,magic,inbnf,inlex; +word fileq=NIL; /* list of currently open-for-input files, of form + cons(strcons(stream,),...)*/ +word insertdepth= -1,margstack=NIL,col=0,lmargin=0; +word echostack=NIL; +word lverge=0,vergstack=NIL; +char *prefixbase; /* stores prefixes for pathnames, to get static resolution */ +word prefixlimit=1024; /* initial size of space for prefixes */ +word prefix,prefixstack=NIL; /* current prefix, stack of old prefixes */ +word atnl=1,line_no=0; +word lastline; +word litstack=NIL,linostack=NIL; +word c=' ', lastc; +word commandmode; +word common_stdin,common_stdinb,cook_stdin; +word litmain=0,literate=0; /* flags "literate" comment convention */ +char *dic,*dicp,*dicq; +char *pathname(); + +setupdic() +{ dicp=dicq=dic=malloc(DICSPACE); + if(dic==NULL)mallocfail("dictionary"); + /* it is not permissible to realloc dic, because at the moment identifiers + etc. contain absolute pointers into the dictionary space - so we must + choose fairly large initial value for DICSPACE. Fix this later */ + prefixbase=malloc(prefixlimit); + prefixbase[0]='\0'; + prefix=0; +} + +/* this allows ~login convention in filenames */ +/* #define okgetpwnam +/* suppress 26.5.06 getpwnam cases runtime error when statically linked (Linux) */ + +#ifdef okgetpwnam +#include +struct passwd *getpwnam(); +#endif +char *getenv(); + +char *gethome(n) /* for expanding leading `~' in tokens and pathnames */ +char *n; +{ struct passwd *pw; + if(n[0]=='\0')return(getenv("HOME")); +#ifdef okgetpwnam + if(pw=getpwnam(n))return(pw->pw_dir); +#endif + return(NULL); +} + +#define ovflocheck if(dicq-dic>DICSPACE)dicovflo() + +dicovflo() /* is this called everywhere it should be? Check later */ +{ fprintf(stderr,"\npanic: dictionary overflow\n"); exit(1); } + +char *token() /* lex analyser for command language (very simple) */ +{ extern char *current_script; + word ch=getchar(); + dicq = dicp; /* uses top of dictionary as temporary work space */ + while(ch==' '||ch=='\t')ch=getchar(); + if(ch=='~') + { char *h; + *dicq++ = ch; + ch=getchar(); + while(isalnum(ch)||ch=='-'||ch=='_'||ch=='.') + *dicq++ = ch,ch=getchar(); + /* NB csh does not allow `.' in user ids when expanding `~' + but this may be a mistake */ + *dicq='\0'; + if(h=gethome(dicp+1)) + (void)strcpy(dicp,h),dicq=dicp+strlen(dicp); + } +#ifdef SPACEINFILENAMES + if(ch!='"'&&ch!='<') /* test added 9.5.06 see else part */ +#endif + while(!isspace(ch)&&ch!=EOF) + { *dicq++ = ch; + if(ch=='%') + if(dicq[-2]=='\\')(--dicq)[-1]='%'; + else dicq--,(void)strcpy(dicq,current_script),dicq+=strlen(dicq); + ch=getchar(); } +#ifdef SPACEINFILENAMES + else { word closeq= ch=='<'?'>':'"'; /* this branch added 9.5.06 */ + *dicq++ = ch; /* to allow spaces in "tok" or */ + ch=getchar(); + while(ch!=closeq&&ch!='\n'&&ch!=EOF) + *dicq++ = ch, ch=getchar(); + if(ch==closeq)*dicq++ = ch, ch=getchar(); } +#endif + *dicq++ = '\0'; + ovflocheck; + while(ch==' '||ch=='\t')ch=getchar(); + ungetc(ch,stdin); + return(*dicp=='\0'?(char *)NULL:dicp); +} /* NB - if no token returns NULL rather than pointer to empty string */ + +char *addextn(b,s) /* if(b)force s to end in ".m", and resolve */ +word b; +char *s; +{ extern char *miralib; + extern char linebuf[]; + word n=strlen(s); + /* printf("addextn(%s)\n",s); /* DEBUG */ + if(s[0]=='<'&&s[n-1]=='>') + { static miralen=0; /* code to handle quotes added 21/1/87 */ + if(!miralen)miralen=strlen(miralib); + strcpy(linebuf,miralib); + linebuf[miralen]= '/'; + strcpy(linebuf+miralen+1,s+1); + strcpy(dicp,linebuf); + s=dicp; + n=n+miralen-1; + dicq=dicp+n+1; + dicq[-1] = '\0'; /* overwrites '>' */ + ovflocheck; } else + if(s[0]=='\"'&&s[n-1]=='\"') + { /*strip quotes */ + dicq=dicp; s++; + while(*s)*dicq++ = *s++; + dicq[-1]='\0'; /* overwrites '"' */ + s=dicp; n=n-2; + } + if(!b||strcmp(s+n-2,".m")==0)return(s); + if(s==dicp)dicq--;/*if s in scratch area at top of dic, extend in situ*/ + else { /* otherwise build new copy at top of dic */ + dicq=dicp; + while(*s)*dicq++ = *s++; + *dicq = '\0'; } + if(strcmp(dicq-2,".x")==0)dicq -= 2; else + if(dicq[-1]=='.')dicq -= 1; + (void)strcpy(dicq,".m"); + dicq += 3; + ovflocheck; + /* printf("return(%s)\n",dicp); /* DEBUG */ + return(dicp); +} /* NB - call keep(dicp) if the result is to be retained */ + +word brct=0; + +spaces(n) +word n; +{ while(n-- >0)putchar(' '); +} + +litname(s) +char *s; +{ word n=strlen(s); + return(n>=6 && strcmp(s+n-6,".lit.m")==0); +} + +word getch() /* keeps track of current position in the variable "col"(column) */ +{ word ch= getc(s_in); + if(ch==EOF&&!atnl&&tl[fileq]==NIL) /* badly terminated top level file */ + { atnl=1; return('\n'); } + if(atnl) + { if((line_no==0&&!commandmode||magic&&line_no==1)&&litstack==NIL) + litmain=literate= (ch=='>')||litname(get_fil(current_file)); + if(literate) + { word i=0; + while(ch!=EOF&&ch!='>') + { ungetc(ch,s_in); + line_no++; + (void)fgets(dicp,250,s_in); + if(i==0&&line_no>1)chblank(dicp); i++; + if(echoing)spaces(lverge),fputs(dicp,stdout); + ch=getc(s_in); } + if((i>1||line_no==1&&i==1)&&ch!=EOF)chblank(dicp); + if(ch=='>') + { if(echoing)putchar(ch),spaces(lverge);ch=getc(s_in); } + } /* supports alternative `literate' comment convention */ + atnl=0; col= lverge+literate; + if(!commandmode&&ch!=EOF)line_no++; } + if(echoing&&ch!=EOF) + { putchar(ch); + if(ch=='\n'&&!literate) + if(litmain)putchar('>'),spaces(lverge); + else spaces(lverge); + } + if(ch=='\t')col= ((col-lverge)/8 + 1)*8+lverge; + else col++; + if(ch=='\n')atnl= 1; + return(ch); } + +word blankerr=0; + +chblank(s) +char *s; +{ while(*s==' '||*s=='\t')s++; + if(*s=='\n')return; + syntax("formal text not delimited by blank line\n"); + blankerr=1; + reset(); /* easiest way to recover is to pretend it was an interrupt */ +} + +/* getlitch gets a character from input like getch, but using C escaping + conventions if the char is backslash -- for use in reading character + and string constants */ + +word rawch; +/* it is often important to know, when certain characters are returned (e.g. + quotes and newlines) whether they were escaped or literal */ + +word errch; /* for reporting unrecognised \escape */ + +word getlitch() +{ extern word UTF8; + word ch=c; + rawch = ch; + if(ch=='\n')return(ch); /* always an error */ + if(UTF8&&ch>127) + { /* UTF-8 uses 2 or 3 bytes for unicode points to 0xffff */ + word ch1=c=getch(); + if((ch&0xe0)==0xc0) /* 2 bytes */ + { if((ch1&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return sto_char((ch&0x1f)<<6|ch1&0x3f); } + word ch2=c=getch(); + if((ch&0xf0)==0xe0) /* 3 bytes */ + { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return sto_char((ch&0xf)<<12|(ch1&0x3f)<<6|ch2&0x3f); } + word ch3=c=getch(); + if((ch&0xf8)==0xf0) /* 4 bytes, beyond basic multiligual plane */ + { if((ch1&0xc0)!=0x80||(ch2&0xc0)!=0x80||(ch3&0xc0)!=0x80) + return -5; /* not valid UTF8 */ + c=getch(); + return((ch&7)<<18|(ch1&0x3f)<<12|(ch2&0x3f)<<6|ch3&0x3f); } + return(-5); + /* not UTF8 */ + } + if(ch!='\\') + { c=getch(); return(ch); } + ch = getch(); + c = getch(); + switch(ch) + { case '\n': return(getlitch()); /* escaped nl was handled in 'getch()' */ + case 'a': return('\a'); + case 'b': return('\b'); + case 'f': return('\f'); /* form feed */ + case 'n': return('\n'); /* newline, == linefeed */ + case 'r': return('\r'); /* carriage return */ + case 't': return('\t'); + case 'v': return('\v'); + case 'X': /* omit for Haskell escape rules, see also lines marked H */ + case 'x': if(isxdigit(c)) + { word value, N=ch=='x'?4:6; /* N=7 for Haskell escape rules */ + char hold[8]; + ch = c; + word count=0; + /* while(ch=='0'&&isxdigit(peekch()))ch=getch(); /* H-lose leading 0s */ + while(isxdigit(ch)&&countUMAX?-3 /* \x out of range */ + :sto_char(value); } + else return -2; /* \x with no hex digits */ + default: if('0'<=ch&&ch<='9') + { word n=ch-'0',count=1,N=3; /* N=8 for Haskell escape rules */ + ch = c; + /* while(ch=='0'&&isdigit(peekch()))ch=getch(); /* H-lose leading 0s */ + while(isdigit(ch)&&countUMAX?-4: /* H \decimal out of range */ + sto_char(n); } + if(ch=='\''||ch=='"'||ch=='\\'||ch=='`')return(ch); /* see note */ + if(ch=='&')return -7; /* Haskell null escape, accept silently */ + errch=ch<=255?ch:'?'; + return -6; /* unrecognised \something */ + } +} /* note: we accept \` for ` because getlitch() is used by charclass() */ + +char *rdline() /* used by the "!" command -- see RULES */ +{ extern char *current_script; + static char linebuf[BUFSIZE]; + char *p=linebuf; + word ch=getchar(),expansion=0; + while(ch==' '||ch=='\t')ch=getchar(); + if(ch=='\n'||ch=='!'&&!(*linebuf)) + { /* "!!" or "!" on its own means repeat last !command */ + if(*linebuf)printf("!%s",linebuf); + while(ch!='\n'&&ch!=EOF)ch=getchar(); + return(linebuf); } + if(ch=='!') + expansion=1,p=linebuf+strlen(linebuf)-1; /* p now points at old '\n' */ + else ungetc(ch,stdin); + while((*p++ =ch=getchar())!='\n'&&ch!=EOF) + if(p-linebuf>=BUFSIZE) + { *p='\0'; + fprintf(stderr,"sorry, !command too long (limit=%d chars): %s...\n", + BUFSIZE,linebuf); + while((ch=getchar())!='\n'&&ch!=EOF); + return(NULL); + } else + if(p[-1]=='%') + if(p>linebuf+1&&p[-2]=='\\')(--p)[-1]='%'; else + { (void)strncpy(p-1,current_script,linebuf+BUFSIZE-p); + p = linebuf+strlen(linebuf); + expansion = 1; + } + *p = '\0'; + if(expansion)printf("!%s",linebuf); + return(linebuf); } + +setlmargin() /* this and the next routine are used to enforce the offside + rule ("yylex" refuses to read a symbol if col=hd[margstack]))/* && part fixes utah.bug*/ + { c = getch(); + return(ELSEQ); /* ELSEQ means "OFFSIDE =" */ + } + else return(OFFSIDE); + if(c==';') /* fixes utah2.bug */ + { c=getch(); layout(); + if(c=='='&&(margstack==NIL||col>=hd[margstack])) + { c = getch(); + return(ELSEQ); /* ELSEQ means "OFFSIDE =" */ + } + else return(';'); + } + if( + /* c=='_'&&okid(peekch()) || /* _id/_ID as lowercase id */ + isletter(c)){ kollect(okid); + if(inlex==1){ layout(); + yylval=name(); + return(c=='='?LEXDEF: + isconstructor(yylval)?CNAME: + NAME); } + if(inbnf==1) + /* add trailing space to nonterminal to avoid clash + with ordinary names */ + dicq[-1] = ' ', + *dicq++ = '\0'; + return(identifier(0)); } + if('0'<=c&&c<='9'||c=='.'&&peekdig()) + { if(c=='0'&&tolower(peekch())=='x') + hexnumeral(); else /* added 21.11.2013 */ + if(c=='0'&&tolower(peekch())=='o') + getch(),c=getch(),octnumeral(); /* added 21.11.2013 */ + else numeral(); + return(CONST); } + if(c=='%'&&!commandmode)return(directive()); + if(c=='\'') + { c = getch(); + yylval= getlitch(); + if(yylval<0){ errclass(yylval,0); return CONST; } + if(!is_char(yylval)) + printf("%simpossible event while reading char const ('\\%u\')\n", + echoing?"\n":"",yylval), + acterror(); + if(rawch=='\n'||c!='\'')syntax("improperly terminated char const\n"); + else c= getch(); + return(CONST); } + if(inexplist&&(c=='\"'||c=='<')) + { if(!pathname())syntax("badly formed pathname in %export list\n"); + else exportfiles=strcons(addextn(1,dicp),exportfiles), + keep(dicp); + return(PATHNAME); } + if(inlex==1&&c=='`') + { return(charclass()?ANTICHARCLASS:CHARCLASS); } + if(c=='\"') + { string(); + if(yylval==NIL)yylval=NILS; /* to help typechecker! */ + return(CONST); } + if(inbnf==2) /* fiddle to offside rule in grammars */ + if(c=='[')brct++; else if(c==']')brct--; else + if(c=='|'&&brct==0) + return(OFFSIDE); + if(c==EOF) + { if(tl[fileq]==NIL&&margstack!=NIL)return(OFFSIDE); /* to fix dtbug */ + fclose((FILE *)hd[hd[fileq]]); + fileq= tl[fileq]; insertdepth--; + if(fileq!=NIL&&hd[echostack]) + { if(literate)putchar('>'),spaces(lverge); + printf(""); } + s_in= fileq==NIL?stdin:(FILE *)hd[hd[fileq]]; + c= ' '; + if(fileq==NIL) + { lverge=c=col=lmargin=0; + /* c=0; necessary because YACC sometimes reads 1 token past END */ + atnl=1; + echoing=verbosity&listing; + lastline=line_no; + /* hack so errline can be set right if err at end of file */ + line_no=0; + litmain=literate=0; + return(END); } + else { current_file = tl[hd[fileq]]; + prefix=hd[prefixstack]; + prefixstack=tl[prefixstack]; + echoing=hd[echostack]; + echostack=tl[echostack]; + lverge=hd[vergstack]; + vergstack=tl[vergstack]; + literate=hd[litstack]; + litstack=tl[litstack]; + line_no=hd[linostack]; + linostack=tl[linostack]; } + return(yylex()); } + lastc= c; + c= getch(); +#define try(x,y) if(c==x){ c=getch(); return(y); } + switch(lastc) { + case '_': if(c=='') /* underlined something */ + { c=getch(); + if(c=='<'){ c=getch(); return(LE); } + if(c=='>'){ c=getch(); return(GE); } + if(c=='%'&&!commandmode)return(directive()); + if(isletter(c)) /* underlined reserved word */ + { kollect(okulid); + if(dicp[1]=='_'&&dicp[2]=='') + return(identifier(1)); } + syntax("illegal use of underlining\n"); + return('_'); } + return(lastc); + case '-': try('>',ARROW) try('-',MINUSMINUS) return(lastc); + case '<': try('-',LEFTARROW) try('=',LE) return(lastc); + case '=': if(c=='>'){ syntax("unexpected symbol =>\n"); return '='; } + try('=',EQEQ) return(lastc); + case '+': try('+',PLUSPLUS) return(lastc); + case '.': if(c=='.') + { c=getch(); + return(DOTDOT); + } + return(lastc); + case '\\': try('/',VEL) return(lastc); + case '>': try('=',GE) return(lastc); + case '~': try('=',NE) return(lastc); + case '&': if(c=='>') + { c=getch(); + if(c=='>')yylval=1; + else yylval=0,ungetc(c,s_in); + c=' '; + return(TO); } + return(lastc); + case '/': try('/',DIAG) return(lastc); + case '*': try('*',collectstars()) return(lastc); + case ':': if(c==':') + { c=getch(); + if(c=='='){ c=getch(); return(COLON2EQ); } + else return(COLONCOLON); + } + return(lastc); + case '$': if( + /* c=='_'&&okid(peekch())|| /* _id/_ID as id */ + isletter(c)) + { word t; + kollect(okid); + t=identifier(0); + return(t==NAME?INFIXNAME:t==CNAME?INFIXCNAME:'$'); } + /* the last alternative is an error - caveat */ + if('1'<=c&&c<='9') + { word n=0; + while(isdigit(c)&&n<1e6)n=10*n+c-'0',c=getch(); + if(n>sreds) + /* sreds==0 everywhere except in semantic redn clause */ + printf("%ssyntax error: illegal symbol $%d%s\n", + echoing?"\n":"",n,n>=1e6?"...":""), + acterror(); + else { yylval=mkgvar(n); return(NAME); } + } + if(c=='-') + { if(!compiling) + syntax("unexpected symbol $-\n"); else + {c=getch(); yylval=common_stdin; return(CONST); }} + /* NB we disallow recursive use of $($/+/-) inside $+ data + whence addition of `compiling' to premises */ + if(c==':') + { c=getch(); + if(c!='-')syntax("unexpected symbol $:\n"); else + { if(!compiling) + syntax("unexpected symbol $:-\n"); else + {c=getch(); yylval=common_stdinb; return(CONST); }}} /* $:- */ + if(c=='+') + { /* if(!(commandmode&&compiling||magic)) + syntax("unexpected symbol $+\n"); else /* disallow in scripts */ + if(!compiling) + syntax("unexpected symbol $+\n"); else + { c=getch(); + if(commandmode) + yylval=cook_stdin; + else yylval=ap(readvals(0,0),OFFSIDE); + return(CONST); }} + if(c=='$') + { if(!(inlex==2||commandmode&&compiling)) + syntax("unexpected symbol $$\n"); else + { c=getch(); + if(inlex) { yylval=mklexvar(0); return(NAME); } + else return(DOLLAR2); }} + if(c=='#') + { if(inlex!=2)syntax("unexpected symbol $#\n"); else + { c=getch(); yylval=mklexvar(1); return(NAME); }} + if(c=='*') + { c=getch(); yylval=ap(GETARGS,0); return(CONST); } + if(c=='0') + syntax("illegal symbol $0\n"); + default: return(lastc); +}} + +layout() +{L:while(c==' '||c=='\n'&&!commandmode||c=='\t') c= getch(); + if(c==EOF&&commandmode){ c='\n'; return; } + if(c=='|'&&peekch()=='|' /* ||comments */ + || col==1&&line_no==1 /* added 19.11.2013 */ + &&c=='#'&&peekch()=='!') /* UNIX magic string */ + { while((c=getch())!='\n'&&c!=EOF); + if(c==EOF&&!commandmode)return; + c= '\n'; + goto L; } +} + +collectstars() +{ word n=2; + while(c=='*')c=getch(),n++; + yylval= mktvar(n); + return(TYPEVAR); +} + +word gvars=NIL; /* list of grammar variables - no need to reset */ + +mkgvar(i) /* make bound variable (corresponding to $i in bnf rule) */ +word i; +{ word *p= &gvars; + while(--i) + { if(*p==NIL)*p=cons(sto_id("gvar"),NIL); + p= &tl[*p]; } + if(*p==NIL)*p=cons(sto_id("gvar"),NIL); + return(hd[*p]); +} /* all these variables have the same name, and are not in hashbucket */ + +word lexvar=0; + +mklexvar(i) /* similar - corresponds to $$, $# on rhs of %lex rule */ +word i; /* i=0 or 1 */ +{ extern word ltchar; + if(!lexvar) + lexvar=cons(sto_id("lexvar"),sto_id("lexvar")), + id_type(hd[lexvar])=ltchar, + id_type(tl[lexvar])=genlstat_t(); + return(i?tl[lexvar]:hd[lexvar]); +} + +word ARGC; +char **ARGV; /* initialised in main(), see steer.c */ + +conv_args() /* used to give access to command line args + see case GETARGS in reduce.c */ +{ word i=ARGC,x=NIL; + if(i==0)return(NIL); /* possible only if not invoked from a magic script */ + { while(--i)x=cons(str_conv(ARGV[i]),x); + x=cons(str_conv(ARGV[0]),x); } + return(x); +} + +str_conv(s) /* convert C string to Miranda form */ +char *s; +{ word x=NIL,i=strlen(s); + while(i--)x=cons(s[i],x); + return(x); +} /* opposite of getstring() - see reduce.c */ + +okpath(ch) +word ch; +{ return(ch!='\"'&&ch!='\n'&&ch!='>'); } + +char *pathname() /* returns NULL if not valid pathname (in string quotes) */ +{ layout(); + if(c=='<') /* alternative quotes <..> for system libraries */ + { extern char *miralib; + char *hold=dicp; + c=getch(); + (void)strcpy(dicp,miralib); + dicp+=strlen(miralib); + *dicp++ = '/'; + kollect(okpath); + dicp=hold; + if(c!='>')return(NULL); + c=' '; + return(dicp); } + if(c!='\"')return(NULL); + c=getch(); + if(c=='~') + { char *h,*hold=dicp; + extern char linebuf[]; + *dicp++ = c; + c=getch(); + while(isalnum(c)||c=='-'||c=='_'||c=='.') + *dicp++ = c, c=getch(); + *dicp='\0'; + if(h=gethome(hold+1)) + (void)strcpy(hold,h),dicp=hold+strlen(hold); + else (void)strcpy(&linebuf[0],hold), + (void)strcpy(hold,prefixbase+prefix), + dicp=hold+strlen(prefixbase+prefix), + (void)strcpy(dicp,&linebuf[0]), + dicp+=strlen(dicp); + kollect(okpath); + dicp=hold; + } else + if(c=='/') /* absolute pathname */ + kollect(okpath); + else { /* relative pathname */ + char *hold=dicp; + (void)strcpy(dicp,prefixbase+prefix); + dicp+=strlen(prefixbase+prefix); + kollect(okpath); + dicp=hold; } + if(c!='\"')return(NULL); + c = ' '; + return(dicp); +} /* result is volatile - call keep(dicp) to retain */ + +adjust_prefix(f) /* called at %insert and at loadfile, to get static pathname + resolution */ +char *f; +{ /* the directory part of the pathname f becomes the new + prefix for pathnames, and we stack the current prefix */ + char *g; + prefixstack=strcons(prefix,prefixstack); + prefix += strlen(prefixbase+prefix)+1; + while(prefix+strlen(f)>=prefixlimit) /* check and fix overflow */ + prefixlimit += 1024, prefixbase=realloc(prefixbase,prefixlimit); + (void)strcpy(prefixbase+prefix,f); + g=rindex(prefixbase+prefix,'/'); + if(g)g[1]='\0'; + else prefixbase[prefix]='\0'; +} + +/* NOTES on how static pathname resolution is achieved: +(the specification is that pathnames must always be resolved relative to the +file in which they are encountered) +Definition -- the 'prefix' of a pathname is the initial segment up to but not +including the last occurrence of '/' (null if no '/' present). +Keep the wd constant during compilation. Have a global char* prefix, initially +null. +1) Whenever you read a relative pathname(), insert 'prefix' on the front of it. +2) On entering a new level of insert, stack old prefix and prefix becomes that + of new file name. Done by calling adjust_prefix(). +3) On quitting a level of insert, unstack old prefix. +*/ + +peekdig() +{ word ch = getc(s_in); + ungetc(ch,s_in); + return('0'<=ch&&ch<='9'); +} + +peekch() +{ word ch = getc(s_in); + ungetc(ch,s_in); + return(ch); +} + +openfile(n) /* returns 0 or 1 as indication of success - puts file on fileq + if successful */ +char *n; +{ FILE *f; + f= fopen(n,"r"); + if(f==NULL)return(0); + fileq= cons(strcons(f,NIL),fileq); + insertdepth++; + return(1); +} + +identifier(s) /* recognises reserved words */ +word s; /* flags looking for ul reserved words only */ +{ extern word lastid,initialising; + if(inbnf==1) + { /* only reserved nonterminals are `empty', `end', `error', `where' */ + if(is("empty ")||is("e_m_p_t_y"))return(EMPTYSY); else + if(is("end ")||is("e_n_d"))return(ENDSY); else + if(is("error ")||is("e_r_r_o_r"))return(ERRORSY); else + if(is("where ")||is("w_h_e_r_e"))return(WHERE); } + else + switch(dicp[0]) + { case 'a': if(is("abstype")||is("a_b_s_t_y_p_e")) + return(ABSTYPE); + break; + case 'd': if(is("div")||is("d_i_v")) + return(DIV); + break; + case 'F': if(is("False")) /* True, False alleged to be predefined, not + reserved (??) */ + { yylval = False; + return(CONST); } + break; + case 'i': if(is("if")||is("i_f")) + return(IF); + break; + case 'm': if(is("mod")||is("m_o_d")) + return(REM); + break; + case 'o': if(is("otherwise")||is("o_t_h_e_r_w_i_s_e")) + return(OTHERWISE); + break; + case 'r': if(is("readvals")||is("r_e_a_d_v_a_l_s")) + return(READVALSY); + break; + case 's': if(is("show")||is("s_h_o_w")) + return(SHOWSYM); + break; + case 'T': if(is("True")) + { yylval = True; + return(CONST); } + case 't': if(is("type")||is("t_y_p_e")) + return(TYPE); + break; + case 'w': if(is("where")||is("w_h_e_r_e")) + return(WHERE); + if(is("with")||is("w_i_t_h")) + return(WITH); + break; + } + if(s){ syntax("illegal use of underlining\n"); return('_'); } + yylval=name(); /* not a reserved word */ + if(commandmode&&lastid==0&&id_type(yylval)!=undef_t)lastid=yylval; + return(isconstructor(yylval)?CNAME:NAME); +} + +word disgusting=0; /* flag to turn off typecheck, temporary hack for jrc */ + +directive() /* these are of the form "%identifier" */ +{ extern word SYNERR,magic; + word holdcol=col-1,holdlin=line_no; + c = getch(); + if(c=='%'){ c=getch(); return(ENDIR); } + kollect(okulid); + switch(dicp[0]=='_'&&dicp[1]==''?dicp[2]:dicp[0]) + { case 'b': if(is("begin")||is("_^Hb_^He_^Hg_^Hi_^Hn")) + if(inlex) + return(LBEGIN); + if(is("bnf")||is("_^Hb_^Hn_^Hf")) + { setlmargin(); col=holdcol+4; + /* `indent' to right hand end of directive */ + return(BNF); } + break; + case 'e': if(is("export")||is("_e_x_p_o_r_t")) + { if(magic)syntax( + "%export directive not permitted in \"-exp\" script\n"); + return(EXPORT); } + break; + case 'f': if(is("free")||is("_f_r_e_e")) + { if(magic)syntax( + "%free directive not permitted in \"-exp\" script\n"); + return(FREE); } + break; + case 'i': if(is("include")||is("_i_n_c_l_u_d_e")) + { if(!SYNERR){ layout(); setlmargin(); } + /* does `indent' for grammar */ + if(!pathname()) + syntax("bad pathname after %include\n"); + else yylval=strcons(addextn(1,dicp), + fileinfo(get_fil(current_file),holdlin)), + /* (includee,hereinfo) */ + keep(dicp); + return(INCLUDE); } + if(is("insert")||is("_i_n_s_e_r_t")) + { char *f=pathname(); + if(!f)syntax("bad pathname after %insert\n"); else + if(insertdepth<12&&openfile(f)) + { adjust_prefix(f); + vergstack=cons(lverge,vergstack); + echostack=cons(echoing,echostack); + litstack=cons(literate,litstack); + linostack=strcons(line_no,linostack); + line_no=0; atnl=1; /* was line_no=1; */ + keep(dicp); + current_file = make_fil(f,fm_time(f),0,NIL); + files = append1(files,cons(current_file,NIL)); + tl[hd[fileq]] = current_file; + s_in = (FILE *)hd[hd[fileq]]; + literate= peekch()=='>'||litname(f); + col=lverge=holdcol; + if(echoing) + { putchar('\n'); + if(!literate) + if(litmain)putchar('>'),spaces(holdcol); + else spaces(holdcol); } + c = getch(); } /* used to precede previous cmd when echo + was delayed by one char, see getch() */ + else { word toomany=(insertdepth>=12); + printf("%s%%insert error - cannot open \"%s\"\n", + echoing?"\n":"",f); + keep(dicp); + if(toomany)printf( + "too many nested %%insert directives (limit=%d)\n", + insertdepth); + else + files = append1(files,cons(make_fil(f,0,0,NIL),NIL)); + /* line above for benefit of `oldfiles' */ + acterror(); } + return(yylex()); } + break; + case 'l': if(is("lex")||is("_^Hl_^He_^Hx")) + { if(inlex)syntax("nested %lex not permitted\n"); + /* due to use of global vars inlex, lexdefs */ + return(LEX); } + if(is("list")||is("_l_i_s_t")) + { echoing=verbosity; return(yylex()); } + break; + case 'n': if(is("nolist")||is("_n_o_l_i_s_t")) + { echoing=0; return(yylex()); } + break; + } + if(echoing)putchar('\n'); + printf("syntax error: unknown directive \"%%%s\"\n",dicp), + acterror(); + return(END); +} + +okid(ch) +word ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch=='\''); } + +okulid(ch) +word ch; +{ return('a'<=ch&&ch<='z'||'A'<=ch&&ch<='Z'||'0'<=ch&&ch<='9' + ||ch=='_'||ch==''||ch=='\''); } + +kollect(f) +/* note top of dictionary used as work space to collect current token */ +word (*f)(); +{ dicq= dicp; + while((*f)(c)){ *dicq++ = c; c= getch(); } + *dicq++ = '\0'; + ovflocheck; +} + +char *keep(p) /* call this to retain volatile string for later use */ +char *p; +{ if(p==dicp)dicp= dicq; + else (void)strcpy(dicp,p), + p=dicp, + dicp=dicq=dicp+strlen(dicp)+1, + dic_check(); + return(p); +} + +dic_check() /* called from REDUCE */ +{ ovflocheck; } + +numeral() +{ word nflag=1; + dicq= dicp; + while(isdigit(c)) + *dicq++ = c, c=getch(); + if(c=='.'&&peekdig()) + { *dicq++ = c, c=getch(); nflag=0; + while(isdigit(c)) + *dicq++ = c, c=getch(); } + if(c=='e') + { word np=0; + *dicq++ = c, c=getch(); nflag=0; + if(c=='+')c=getch(); else /* ignore + before exponent */ + if(c=='-')*dicq++ = c, c=getch(); + if(!isdigit(c)) /* e must be followed by some digits */ + syntax("badly formed floating point number\n"); + while(c=='0') + *dicq++ = c, c=getch(); + while(isdigit(c)) + np++, *dicq++ = c, c=getch(); + if(!nflag&&np>3) /* scanf falls over with silly exponents */ + { syntax("floating point number out of range\n"); + return; } + } + ovflocheck; + if(nflag) /* `.' or `e' makes fractional */ + *dicq = '\0', + yylval= bigscan(dicp); else + { double r=0.0; + if(dicq-dicp>60) /* this allows 59 chars */ + /* scanf crashes, on VAX, gives wrong answers, on ORION 1/05 */ + { syntax("illegal floating point constant (too many digits)\n"); + return; } + errno=0; + *dicq = '\n'; + sscanf(dicp,"%lf",&r); + if(errno)fpe_error(); else + yylval= sto_dbl((double)r); } +} + +hexnumeral() /* added 21.11.2013 */ +{ extern word errno; + word nflag=1; + dicq= dicp; + *dicq++ = c, c=getch(); /* 0 */ + *dicq++ = c, c=getch(); /* x */ + if(!isxdigit(c)&&c!='.')syntax("malformed hex number\n"); + while(c=='0'&&isxdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */ + while(isxdigit(c)) + *dicq++ = c, c=getch(); + ovflocheck; + if(c=='.'||tolower(c)=='p') /* hex float, added 20.11.19 */ + { double d; + if(c=='.') + { *dicq++ = c, c=getch(); + while(isxdigit(c)) + *dicq++ = c, c=getch(); } + if(c=='p') + { *dicq++ = c, c=getch(); + if(c=='+'||c=='-')*dicq++ = c, c=getch(); + if(!isdigit(c))syntax("malformed hex float\n"); + while(isdigit(c)) + *dicq++ = c, c=getch(); } + ovflocheck; + *dicq='\0'; + if(dicq-dicp>60||sscanf(dicp,"%lf",&d)!=1) + syntax("malformed hex float\n"); + else yylval= sto_dbl(d); + return; } + *dicq = '\0'; + yylval= bigxscan(dicp+2,dicq); +} + +octnumeral() /* added 21.11.2013 */ +{ extern word errno; + word nflag=1; + dicq= dicp; + if(!isdigit(c))syntax("malformed octal number\n"); + while(c=='0'&&isdigit(peekch()))c=getch(); /* skip zeros before first nonzero digit */ + while(isdigit(c)&&c<='7') + *dicq++ = c, c=getch(); + if(isdigit(c))syntax("illegal digit in octal number\n"); + ovflocheck; + *dicq = '\0'; + yylval= bigoscan(dicp,dicq); +} + +word namebucket[128]; /* each namebucket has a list terminated by 0, not NIL */ + +hash(s) /* returns a value in {0..127} */ +char *s; +{ word h = *s; + if(h)while(*++s)h ^= *s; /* guard necessary to deal with s empty */ + return(h&127); +} + +isconstrname(s) +char *s; +{ if(s[0]=='$')s++; + return isupper(*s); /* formerly !islower */ +} + +getfname(x) +/* nonterminals have an added ' ', getfname returns the corresponding + function name */ +word x; +{ char *p = get_id(x); + dicq= dicp; + while(*dicq++ = *p++); + if(dicq-dicp<3)fprintf(stderr,"impossible event in getfname\n"),exit(1); + dicq[-2] = '\0'; /* overwrite last char */ + ovflocheck; + return(name()); +} + +isnonterminal(x) +word x; +{ char *n; + if(tag[x]!=ID)return(0); + n = get_id(x); + return(n[strlen(n)-1]==' '); +} + +name() +{ word q,h; + q= namebucket[h=hash(dicp)]; + while(q&&!is(get_id(hd[q])))q= tl[q]; + if(q==0) + { q = sto_id(dicp); + namebucket[h] = cons(q,namebucket[h]); + keep(dicp); } + else q= hd[q]; + return(q); } +/* note - keeping buckets sorted didn't seem to help (if anything slightly + slower) probably because ordering only relevant if name not present, and + outweighed by increased complexity of loop */ + +static word inprelude=1; + +make_id(n) /* used in mira_setup(), primdef(), predef(), all in steer.c */ +char *n; +{ word x,h; + h=hash(n); + x = sto_id(inprelude?keep(n):n); + namebucket[h] = cons(x,namebucket[h]); + return(x); } + +findid(n) /* like name() but returns NIL rather than create new id */ +char *n; +{ word q; + q= namebucket[hash(n)]; + while(q&&!strcmp(n,get_id(hd[q]))==0)q= tl[q]; + return(q?hd[q]:NIL); } + +word *pnvec=0,nextpn,pn_lim=200; /* private name vector */ + +reset_pns() /* (re)initialise private name space */ +{ nextpn=0; + if(!pnvec) + { pnvec=(word *)malloc(pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } +} + +make_pn(val) /* create new private name with value val */ +word val; +{ if(nextpn==pn_lim) + { pn_lim+=400; + pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } + pnvec[nextpn]=strcons(nextpn,val); + return(pnvec[nextpn++]); +} + +sto_pn(n) /* return n'th private name, extending pnvec if necessary */ +word n; +{ if(n>=pn_lim) + { while(pn_lim<=n)pn_lim+=400; + pnvec=(word *)realloc(pnvec,pn_lim*sizeof(word)); + if(pnvec==NULL)mallocfail("pnvec"); } + while(nextpn<=n) /* NB allocates all missing names upto and including nth*/ + pnvec[nextpn]=strcons(nextpn,UNDEF),nextpn++; + return(pnvec[n]); +} + +mkprivate(x) /* disguise identifiers prior to removal from environment */ +word x; /* used in setting up prelude - see main() in steer.c */ +{ while(x!=NIL) + { char *s = get_id(hd[x]); + get_id(hd[x])[0] += 128; /* hack to make private internal name */ + x = tl[x]; } /* NB - doesn't change hashbucket */ + inprelude=0; +} + +word sl=100; + +string() +{ word p; + word ch,badch=0; + c = getch(); + ch= getlitch(); + p= yylval= cons(NIL,NIL); + while(ch!=EOF&&rawch!='\"'&&rawch!='\n') + if(ch==-7) ch=getlitch(); else /* skip \& */ + if(ch<0){ badch=ch; break; } + else { p= tl[p]= cons(ch,NIL); + ch= getlitch(); } + yylval= tl[yylval]; + if(badch)errclass(badch,1); + if(rawch=='\n') + syntax("non-escaped newline encountered inside string quotes\n"); else + if(ch==EOF) + { if(echoing)putchar('\n'); + printf("syntax error: script ends inside unclosed string quotes - \n"); + printf(" \""); + while(yylval!=NIL&& sl-- ) + { putchar(hd[yylval]); + yylval= tl[yylval]; } + printf("...\"\n"); + acterror(); } +} + +charclass() +{ word p; + word ch,badch=0,anti=0; + c = getch(); + if(c=='^')anti=1,c=getch(); + ch= getlitch(); + p= yylval= cons(NIL,NIL); + while(ch!=EOF&&rawch!='`'&&rawch!='\n') + if(ch==-7)ch=getlitch(); else /* skip \& */ + if(ch<0){ badch=ch; break; } + else { if(rawch=='-'&&hd[p]!=NIL&&hd[p]!=DOTDOT) + ch=DOTDOT; /* non-initial, non-escaped '-' */ + p= tl[p]= cons(ch,NIL); + ch= getlitch(); } + if(hd[p]==DOTDOT)hd[p]='-'; /* naturalise a trailing '-' */ + for(p=yylval;tl[p]!=NIL;p=tl[p]) /* move each DOTDOT to front of range */ + if(hd[tl[p]]==DOTDOT) + { hd[tl[p]]=hd[p],hd[p]=DOTDOT; + if(hd[tl[p]]>=hd[tl[tl[p]]]) + syntax("illegal use of '-' in [charclass]\n"); + } + yylval= tl[yylval]; + if(badch)errclass(badch,2); + if(rawch=='\n') + syntax("non-escaped newline encountered in char class\n"); else + if(ch==EOF) + { if(echoing)putchar('\n'); + printf( + "syntax error: script ends inside unclosed char class brackets - \n"); + printf(" ["); + while(yylval!=NIL&& sl-- ) + { putchar(hd[yylval]); + yylval= tl[yylval]; } + printf("...]\n"); + acterror(); } + return(anti); +} + +reset_lex() /* called after an error */ +{ extern word errs,errline; + extern char *current_script; + /*printf("reset_lex()\n"); /* DEBUG */ + if(!commandmode) + { if(!errs)errs=fileinfo(get_fil(current_file),line_no); + /* convention, if errs set contains location of error, otherwise pick up + from current_file and line_no */ + if(tl[errs]==0&&(char *)hd[errs]==current_script) + /* at end of file, so line_no has been reset to 0 */ + printf("error occurs at end of "); + else printf("error found near line %d of ",tl[errs]); + printf("%sfile \"%s\"\ncompilation abandoned\n", + (char *)hd[errs]==current_script?"":"%insert ", + (char *)hd[errs]); + if((char *)hd[errs]==current_script) + errline=tl[errs]==0?lastline:tl[errs],errs=0; + else { while(tl[linostack]!=NIL)linostack=tl[linostack]; + errline=hd[linostack]; } + /* tells editor where to find error - errline contains location of 1st + error in main script, errs is hereinfo of upto one error in %insert + script (each is 0 if not set) - some errors can set both */ + } + reset_state(); +} + +reset_state() /* reset all global variables used by compiler */ +{ extern word TABSTRS,SGC,newtyps,algshfns,showchain,inexplist,sreds, + rv_script,idsused; + /* printf("reset_state()\n"); /* DEBUG */ + if(commandmode) + while(c!='\n'&&c!=EOF)c=getc(s_in); /* no echo */ + while(fileq!=NIL)fclose((FILE *)hd[hd[fileq]]),fileq=tl[fileq]; + insertdepth= -1; + s_in=stdin; + echostack=idsused=prefixstack=litstack=linostack=vergstack + =margstack=NIL; + prefix=0; prefixbase[0]='\0'; + echoing=verbosity&listing; + brct=inbnf=sreds=inlex=inexplist=commandmode=lverge=col=lmargin=0; + atnl=1; + rv_script=0; + algshfns=newtyps=showchain=SGC=TABSTRS=NIL; + c=' '; + line_no=0; + litmain=literate=0; + /* printf("exit reset_state()\n"); /* DEBUG */ +} + +/* end of MIRANDA LEX ANALYSER */ + -- cgit v1.2.1