File ‹tools/mlyacc/src/yacc.ML›
type int = Int.int
functor ParseGenFun(structure ParseGenParser : PARSE_GEN_PARSER
structure MakeTable : MAKE_LR_TABLE
structure Verbose : VERBOSE
structure PrintStruct : PRINT_STRUCT
sharing MakeTable.LrTable = PrintStruct.LrTable
sharing MakeTable.Errs = Verbose.Errs
structure Absyn : ABSYN
) : PARSE_GEN =
struct
open Array List
infix 9 sub
structure Grammar = MakeTable.Grammar
structure Header = ParseGenParser.Header
open Header Grammar
val lineLength: int = 70
datatype names = NAMES
of {miscStruct : string,
tableStruct : string,
tokenStruct : string,
actionsStruct : string,
valueStruct: string,
ecStruct : string,
arg: string,
tokenSig : string,
miscSig :string,
dataStruct:string,
dataSig:string
}
val DEBUG = true
exception Semantic
datatype values = VALS
of {say : string -> unit,
saydot : string -> unit,
sayln : string -> unit,
pureActions: bool,
pos_type : string,
arg_type : string,
ntvoid : string,
termvoid : string,
start : Grammar.nonterm,
hasType : Grammar.symbol -> bool,
termToString : Grammar.term -> string,
symbolToString : Grammar.symbol -> string,
term : (Header.symbol * ty option) list,
nonterm : (Header.symbol * ty option) list,
terms : Grammar.term list,
tokenInfo : string option}
structure SymbolHash = Hash(type elem = string
val gt = (op >) : string*string -> bool)
structure TermTable = Table(type key = Grammar.term
val gt = fn (T i,T j) => i > j)
structure SymbolTable = Table(
type key = Grammar.symbol
val gt = fn (TERM(T i),TERM(T j)) => i>j
| (NONTERM(NT i),NONTERM(NT j)) => i>j
| (NONTERM _,TERM _) => true
| (TERM _,NONTERM _) => false)
val printTypes = fn (VALS {say,sayln,term,nonterm,symbolToString,pos_type,
arg_type,
termvoid,ntvoid,saydot,hasType,start,
pureActions,...},
NAMES {valueStruct,...},symbolType) =>
let val prConstr = fn (symbol,SOME s) =>
say (" | " ^ (symbolName symbol) ^ " of " ^
(if pureActions then "" else "unit -> ") ^
" (" ^ tyName s ^ ")"
)
| _ => ()
in sayln "local open Header in";
sayln ("type pos = " ^ pos_type);
sayln ("type arg = " ^ arg_type);
sayln ("structure " ^ valueStruct ^ " = ");
sayln "struct";
say ("datatype svalue = " ^ termvoid ^ " | " ^ ntvoid ^ " of" ^
(if pureActions then "" else " unit -> ") ^ " unit");
app prConstr term;
app prConstr nonterm;
sayln "\nend";
sayln ("type svalue = " ^ valueStruct ^ ".svalue");
say "type result = ";
case symbolType (NONTERM start)
of NONE => sayln "unit"
| SOME t => (say (tyName t); sayln "");
sayln "end"
end
val printTokenStruct =
fn (VALS {say, sayln, termToString, hasType,termvoid,terms,
pureActions,tokenInfo,...},
NAMES {miscStruct,tableStruct,valueStruct,
tokenStruct,tokenSig,dataStruct,...}) =>
(sayln ("structure " ^ tokenStruct ^ " : " ^ tokenSig ^ " =");
sayln "struct";
(case tokenInfo of
NONE => ()
| _ => sayln ("open "^dataStruct^".Header"));
sayln ("type svalue = " ^ dataStruct ^ ".svalue");
sayln "type ('a,'b) token = ('a,'b) Token.token";
let val f = fn term as T i =>
(say "fun "; say (termToString term);
say " (";
if (hasType (TERM term)) then say "i," else ();
say "p1,p2) = Token.TOKEN (";
say (dataStruct ^ "." ^ tableStruct ^ ".T ");
say (Int.toString i);
say ",(";
say (dataStruct ^ "." ^ valueStruct ^ ".");
if (hasType (TERM term)) then
(say (termToString term);
if pureActions then say " i"
else say " (fn () => i)")
else say termvoid;
say ",";
sayln "p1,p2))")
in app f terms
end;
sayln "end")
val printSigs = fn (VALS {term,tokenInfo,...},
NAMES {tokenSig,tokenStruct,miscSig,
dataStruct, dataSig, ...},
say) =>
say ("signature " ^ tokenSig ^ " =\nsig\n"^
(case tokenInfo of NONE => "" | SOME s => (s^"\n"))^
"type ('a,'b) token\ntype svalue\n" ^
(List.foldr (fn ((s,ty),r) => String.concat [
"val ", symbolName s,
(case ty
of NONE => ": "
| SOME l => ": (" ^ (tyName l) ^ ") * "),
" 'a * 'a -> (svalue,'a) token\n", r]) "" term) ^
"end\nsignature " ^ miscSig ^
"=\nsig\nstructure Tokens : " ^ tokenSig ^
"\nstructure " ^ dataStruct ^ ":" ^ dataSig ^
"\nsharing type " ^ dataStruct ^
".Token.token = Tokens.token\nsharing type " ^
dataStruct ^ ".svalue = Tokens.svalue\nend\n")
val printEC = fn (keyword : term list,
preferred_change : (term list * term list) list,
noshift : term list,
value : (term * string) list,
VALS {termToString, say,sayln,terms,saydot,hasType,
termvoid,pureActions,...},
NAMES {ecStruct,tableStruct,valueStruct,...}) =>
let
val sayterm = fn (T i) => (say "(T "; say (Int.toString i); say ")")
val printBoolCase = fn ( l : term list) =>
(say "fn ";
app (fn t => (sayterm t; say " => true"; say " | ")) l;
sayln "_ => false")
val printTermList = fn (l : term list) =>
(app (fn t => (sayterm t; say " :: ")) l; sayln "nil")
fun printChange () =
(sayln "val preferred_change = ";
app (fn (d,i) =>
(say"("; printTermList d; say ","; printTermList i;
sayln ")::"
)
) preferred_change;
sayln "nil")
val printErrValues = fn (l : (term * string) list) =>
(sayln "local open Header in";
sayln "val errtermvalue=";
say "fn ";
app (fn (t,s) =>
(sayterm t; say " => ";
saydot valueStruct; say (termToString t);
say "(";
if pureActions then () else say "fn () => ";
say "("; say s; say "))";
sayln " | "
)
) l;
say "_ => ";
say (valueStruct ^ ".");
sayln termvoid; sayln "end")
val printNames = fn () =>
let val f = fn term => (
sayterm term; say " => ";
sayln (String.concat["\"", termToString term, "\""]);
say " | ")
in (sayln "val showTerminal =";
say "fn ";
app f terms;
sayln "_ => \"bogus-term\"")
end
val ecTerms =
List.foldr (fn (t,r) =>
if hasType (TERM t) orelse exists (fn (a,_)=>a=t) value
then r
else t::r)
[] terms
in say "structure ";
say ecStruct;
sayln "=";
sayln "struct";
say "open ";
sayln tableStruct;
sayln "val is_keyword =";
printBoolCase keyword;
printChange();
sayln "val noShift = ";
printBoolCase noshift;
printNames ();
printErrValues value;
say "val terms = ";
printTermList ecTerms;
sayln "end"
end
val printAction = fn (rules,
VALS {hasType,say,sayln,termvoid,ntvoid,
symbolToString,saydot,start,pureActions,...},
NAMES {actionsStruct,valueStruct,tableStruct,arg,...}) =>
let val printAbsynRule = Absyn.printRule(say,sayln)
val is_nonterm = fn (NONTERM i) => true | _ => false
val numberRhs = fn r =>
List.foldl (fn (e,(r,table)) =>
let val num = case SymbolTable.find(e,table)
of SOME i => i
| NONE => 1
in ((e,num,hasType e orelse is_nonterm e)::r,
SymbolTable.insert((e,num+1),table))
end) (nil,SymbolTable.empty) r
val saySym = symbolToString
val printCase = fn (i:int, r as {lhs=lhs as (NT lhsNum),prec,
rhs,code,rulenum}) =>
let open Absyn
val mkToken = fn (sym,num : int,typed) =>
let val symString = symbolToString sym
val symNum = symString ^ (Int.toString num)
in PTUPLE[WILD,
PTUPLE[if not (hasType sym) then
(if is_nonterm sym then
PAPP(valueStruct^"."^ntvoid,
PVAR symNum)
else WILD)
else
PAPP(valueStruct^"."^symString,
if num=1 andalso pureActions
then AS(PVAR symNum,PVAR symString)
else PVAR symNum),
if num=1 then AS(PVAR (symString^"left"),
PVAR(symNum^"left"))
else PVAR(symNum^"left"),
if num=1 then AS(PVAR(symString^"right"),
PVAR(symNum^"right"))
else PVAR(symNum^"right")]]
end
val numberedRhs = #1 (numberRhs rhs)
val pat = PTUPLE[PINT i,PLIST(map mkToken numberedRhs @
[PVAR "rest671"])]
val argsWithTypes =
List.foldr (fn ((_,_,false),r) => r
| (s as (_,_,true),r) => s::r) nil numberedRhs
val defaultPos = EVAR "defaultPos"
val resultexp = EVAR "result"
val resultpat = PVAR "result"
val code = CODE code
val rest = EVAR "rest671"
val body =
LET([VB(resultpat,
EAPP(EVAR(valueStruct^"."^
(if hasType (NONTERM lhs)
then saySym(NONTERM lhs)
else ntvoid)),
if pureActions then code
else if argsWithTypes=nil then FN(WILD,code)
else
FN(WILD,
let val body =
LET(map (fn (sym,num:int,_) =>
let val symString = symbolToString sym
val symNum = symString ^ Int.toString num
in VB(if num=1 then
AS(PVAR symString,PVAR symNum)
else PVAR symNum,
EAPP(EVAR symNum,UNIT))
end) (rev argsWithTypes),
code)
in if hasType (NONTERM lhs) then
body else SEQ(body,UNIT)
end)))],
ETUPLE[EAPP(EVAR(tableStruct^".NT"),EINT(lhsNum)),
case rhs
of nil => ETUPLE[resultexp,defaultPos,defaultPos]
| r =>let val (rsym,rnum,_) = hd(numberedRhs)
val (lsym,lnum,_) = hd(rev numberedRhs)
in ETUPLE[resultexp,
EVAR (symbolToString lsym ^
Int.toString lnum ^ "left"),
EVAR (symbolToString rsym ^
Int.toString rnum ^ "right")]
end,
rest])
in printAbsynRule (RULE(pat,body))
end
val prRules = fn () =>
(sayln "fn (i392:int,defaultPos,stack,";
say " ("; say arg; sayln "):arg) =>";
sayln "case (i392,stack)";
say "of ";
app (fn (rule as {rulenum,...}) =>
(printCase(rulenum,rule); say "| ")) rules;
sayln "_ => raise (mlyAction i392)")
in say "structure ";
say actionsStruct;
sayln " =";
sayln "struct ";
sayln "type int = Int.int";
sayln "exception mlyAction of int";
sayln "local open Header in";
sayln "val actions = ";
prRules();
sayln "end";
say "val void = ";
saydot valueStruct;
sayln termvoid;
say "val extract = ";
say "fn a => (fn ";
saydot valueStruct;
if hasType (NONTERM start)
then say (symbolToString (NONTERM start))
else say "ntVOID";
sayln " x => x";
sayln "| _ => let exception ParseInternal";
say "\tin raise ParseInternal end) a ";
sayln (if pureActions then "" else "()");
sayln "end"
end
val make_parser = fn ((header,
DECL {eop,change,keyword,nonterm,prec,
term, control,value} : declData,
rules : rule list),spec,error : pos -> string -> unit,
wasError : unit -> bool) =>
let
val verbose = List.exists (fn VERBOSE=>true | _ => false) control
val defaultReductions = not (List.exists (fn NODEFAULT=>true | _ => false) control)
val pos_type =
let fun f nil = NONE
| f ((POS s)::r) = SOME s
| f (_::r) = f r
in f control
end
val start =
let fun f nil = NONE
| f ((START_SYM s)::r) = SOME s
| f (_::r) = f r
in f control
end
val name =
let fun f nil = NONE
| f ((PARSER_NAME s)::r) = SOME s
| f (_::r) = f r
in f control
end
val header_decl =
let fun f nil = NONE
| f ((FUNCTOR s)::r) = SOME s
| f (_::r) = f r
in f control
end
val token_sig_info_decl =
let fun f nil = NONE
| f ((TOKEN_SIG_INFO s)::_) = SOME s
| f (_::r) = f r
in f control
end
val arg_decl =
let fun f nil = ("()","unit")
| f ((PARSE_ARG s)::r) = s
| f (_::r) = f r
in f control
end
val noshift =
let fun f nil = nil
| f ((NSHIFT s)::r) = s
| f (_::r) = f r
in f control
end
val pureActions =
let fun f nil = false
| f ((PURE)::r) = true
| f (_::r) = f r
in f control
end
val term =
case term
of NONE => (error 1 "missing %term definition"; nil)
| SOME l => l
val nonterm =
case nonterm
of NONE => (error 1 "missing %nonterm definition"; nil)
| SOME l => l
val pos_type =
case pos_type
of NONE => (error 1 "missing %pos definition"; "")
| SOME l => l
val termHash =
List.foldr (fn ((symbol,_),table) =>
let val name = symbolName symbol
in if SymbolHash.exists(name,table) then
(error (symbolPos symbol)
("duplicate definition of " ^ name ^ " in %term");
table)
else SymbolHash.add(name,table)
end) SymbolHash.empty term
val isTerm = fn name => SymbolHash.exists(name,termHash)
val symbolHash =
List.foldr (fn ((symbol,_),table) =>
let val name = symbolName symbol
in if SymbolHash.exists(name,table) then
(error (symbolPos symbol)
(if isTerm name then
name ^ " is defined as a terminal and a nonterminal"
else
"duplicate definition of " ^ name ^ " in %nonterm");
table)
else SymbolHash.add(name,table)
end) termHash nonterm
fun makeUniqueId s =
if SymbolHash.exists(s,symbolHash) then makeUniqueId (s ^ "'")
else s
val _ = if wasError() then raise Semantic else ()
val numTerms = SymbolHash.size termHash
val numNonterms = SymbolHash.size symbolHash - numTerms
val symError = fn sym => fn err => fn symbol =>
error (symbolPos symbol)
(symbolName symbol^" in "^err^" is not defined as a " ^ sym)
val termNum : string -> Header.symbol -> term =
let val termError = symError "terminal"
in fn stmt =>
let val stmtError = termError stmt
in fn symbol =>
case SymbolHash.find(symbolName symbol,symbolHash)
of NONE => (stmtError symbol; T ~1)
| SOME i => T (if i<numTerms then i
else (stmtError symbol; ~1))
end
end
val nontermNum : string -> Header.symbol -> nonterm =
let val nontermError = symError "nonterminal"
in fn stmt =>
let val stmtError = nontermError stmt
in fn symbol =>
case SymbolHash.find(symbolName symbol,symbolHash)
of NONE => (stmtError symbol; NT ~1)
| SOME i => if i>=numTerms then NT (i-numTerms)
else (stmtError symbol;NT ~1)
end
end
val symbolNum : string -> Header.symbol -> Grammar.symbol =
let val symbolError = symError "symbol"
in fn stmt =>
let val stmtError = symbolError stmt
in fn symbol =>
case SymbolHash.find(symbolName symbol,symbolHash)
of NONE => (stmtError symbol; NONTERM (NT ~1))
| SOME i => if i>=numTerms then NONTERM(NT (i-numTerms))
else TERM(T i)
end
end
val eop = map (termNum "%eop") eop
val keyword = map (termNum "%keyword") keyword
val prec = map (fn (a,l) =>
(a,case a
of LEFT => map (termNum "%left") l
| RIGHT => map (termNum "%right") l
| NONASSOC => map (termNum "%nonassoc") l
)) prec
val change =
let val mapTerm = termNum "%prefer, %subst, or %change"
in map (fn (a,b) => (map mapTerm a, map mapTerm b)) change
end
val noshift = map (termNum "%noshift") noshift
val value =
let val mapTerm = termNum "%value"
in map (fn (a,b) => (mapTerm a,b)) value
end
val (rules,_) =
let val symbolNum = symbolNum "rule"
val nontermNum = nontermNum "rule"
val termNum = termNum "%prec tag"
in List.foldr
(fn (RULE {lhs,rhs,code,prec},(l,n)) =>
( {lhs=nontermNum lhs,rhs=map symbolNum rhs,
code=code,prec=case prec
of NONE => NONE
| SOME t => SOME (termNum t),
rulenum=n}::l,n-1))
(nil,length rules-1) rules
end
val _ = if wasError() then raise Semantic else ()
val termToString =
let val data = array(numTerms,"")
val unmap = fn (symbol,_) =>
let val name = symbolName symbol
in update(data,
case SymbolHash.find (name,symbolHash) of
NONE => raise Fail "termToString"
| SOME i => i,
name)
end
val _ = app unmap term
in fn T i =>
if DEBUG andalso (i<0 orelse i>=numTerms)
then "bogus-num" ^ (Int.toString i)
else data sub i
end
val nontermToString =
let val data = array(numNonterms,"")
val unmap = fn (symbol,_) =>
let val name = symbolName symbol
in update(data,
case SymbolHash.find (name,symbolHash) of
NONE => raise Fail "nontermToString"
| SOME i => i-numTerms,
name)
end
val _ = app unmap nonterm
in fn NT i =>
if DEBUG andalso (i<0 orelse i>=numNonterms)
then "bogus-num" ^ (Int.toString i)
else data sub i
end
val termPrec =
let val precData = array(numTerms, NONE : int option)
val addPrec = fn termPrec => fn term as (T i) =>
case precData sub i
of SOME _ =>
error 1 ("multiple precedences specified for terminal " ^
(termToString term))
| NONE => update(precData,i,termPrec)
val termPrec = fn ((LEFT,_) ,i) => i
| ((RIGHT,_),i) => i+2
| ((NONASSOC,l),i) => i+1
val _ = List.foldl (fn (args as ((_,l),i)) =>
(app (addPrec (SOME (termPrec args))) l; i+3))
0 prec
in fn (T i) =>
if DEBUG andalso (i < 0 orelse i >= numTerms) then
NONE
else precData sub i
end
val elimAssoc = fn i => (i - (i mod 3) + 1)
val rulePrec =
let fun findRightTerm (nil,r) = r
| findRightTerm (TERM t :: tail,r) =
findRightTerm(tail,SOME t)
| findRightTerm (_ :: tail,r) = findRightTerm(tail,r)
in fn rhs =>
case findRightTerm(rhs,NONE)
of NONE => NONE
| SOME term =>
case termPrec term
of SOME i => SOME (elimAssoc i)
| a => a
end
val grammarRules =
let val conv = fn {lhs,rhs,code,prec,rulenum} =>
{lhs=lhs,rhs =rhs,precedence=
case prec
of SOME t => (case termPrec t
of SOME i => SOME(elimAssoc i)
| a => a)
| _ => rulePrec rhs,
rulenum=rulenum}
in map conv rules
end
val start =
case start
of NONE => #lhs (hd grammarRules)
| SOME name =>
nontermNum "%start" name
val symbolType =
let val data = array(numTerms+numNonterms,NONE : ty option)
val unmap =
fn (symbol,ty) =>
update (data,
case SymbolHash.find(symbolName symbol,symbolHash) of
NONE => raise Fail "unmap"
| SOME i => i,
ty)
val _ = (app unmap term; app unmap nonterm)
in fn NONTERM(NT i) =>
if DEBUG andalso (i<0 orelse i>=numNonterms)
then NONE
else data sub (i+numTerms)
| TERM (T i) =>
if DEBUG andalso (i<0 orelse i>=numTerms)
then NONE
else data sub i
end
val symbolToString =
fn NONTERM i => nontermToString i
| TERM i => termToString i
val grammar = GRAMMAR {rules=grammarRules,
terms=numTerms,nonterms=numNonterms,
eop = eop, start=start,noshift=noshift,
termToString = termToString,
nontermToString = nontermToString,
precedence = termPrec}
val _ =
if false
then
(List.foldl
(fn ({lhs, rhs, rulenum, ...}, i) =>
(print (String.concat [Int.toString rulenum, ": ",
nontermToString lhs, " ->"])
; List.app (fn s => (print (String.concat
[" ", symbolToString s]))) rhs
; print "\n"
; i + 1))
0 grammarRules
; ())
else ()
val name' = case name
of NONE => ""
| SOME s => symbolName s
val names = NAMES {miscStruct=name' ^ "LrValsFun",
valueStruct="MlyValue",
tableStruct="LrTable",
tokenStruct="Tokens",
actionsStruct="Actions",
ecStruct="EC",
arg= #1 arg_decl,
tokenSig = name' ^ "_TOKENS",
miscSig = name' ^ "_LRVALS",
dataStruct = "ParserData",
dataSig = "PARSER_DATA"}
val (table,stateErrs,corePrint,errs) =
MakeTable.mkTable(grammar,defaultReductions)
val entries = ref 0
in
make_path (spec ^ ".sml") |> File_Stream.open_output (fn result =>
make_path (spec ^ ".sig") |> File_Stream.open_output (fn sigs =>
let
val pos = ref 0
val pr = File_Stream.output result
val say = fn s => let val l = String.size s
val newPos = (!pos) + l
in if newPos > lineLength
then (pr "\n"; pos := l)
else (pos := newPos);
pr s
end
val saydot = fn s => (say (s ^ "."))
val sayln = fn t => (pr t; pr "\n"; pos := 0)
val termvoid = makeUniqueId "VOID"
val ntvoid = makeUniqueId "ntVOID"
val hasType = fn s => case symbolType s
of NONE => false
| _ => true
val terms = let fun f n = if n=numTerms then nil
else (T n) :: f(n+1)
in f 0
end
val values = VALS {say=say,sayln=sayln,saydot=saydot,
termvoid=termvoid, ntvoid = ntvoid,
hasType=hasType, pos_type = pos_type,
arg_type = #2 arg_decl,
start=start,pureActions=pureActions,
termToString=termToString,
symbolToString=symbolToString,term=term,
nonterm=nonterm,terms=terms,
tokenInfo=token_sig_info_decl}
val (NAMES {miscStruct,tableStruct,dataStruct,tokenSig,tokenStruct,dataSig,...}) = names
in case header_decl
of NONE => (say "functor "; say miscStruct;
sayln "(structure Token : TOKEN)";
say " : sig structure ";
say dataStruct;
say " : "; sayln dataSig;
say " structure ";
say tokenStruct; say " : "; sayln tokenSig;
sayln " end")
| SOME s => say s;
sayln " = ";
sayln "struct";
sayln ("structure " ^ dataStruct ^ "=");
sayln "struct";
sayln "structure Header = ";
sayln "struct";
sayln header;
sayln "end";
sayln "structure LrTable = Token.LrTable";
sayln "structure Token = Token";
sayln "local open LrTable in ";
entries := PrintStruct.makeStruct{table=table,print=pr,
name = "table",
verbose=verbose};
sayln "end";
printTypes(values,names,symbolType);
printEC (keyword,change,noshift,value,values,names);
printAction(rules,values,names);
sayln "end";
printTokenStruct(values,names);
sayln "end";
printSigs(values,names, File_Stream.output sigs);
MakeTable.Errs.printSummary (fn s => TextIO.output(TextIO.stdOut,s)) errs
end));
if verbose then
make_path (spec ^ ".desc") |> File_Stream.open_output (fn out =>
let
val say = File_Stream.output out
val printRule =
let val rules = Array.fromList grammarRules
in fn say =>
let val prRule = fn {lhs,rhs,precedence,rulenum} =>
((say o nontermToString) lhs; say " : ";
app (fn s => (say (symbolToString s); say " ")) rhs)
in fn i => prRule (rules sub i)
end
end
in Verbose.printVerbose
{termToString=termToString,nontermToString=nontermToString,
table=table, stateErrs=stateErrs,errs = errs,entries = !entries,
print=say, printCores=corePrint,printRule=printRule}
end)
else ()
end
val parseGen = fn spec =>
let val (result,inputSource) = ParseGenParser.parse spec
in make_parser(getResult result,spec,Header.error inputSource,
errorOccurred inputSource)
end
end;