path: root/new/lex.c

/* 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 <errno.h>

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,<ptr to element of 'files'>),...)*/
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 <pwd.h>
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 <tok> */
         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 <quotes> */
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)&&count<N)
                     hold[count++]=ch,ch=getch();
                /* read upto N hex digits */
                hold[count] = '\0';
                sscanf(hold,"%x",&value);
                c = ch;
                return value>UMAX?-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)&&count<N)
               /* read upto N digits */
               { n = 10*n+ch-'0';
                 count++;
                 ch = getch(); }
               c = ch;
               return /* n>UMAX?-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<lmargin) */
{ margstack= cons(lmargin,margstack);
  if(lmargin<col)lmargin= col; } /* inner scope region cannot "protrude" */

unsetlmargin()
{ if(margstack==NIL)return;  /* in case called after `syntax("..")' */
  lmargin= hd[margstack];
  margstack= tl[margstack]; }

word okid();
word okulid();
word PREL=1;

#define isletter(c) ('a'<=c&&c<='z'||'A'<=c&&c<='Z') 

errclass(word val, word string) 
/* diagnose error in charclass, string or char const */
{ char *s = string==2?"char class":string?"string":"char const";
  if(val==-2)printf("\\x with no xdigits in %s\n",s); else
  if(val==-3)printf("\\hexadecimal escape out of range in %s\n",s); else
  if(val==-4)printf("\\decimal escape out of range in %s\n",s); else
  if(val==-5)printf("unrecognised character in %s"
                      "(UTF8 error)\n",s); else
  if(val==-6)printf("unrecognised escape \\%c in %s\n",errch,s); else
  if(val==-7)printf("illegal use of \\& in char const\n"); else
  printf("unknown error in %s\n",s);
  acterror(); }

yylex()         /* called by YACC to get the next symbol */
{ extern word SYNERR,exportfiles,inexplist,sreds;
  /* SYNERR flags context sensitive syntax error detected in actions */
  if(SYNERR)return(END); /* tell YACC to go home */
  layout();
  if(c=='\n') /* can only occur in command mode */
/*  if(magic){ commandmode=0; /* expression just read, now script */
/*	       line_no=2;
/*	       return(c); } else /* no longer relevant 26.11.2019 */
    return(END);
  if(col<lmargin)
  if(c=='='&&(margstack==NIL||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("<end of insert>"); }
    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 */