CVS: sml-dist/src/lexgen/src/BackEnds/SML ml.sml,NONE,1.1 sml-fun-output.sml,NONE,1.1 template-sml-fun.sml,NONE,1.1
Matthias Blume <[email protected]>
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/lexgen/src/BackEnds/SML
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30700/src/lexgen/src/BackEnds/SML
Added Files:
ml.sml sml-fun-output.sml template-sml-fun.sml
Log Message:
ml-flex -> lexgen
--- NEW FILE: ml.sml ---
(* ml.sml
*
* COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies
* (Used and modified with permission)
* Aaron Turon (http://www.cs.uchicago.edu/~adrassi)
*
* ML core language representation and pretty-printing
*)
structure ML =
struct
datatype raw_ml = Raw of ml_token list
and ml_token = Tok of string
datatype cmp_op = LT | GT | EQ | LEQ | GEQ
datatype bool_op = AND | OR
(* a subset of ML expressions and patterns that we use to represent the
* match DFA
*)
datatype ml_exp
= ML_Var of string
| ML_Sym of RegExp.Sym.point
| ML_Cmp of (cmp_op * ml_exp * ml_exp)
| ML_Bool of (bool_op * ml_exp * ml_exp)
| ML_Case of ml_exp * (ml_pat * ml_exp) list
| ML_If of ml_exp * ml_exp * ml_exp
| ML_App of (string * ml_exp list)
| ML_Let of (string * ml_exp * ml_exp)
| ML_Fun of (string * string list * ml_exp * ml_exp)
| ML_Seq of ml_exp list
| ML_Tuple of ml_exp list
| ML_List of ml_exp list
| ML_RefGet of ml_exp
| ML_RefPut of ml_exp * ml_exp
| ML_Raw of ml_token list
and ml_pat
= ML_Wild
| ML_VarPat of string
| ML_IntPat of RegExp.Sym.point
| ML_ConPat of string * ml_pat list
local
structure PP = TextIOPP
in
fun ppML (ppStrm, e) = let
fun str s = PP.string ppStrm s
fun sp () = PP.space ppStrm 1
fun nl () = PP.newline ppStrm
fun hbox () = PP.openHBox ppStrm
fun vbox () = PP.openVBox ppStrm (PP.Abs 2)
fun close () = PP.closeBox ppStrm
fun letBody (true, pp) = (
nl();
str "in";
vbox(); nl(); pp(); close();
nl();
str "end")
| letBody (false, pp) = pp()
fun ppExp (inLet, prevFn, e) = (case e
of (ML_Var x) => letBody(inLet, fn () => str x)
| (ML_Sym n) => letBody(inLet, fn () => str(RegExp.symToString n))
| (ML_Cmp (cop, e1, e2)) => letBody(inLet, fn () => (
ppExp' e1;
sp();
str (case cop
of LT => "<"
| GT => ">"
| EQ => "="
| LEQ => "<="
| GEQ => ">=");
sp();
ppExp' e2))
| (ML_Bool (bop, e1, e2)) => letBody(inLet, fn () => (
ppExp' e1;
sp();
str (case bop
of AND => "andalso"
| OR => "orelse");
sp();
ppExp' e2))
| (ML_Case(arg, pl)) => let
fun doCases (_, []) = ()
| doCases (isFirst, (p, e)::r) = (
nl();
(* NOTE: the following seems to trigger a bug in the PP library (bad indent) *)
PP.openHOVBox ppStrm (PP.Abs 6);
hbox();
if isFirst
then (sp(); str "of")
else (PP.space ppStrm 2; str "|");
sp();
ppPat p; sp(); str "=>";
close();
sp();
hbox();
PP.openVBox ppStrm (PP.Abs 0);
ppExp' e;
close();
close();
close();
doCases (false, r))
in
letBody(inLet, fn () => (
hbox();
str "(case"; sp(); str "("; ppExp' arg; str ")";
close();
doCases (true, pl);
nl(); str "(* end case *))"))
end
| (ML_App(f, args)) => letBody(inLet, fn () => (
hbox();
str f; str "(";
case args
of [] => ()
| [e] => ppExp' e
| (e::r) => (
ppExp' e; app (fn e => (str ","; sp(); ppExp' e)) r)
(* end case *);
str ")";
close()))
| (ML_If(e1, e2, e3 as ML_If _)) => letBody(inLet, fn () => (
PP.openVBox ppStrm (PP.Abs 0);
vbox();
hbox(); str "if"; sp(); ppExp' e1; close(); nl();
hbox(); str "then"; sp();
vbox(); ppExp' e2; close();
close();
close(); nl();
hbox(); str "else"; sp();
ppExp' e3;
close();
close()))
| (ML_If(e1, e2, e3)) => letBody(inLet, fn () => (
vbox();
hbox(); str "if"; sp(); ppExp' e1; close(); nl();
hbox(); str "then"; sp();
vbox(); ppExp' e2; close();
close(); nl();
hbox(); str "else"; sp();
vbox(); ppExp' e3; close();
close();
close()))
| (ML_Let(x, e1, e2)) => let
fun pp () = (
nl();
hbox();
str "val"; sp(); str x; sp(); str "="; sp();
ppExp' e1;
close();
ppExp (true, false, e2))
in
if inLet
then pp()
else (
str "let";
PP.openVBox ppStrm (PP.Abs 0);
pp();
close())
end
| (ML_Fun(f, params, body, e)) => let
fun pp prefix = (
nl();
hbox();
str prefix; sp(); str f; sp();
str "(";
case params
of [] => ()
| [x] => str x
| (x::r) => (
str x; app (fn x => (str ","; sp(); str x)) r)
(* end case *);
str ")"; sp(); str "="; sp();
PP.openVBox ppStrm (PP.Abs 6);
ppExp' body;
close();
close();
ppExp (true, true, e))
in
if inLet
then if prevFn then pp "and" else pp "fun"
else (
PP.openVBox ppStrm (PP.Abs 0);
str "let";
pp "fun";
close())
end
| (ML_Seq[]) => letBody(inLet, fn () => str "()")
| (ML_Seq[e]) => ppExp(inLet, prevFn, e)
| (ML_Seq(e::r)) => let
fun pp () = (
ppExp' e;
app (fn e => (str ";"; sp(); ppExp' e)) r)
in
if inLet
then (
nl(); str "in";
PP.openBox ppStrm (PP.Abs 2);
nl(); pp();
close();
nl();
str "end")
else (
PP.openBox ppStrm (PP.Abs 0);
str "("; pp(); str ")";
close())
end
| (ML_Tuple[]) => letBody(inLet, fn () => str "()")
| (ML_Tuple(e::r)) => letBody (inLet, fn () => (
PP.openBox ppStrm (PP.Abs 2);
str "(";
ppExp' e;
app (fn e => (str ","; sp(); ppExp' e)) r;
str ")";
close()))
| (ML_List[]) => letBody(inLet, fn () => str "[]")
| (ML_List(e::r)) => letBody (inLet, fn () => (
PP.openBox ppStrm (PP.Abs 2);
str "[";
ppExp' e;
app (fn e => (str ","; sp(); ppExp' e)) r;
str "]";
close()))
| (ML_RefGet e) => letBody(inLet, fn () => (
str "!(";
ppExp' e;
str ")"))
| (ML_RefPut (e1, e2)) => letBody(inLet, fn () => (
ppExp' e1;
str " := ";
ppExp' e2))
| (ML_Raw toks) => letBody(inLet, fn () => (
hbox(); app (fn (Tok s) => str s) toks; close()))
(* end case *))
and ppExp' e = ppExp(false, false, e)
and ppPat p = let
fun pp (ML_Wild) = str "_"
| pp (ML_VarPat x) = str x
| pp (ML_IntPat n) = str(RegExp.symToString n)
| pp (ML_ConPat(c, [])) = str c
| pp (ML_ConPat(c, [p])) = (
str c; str "("; pp p; str ")")
| pp (ML_ConPat(c, p::r)) = (
str c; str "("; pp p;
app (fn p => (str ","; pp p)) r;
str ")")
in
hbox(); pp p; close()
end
in
ppExp (false, false, e)
end
end (* local *)
end
--- NEW FILE: sml-fun-output.sml ---
(* sml-fun-output.sml
*
* COPYRIGHT (c) 2005
* John Reppy (http://www.cs.uchicago.edu/~jhr)
* Aaron Turon ([email protected])
* All rights reserved.
*
* Code generation for SML, using control-flow
*)
structure SMLFunOutput : OUTPUT =
struct
structure RE = RegExp
structure Sym = RE.Sym
structure SIS = RegExp.SymSet
structure LO = LexOutputSpec
datatype ml_exp = datatype ML.ml_exp
datatype ml_pat = datatype ML.ml_pat
val inp = "inp"
val inpVar = ML_Var inp
fun idOf (LO.State {id, ...}) = id
fun nameOf' i = "yyQ" ^ (Int.toString i)
fun nameOf s = nameOf' (idOf s)
fun actName i = "yyAction" ^ (Int.toString i)
(* simple heuristic to avoid computing unused values *)
local
val has = String.isSubstring
in
val hasyytext = has "yytext"
val hasREJECT = has "REJECT"
val hasyylineno = has "yylineno"
end
(* map over the intervals of a symbol set *)
fun mapInt f syms =
SIS.foldlInt (fn (i, ls) => (f i)::ls) [] syms
(* transition interval representation *)
datatype transition_interval = TI of SIS.interval * int * ml_exp
fun intervalOf (TI (i, t, e)) = i
fun tagOf (TI (i, t, e)) = t
fun actionOf (TI (i, t, e)) = e
fun sameTag (TI (_, t1, _), TI (_, t2, _)) = t1 = t2
fun singleton (TI ((i, j), _, _)) = i = j
(* generate code for transitions: generate a hard-coded binary
* search on accepting characters
*)
fun mkTrans ([], _) = raise Fail "(BUG) SMLFunOutput: alphabet not covered"
| mkTrans ([t], _) = actionOf t
| mkTrans ([t1, t2], _) =
if sameTag (t1, t2) then actionOf t1
else let
val (_, t1end) = intervalOf t1
val (t2start, _) = intervalOf t2
in
if singleton t1 then
ML_If (ML_Cmp (ML.EQ, inpVar, ML_Sym t1end),
actionOf t1,
actionOf t2)
else if singleton t2 then
ML_If (ML_Cmp (ML.EQ, inpVar, ML_Sym t2start),
actionOf t2,
actionOf t1)
else
ML_If (ML_Cmp (ML.LEQ, inpVar, ML_Sym t1end),
actionOf t1,
actionOf t2)
end
| mkTrans (ts, len) = let
val lh = len div 2
fun split (ls, 0, l1) = (List.rev l1, ls)
| split (l::ls, cnt, l1) = split (ls, cnt-1, l::l1)
| split _ = raise Fail "(BUG) SMLFunOutput: split failed"
val (ts1, ts2) = split (ts, lh, [])
val (ts2start, ts2end) = intervalOf (List.hd ts2)
val (ts2', ts2len) = if ts2start = ts2end
then (List.tl ts2, len - lh - 1)
else (ts2, len - lh)
(* we want to take advantage of the special case when
* len = 3 and hd ts2 is a singleton. this case often
* occurs when we have an arrow for a single character.
*)
val elseClause =
if lh = 1 andalso ts2len = 1
then mkTrans ([List.hd ts1, List.hd ts2'], 2)
else ML_If (ML_Cmp (ML.LT, inpVar, ML_Sym ts2start),
mkTrans (ts1, lh),
mkTrans (ts2', ts2len))
in
ML_If (ML_Cmp (ML.EQ, inpVar, ML_Sym ts2start),
actionOf (List.hd ts2),
elseClause)
end
fun mkState actionVec (s, k) = let
val LO.State {id, label, final, next} = s
fun addMatch (i, lastMatch) = let
val lastMatch' = if hasREJECT (Vector.sub (actionVec, i))
then lastMatch
else ML_Var "yyNO_MATCH"
in
ML_App ("yyMATCH",
[ML_Var "strm",
ML_Var (actName i),
lastMatch'])
end
val (curMatch, nextMatches) = (case final
of [] => (NONE, [])
| f::fs => (SOME f, fs)
(* end case *))
val lastMatch = List.foldr addMatch (ML_Var "lastMatch") nextMatches
(* collect all valid transition symbols *)
val labels = List.foldl SIS.union SIS.empty (List.map #1 (!next))
(* pair transition intervals with associated actions/transitions *)
val newFinal = (case curMatch
of SOME j => addMatch (j, lastMatch)
| NONE => lastMatch
(* end case *))
fun arrows (syms, s) =
mapInt
(fn i => TI (i, idOf s,
ML_App (nameOf s, [ML_Var "strm'", newFinal])))
syms
val TIs = List.map arrows (!next)
val errAct' =
(case curMatch
of SOME j =>
ML_App (actName j,
[ML_Var "strm",
if hasREJECT (Vector.sub (actionVec, j))
then lastMatch
else ML_Var "yyNO_MATCH"])
| NONE => ML_App ("yystuck", [lastMatch])
(* end case *))
(* if first state in machine, check for eof *)
val errAct = if id = 0
then ML_If (ML_App("yyInput.eof", [ML_Var "strm"]),
ML_App("UserDeclarations.eof", [ML_Var "yyarg"]),
errAct')
else errAct'
(* error transitions = complement(valid transitions) *)
val error = SIS.complement labels
val errTIs = mapInt (fn i => TI (i, ~1, errAct)) error
(* the arrows represent intervals that partition the entire
* alphabet, with each interval mapped to some transition or
* action. we sort the intervals by their smallest member.
*)
fun gt (a, b) = (#1 (intervalOf a)) > (#1 (intervalOf b))
val sorted = ListMergeSort.sort gt (List.concat (errTIs :: TIs))
(* now we want to find adjacent partitions with the same
* action, and merge their intervals
*)
fun merge [] = []
| merge [t] = [t]
| merge (t1::t2::ts) =
if sameTag (t1, t2) then let
val TI ((i, _), tag, act) = t1
val TI ((_, j), _, _ ) = t2
val t = TI ((i, j), tag, act)
in
merge (t::ts)
end
else
t1::(merge (t2::ts))
val merged = merge sorted
(* create the transition code *)
val trans = mkTrans(merged, List.length merged)
(* create the input code *)
val getInp =
(* trans has at least the error action. if length(merged)
* is 1 then we can avoid getting any input and simply
* take the error transition in all cases. note that
* the "error" transition may actually be a match
*)
(case merged
of [_] => errAct
| _ => ML_Case (ML_App ("yygetc", [ML_Var "strm"]),
[(ML_ConPat ("NONE", []), errAct),
(ML_ConPat ("SOME", [ML_VarPat (inp ^ ", strm'")]),
trans)])
(* end case *))
in
ML_Fun (nameOf s, ["strm", "lastMatch"], getInp, k)
end
fun mkAction (i, action, k) = let
val updStrm = ML_RefPut (ML_Var "yystrm", ML_Var "strm")
val act = ML_Raw [ML.Tok action]
val seq = ML_Seq [updStrm, act]
val lett = if hasyytext action
then ML_Let
("yytext",
ML_App("yymktext", [ML_Var "strm"]),
seq)
else seq
val letl = if hasyylineno action
then ML_Let
("yylineno",
ML_App("ref",
[ML_App ("yyInput.getlineNo",
[ML_RefGet (ML_Var "yystrm")])]),
lett)
else lett
val letr = if hasREJECT action
then ML_Let
("oldStrm", ML_RefGet (ML_Var "yystrm"),
ML_Fun
("REJECT", [],
ML_Seq
[ML_RefPut (ML_Var "yystrm",
ML_Var "oldStrm"),
ML_App("yystuck", [ML_Var "lastMatch"])],
letl))
else letl
in
ML_Fun (actName i, ["strm", "lastMatch"], letr, k)
end
fun lexerHook spec strm = let
val LO.Spec {actions, dfa, startStates, ...} = spec
fun matchSS (label, state) =
(ML_ConPat (label, []),
ML_App (nameOf state,
[ML_RefGet (ML_Var "yystrm"),
ML_Var "yyNO_MATCH"]))
val innerExp = ML_Case (ML_RefGet (ML_Var "yyss"),
List.map matchSS startStates)
val statesExp = List.foldr (mkState actions) innerExp dfa
val lexerExp = Vector.foldri mkAction statesExp actions
val ppStrm = TextIOPP.openOut {dst = strm, wid = 80}
in
ML.ppML (ppStrm, lexerExp)
end
fun startStatesHook spec strm = let
val LO.Spec {startStates, ...} = spec
val machNames = #1 (ListPair.unzip startStates)
in
TextIO.output (strm, String.concatWith " | " machNames)
end
fun userDeclsHook spec strm = let
val LO.Spec {decls, ...} = spec
in
TextIO.output (strm, decls)
end
fun headerHook spec strm = let
val LO.Spec {header, ...} = spec
in
TextIO.output (strm, header)
end
fun argsHook spec strm = let
val LO.Spec {arg, ...} = spec
val arg' = if String.size arg = 0
then "(yyarg as ())"
else "(yyarg as " ^ arg ^ ") ()"
in
TextIO.output (strm, arg')
end
structure TIO = TextIO
val template = let
val file = TIO.openIn "BackEnds/SML/template-sml-fun.sml"
fun done () = TIO.closeIn file
fun read () = (case TIO.inputLine file
of NONE => []
| SOME line => line::read()
(* end case *))
in
read() handle ex => (done(); raise ex)
before done()
end
fun output (spec, fname) =
ExpandFile.expand {
src = template,
dst = fname ^ ".sml",
hooks = [("lexer", lexerHook spec),
("startstates", startStatesHook spec),
("userdecls", userDeclsHook spec),
("header", headerHook spec),
("args", argsHook spec)]
}
end
--- NEW FILE: template-sml-fun.sml ---
@header@
= struct
structure yyInput : sig
type stream
val mkStream : (int -> string) -> stream
val fromStream : TextIO.StreamIO.instream -> stream
val getc : stream -> (Char.char * stream) option
val getpos : stream -> int
val getlineNo : stream -> int
val subtract : stream * stream -> string
val eof : stream -> bool
end = struct
structure TIO = TextIO
structure TSIO = TIO.StreamIO
structure TPIO = TextPrimIO
datatype stream = Stream of {
strm : TSIO.instream,
id : int, (* track which streams originated
* from the same stream *)
pos : int,
lineNo : int
}
local
val next = ref 0
in
fun nextId() = !next before (next := !next + 1)
end
val initPos = 2 (* ml-lex bug compatibility *)
fun mkStream inputN = let
val strm = TSIO.mkInstream
(TPIO.RD {
name = "lexgen",
chunkSize = 4096,
readVec = SOME inputN,
readArr = NONE,
readVecNB = NONE,
readArrNB = NONE,
block = NONE,
canInput = NONE,
avail = (fn () => NONE),
getPos = NONE,
setPos = NONE,
endPos = NONE,
verifyPos = NONE,
close = (fn () => ()),
ioDesc = NONE
}, "")
in
Stream {strm = strm, id = nextId(), pos = initPos, lineNo = 1}
end
fun fromStream strm = Stream {
strm = strm, id = nextId(), pos = initPos, lineNo = 1
}
fun getc (Stream {strm, pos, id, lineNo}) = (case TSIO.input1 strm
of NONE => NONE
| SOME (c, strm') =>
SOME (c, Stream {
strm = strm',
pos = pos+1,
id = id,
lineNo = lineNo +
(if c = #"\n" then 1 else 0)
})
(* end case*))
fun getpos (Stream {pos, ...}) = pos
fun getlineNo (Stream {lineNo, ...}) = lineNo
fun subtract (new, old) = let
val Stream {strm = strm, pos = oldPos, id = oldId, ...} = old
val Stream {pos = newPos, id = newId, ...} = new
val (diff, _) = if newId = oldId andalso newPos >= oldPos
then TSIO.inputN (strm, newPos - oldPos)
else raise Fail
"BUG: yyInput: attempted to subtract incompatible streams"
in
diff
end
fun eof (Stream {strm, ...}) = TSIO.endOfStream strm
end
datatype 'a yymatch
= yyNO_MATCH
| yyMATCH of yyInput.stream * 'a action * 'a yymatch
withtype 'a action = yyInput.stream * 'a yymatch -> 'a
datatype yystart_state =
@startstates@
structure UserDeclarations =
struct
@userdecls@
end
local
fun mk yyins = let
(* current start state *)
val yyss = ref INITIAL
fun YYBEGIN ss = (yyss := ss)
(* current input stream *)
val yystrm = ref yyins
(* get one char of input *)
val yygetc = yyInput.getc
(* create yytext *)
fun yymktext(strm) = yyInput.subtract (strm, !yystrm)
open UserDeclarations
fun lex
@args@
= let
fun yystuck (yyNO_MATCH) = raise Fail "stuck state"
| yystuck (yyMATCH (strm, action, old)) =
action (strm, old)
val yypos = yyInput.getpos (!yystrm)
fun continue() =
@lexer@
in continue() end
in
lex
end
in
fun makeLexer yyinputN = mk (yyInput.mkStream yyinputN)
fun makeLexer' ins = mk (yyInput.mkStream ins)
end
end
-------------------------------------------------------
This SF.Net email is sponsored by xPML, a groundbreaking scripting language
that extends applications into web and mobile media. Attend the live webcast
and join the prime developer group breaking into this new coding territory!
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=110944&bid=241720&dat=121642