#
#	merr.icn 1.1, an error message generator program.
#
#	Clinton Jeffery, jeffery@cs.uidaho.edu
#
#	11/7/2003
#
#	Maintains the mapping from parse states to error messages.
#	See http://unicon.sourceforge.net/merr/
#
#	To do: add a command line option for an alternative message format.
#

global C, att, bison, byacc, make, compile, ofile, target, yyfn, yyln, yytxt
global calloc

procedure main(argv)

   if *argv=0 then
      stop("usage: merr [-yYB] [-F filename] [-s make] [-o msgfile] compiler [target]")
   ofile := "yyerror.icn"
   yamfile := "meta.err"
   yyfn := "yyfilename"
   yyln := "yylineno"
   yytxt := "yytext"
   calloc := "calloc"
   i := 1
   while i<= *argv do {
	case argv[i] of {
	    "-Y": { C := att := "yy_state" }
	    "-B": { C := bison := "yystate" }
	    "-y": { C := byacc := 1 }
	    "-s": { i +:= 1; make := argv[i] }
	    "-C": { i +:= 1; calloc := argv[i] }
	    "--F": { i +:= 1; yyfn := &null }
	    "-F": { i +:= 1; yyfn := argv[i] }
	    "-L": { i +:= 1; yyln := argv[i] }
	    "-T": { i +:= 1; yytxt := argv[i] }
	    "-o": { i +:= 1; ofile := argv[i] }
	    default: {
		if /compile := argv[i] then
		    target := (if \C then "m_err.c" else "m_err.icn")
		else
		    target := argv[i]
	    }
	}
	i+:= 1
    }
    /compile := "./unicon"
    /make := "make " || compile
    if \C & ofile=="yyerror.icn" then ofile := "yyerror.c"
    gen()

    # now the fun begins: write error-inducing source codes, run them,
    # and read the stack states from their errors.

    t := table()
    fin := open(yamfile) | stop("no ", yamfile)
    while line := read(fin) do {
        prog := []
	while not (i := find(":::",line)) do {
	    put(prog,line)
	    line := read(fin) | break break
	}
	if i>1 then put(prog,line[1:i])
	msg := line[i+3:0]
	msg ?:= (tab(many(' \t')), tab(0))
	write(msg)
	generr(t, prog, msg)
    }
    gen(t)
end

procedure gen(t)

    f := open(ofile, "w") | stop("can't write ", image(ofile))
    if \C then {
	if /byacc then {
	    if find("/", ofile) then {
		every i := find("/", ofile)
		f2 := open(ofile[1:i+1] || "yyerror.h", "w")
	        }
	    else
		f2 := open("yyerror.h", "w")
	    write(f2, "extern int _yyerror(char *, int);")
	    write(f2, "#define yyerror(s) _yyerror(s, ", \att | bison, ")")
	    close(f2)
	    }
	maxstate := -1
	every maxstate <:= key(\t)
	write(f,"#include <stdio.h>\n")
	write(f,"int yyerror_isinitialized, yymaxstate = ",maxstate,";")
	write(f,"struct errtable {\n",
	        "   int i;\n",
	        "   union {\n",
	        "      char *msg;\n",
	        "      struct errtable *p;\n",
	        "      } u;\n",
	        "   } errtab[", if maxstate<0 then 1 else maxstate+1, "];")

	write(f, "void yyerror_init()\n{")

	every k := key(\t) do {
	    write(f, "   errtab[",k,"].i = ", *t[k], ";")
	    if *t[k] > 1 then {
		write(f, "   errtab[",k,"].u.p = (struct errtable *)",calloc,"(1,",*t[k]+1," * sizeof(struct errtable));")
		write(f, "   errtab[",k,"].u.p[0].u.msg = ", image(t[k,10000000000]),";")
		j := 1
		every k2 := key(t[k]) do {
		    write(f, "   errtab[", k, "].u.p[", j, "].i = ", k2, ";")
		    write(f, "   errtab[", k, "].u.p[", j, "].u.msg = ", image(t[k,k2]), ";")
		    j +:= 1
		}
	    }
	    else
		write(f,"   errtab[",k,"].u.msg = ",image(t[k,10000000000]),";")
	}
      write(f, "}\n")

      write(f,"int __merr_errors;\n",
	      "extern int yychar, ",yyln,";\n")
      if \yyfn=="yyfilename" then write(f,"extern char *yyfilename;\n")
# Berkeley and/or AT&T probably need extern char yytext[]; need to check
      if yytxt=="yytext" then write(f,"extern char *yytext;\n")

      if \byacc then
          write(f, "extern short *yyssp;\n\n",
		   "int yyerror(char *s)\n{\n   int state = *yyssp;")
      else
          write(f, "int _yyerror(char *s, int state)\n{")
      write(f, "   int i;\n",
	       "   char sbuf[128];")

      write(f, "   if (! yyerror_isinitialized++) yyerror_init();\n",
               "   if (strstr(s, \"stack\")) return 0;")

      write(f, "   if (__merr_errors++ > 10) {\n",
	       "      fprintf(stderr, \"too many errors, aborting\");\n",
	       "      exit(__merr_errors); }")

      write(f, "   if(",\yyfn,") fprintf(stderr, \"%s:\", ",\yyfn,");")
      write(f, "   if ((!strcmp(s, \"syntax error\") || !strcmp(s,\"parse error\"))&&")
      write(f,"         (state>=0 && state<=yymaxstate)) {")
      write(f,"       if (errtab[state].i==1)")
      write(f, "         s = errtab[state].u.msg;")
      write(f,"       else {")
      write(f,"          for(i=1;i<=errtab[state].i;i++)")
      write(f,"             if(yychar == errtab[state].u.p[i].i) {")
      write(f,"                s=errtab[state].u.p[i].u.msg;break;}")
      write(f,"          if(i>errtab[state].i && errtab[state].i > 0)")
      write(f,"             s=errtab[state].u.p[0].u.msg;")
      write(f,"          }")
      write(f,"       }")

      write(f, "   if (!strcmp(s, \"syntax error\") || !strcmp(s,\"parse error\")){")
      write(f, "      sprintf(sbuf,\"%s (%d;%d)\", s, state, yychar);")
      write(f, "      s=sbuf;\n      }")
      write(f, "   fprintf(stderr, \"%d: # \\\"%s\\\": %s\\n\", ",yyln,", ",yytxt,", s);")
      write(f, "   return 0;")
      write(f, "}")
      }
   else {
      write(f,"procedure yyerror(s)\n",
	      "static t, __merr_errors\n",
	      "initial {\n",
	      "   t := table(table(\"syntax error\"))")
      every k := key(\t) do {
	  if *t[k] > 1 then {
	      write(f, "   t[",k,"] := table(",image(t[k,10000000000]),")")
	      every k2 := key(t[k]) do {
		  write(f, "   t[", k, ",", k2, "] := ", image(t[k,k2]))
	      }
	  }
	  else
	      write(f,"   t[",k,"] := table(",image(t[k,10000000000]),")")
      }
      write(f, "   __merr_errors := 0")
      write(f, "   }\n")

      write(f, "   if __merr_errors = 0 then write(&errout)")
      write(f, "   else if map(s)== \"stack underflow. aborting...\" then return")
      write(f, "   __merr_errors +:= 1")
      write(f, "   if __merr_errors > 10 then")
      write(f, "      stop(\"too many errors, aborting\")")
      write(f, "   writes(&errout, \\fName, \":\")")
      write(f, "   if s == \"syntax error\" then")
      write(f, "      s := t[statestk[1], yychar]")
      write(f, "   if s == \"syntax error\" then {")
      write(f, "      s ||:= \" (\" || statestk[1] ||\";\"|| yychar || \")\"")
      write(f, "      }")
      write(f, "   write(&errout, ",yyln,", \": # \\\"\", yytext, \"\\\": \", s)")
      write(f, "   return")
      write(f, "end")
}
close(f)

system(make)

end

global efile

procedure generr(t, prog, msg)

    efile := \target | "err.icn"
    f := open(efile,"w")
    every write(f, !prog) 
    close(f)
    s := compile ||" "||efile||" 2> err.out"
    system("cat m_err.c")
    system("cat err.out")
    system(s)

    f := open("err.out")
    while ((line := read(f)) &
	   (not (line ? (tab(find("(")+1), tab(many(&digits)),
			=";", tab(many(&digits)), =")"))))

    if (not (\line ? (tab(find("(")+1), tab(many(&digits)),
			=";", tab(many(&digits)), =")"))) then
	stop("no error in ",efile)
    line2 := line
    while line ?:= (tab(find(":")+1) & tab(0))
    if *trim(line) = 0 then stop("bad line ", image(line))
    line ? {
	tab(find("(")+1) | { unknownstate(line2); fail }
	state := integer(tab(many(&digits))) | {
	    unknownstate(line2); fail }
	=";"
	token := integer(tab(many(&digits))) | {
	    unknownstate(line2); fail }
	=")"
    }
    close(f)

    if /state | /token then { write(msg, "not entered into table"); fail }
    if not member(t, state) then t[state] := table(msg)
    t[state,token] := msg
end

procedure unknownstate(s)
    write("unknown state in ", image(s))
    system("cat " || efile)
    system("cat err.out")
end