diff options
| -rw-r--r-- | ccross.mlb | 5 | ||||
| -rw-r--r-- | ccross.sml | 5 | ||||
| -rw-r--r-- | common.sml | 2 | ||||
| -rw-r--r-- | driver.fun | 14 | ||||
| -rw-r--r-- | exn_handler.sml (renamed from exn_handler.fun) | 0 | ||||
| -rw-r--r-- | parser.fun | 348 | ||||
| -rw-r--r-- | parser.sig | 10 | ||||
| -rw-r--r-- | ppc.fun | 18 | ||||
| -rw-r--r-- | ppc.sig | 4 |
9 files changed, 397 insertions, 9 deletions
@@ -1,5 +1,6 @@ ann "allowRecordPunExps true" + "allowOrPats true" "warnUnused true" in $(SML_LIB)/basis/basis.mlb @@ -11,7 +12,9 @@ in tree.sig tree.sml tokenizer.sig tokenizer.fun ppc.sig ppc.fun - exn_handler.sig exn_handler.fun + parser.sig parser.fun + + exn_handler.sig exn_handler.sml driver.sig driver.fun ccross.sig ccross.sml @@ -2,8 +2,9 @@ structure ccross:> CCROSS = struct structure T:> TOKENIZER = Tokenizer(structure H = Hashtable; structure S = Stream) structure ppc:> PPC = ppc(structure Tree = Tree; structure T = T) - structure D:> DRIVER = Driver(ppc) - structure ExnHandler: EXN_HANDLER = ExnHandler + structure Parser:> PARSER = Parser(ppc) + structure D:> DRIVER = Driver(Parser) + structure ExnHandler:> EXN_HANDLER = ExnHandler end val () = MLton.Exn.setTopLevelHandler ccross.ExnHandler.handler @@ -161,7 +161,7 @@ val I = fn z => bindWith2str Int.toString z val C = fn z => bindWith2str str z val B = fn z => bindWith2str Bool.toString z val R = fn z => bind A1 (fn ((output, _), n) => app (fn f => f ()) - (List.tabulate (n, fn _ => fn () => output "\t"))) z + (List.tabulate (n, fn _ => fn () => output " "))) z type ('t, 'a, 'b, 'c) a1printer = (bool * ((string -> unit) * 'a)) * 'b -> 't -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c @@ -1,4 +1,4 @@ -functor Driver(P: PPC): DRIVER = struct +functor Driver(P: PARSER): DRIVER = struct structure P = P datatype execMode = Normal | DebugE | DebugT @@ -50,9 +50,15 @@ functor Driver(P: PPC): DRIVER = struct val file = valOf $ #file config in case (#mode config) of - Normal => die `"Normal mode is not implemented yet" % - | DebugT => P.T.debugPrint file - | DebugE => P.debugPrint file (#includeDirs config) + Normal => + let + val parseCtx = P.createParseCtx file (#includeDirs config) + val (_, _) = P.parseDef parseCtx + in + raise Unimplemented + end + | DebugT => P.P.T.debugPrint file + | DebugE => P.P.debugPrint file (#includeDirs config) end end diff --git a/exn_handler.fun b/exn_handler.sml index c0a2d7a..c0a2d7a 100644 --- a/exn_handler.fun +++ b/exn_handler.sml diff --git a/parser.fun b/parser.fun new file mode 100644 index 0000000..ccd467e --- /dev/null +++ b/parser.fun @@ -0,0 +1,348 @@ +functor Parser(P: PPC): PARSER = struct + + structure P = P + structure T = P.T + + type parseCtx = P.t + + datatype unop = + UnopPreInc | + UnopPreDec | + UnopAddr | + UnopDeref | + UnopPos | + UnopNeg | + UnopComp | + UnopLogNeg | + + UnopPostInc | + UnopPostDec + + datatype binop = + BinopMul | + BinopDiv | + BinopMod | + BinopSum | + BinopSub | + BinopShiftLeft | + BinopShiftRight | + BinopGreater | + BinopLess | + BinopLessEqual | + BinopGreaterEqual | + BinopEqual | + BinopNotEqual | + BinopBitAnd | + BinopBitXor | + BinopBitOr | + BinopLogAnd | + BinopLogOr | + + BinopAssign | + BinopMulAssign | + BinopDivAssign | + BinopModAssign | + BinopSumAssign | + BinopSubAssign | + BinopLeftShiftAssign | + BinopRightShiftAssign | + BinopBitAndAssign | + BinopBitXorAssign | + BinopBitOrAssign + + val binopTable = [ + (BinopMul, T.Asterisk, 13, true), + (BinopDiv, T.Slash, 13, true), + (BinopMod, T.Percent, 13, true), + (BinopSum, T.Plus, 12, true), + (BinopSub, T.Minus, 12, true), + (BinopShiftLeft, T.DoubleLess, 11, true), + (BinopShiftRight, T.DoubleGreater, 11, true), + (BinopGreater, T.Greater, 10, true), + (BinopLess, T.Less, 10, true), + (BinopLessEqual, T.LessEqualSign, 10, true), + (BinopGreaterEqual, T.GreaterEqualSign, 10, true), + (BinopEqual, T.DoubleEqualSign, 9, true), + (BinopNotEqual, T.ExclMarkEqualSign, 9, true), + (BinopBitAnd, T.Ampersand, 8, true), + (BinopBitXor, T.Cap, 7, true), + (BinopBitOr, T.VerticalBar, 6, true), + (BinopLogAnd, T.DoubleAmpersand, 5, true), + (BinopLogOr, T.DoubleVerticalBar, 4, true), + + (BinopAssign, T.EqualSign, 3, false), + (BinopMulAssign, T.AmpersandEqualSign, 3, false), + (BinopDivAssign, T.SlashEqualSign, 3, false), + (BinopModAssign, T.PercentEqualSign, 3, false), + (BinopSumAssign, T.PlusEqualSign, 3, false), + (BinopSubAssign, T.MinusEqualSign, 3, false), + (BinopLeftShiftAssign, T.DoubleLessEqualSign, 3, false), + (BinopRightShiftAssign, T.DoubleGreaterEqualSign, 3, false), + (BinopBitAndAssign, T.AmpersandEqualSign, 3, false), + (BinopBitXorAssign, T.CapEqualSign, 3, false), + (BinopBitOrAssign, T.VerticalBarEqualSign, 3, false) + ] + + datatype expr = + Enum | + Eid of string | + Estrlit of string | + EmemberByV of string * exprAug | + EmemberByP of string * exprAug | + Eunop of unop * exprAug | + Ebinop of binop * exprAug * exprAug + + and exprAug = EAug of expr * P.tkPos + + datatype exprPart = + EPexpr of exprAug | + (* last two are prio and leftAssoc *) + EPbinop of binop * P.tkPos * int * bool + + type def = expr + + datatype token = + Tk of T.token | + TkParens of (token * P.tkPos) list | + TkBrackets of (token * P.tkPos) list | + TkBraces of (token * P.tkPos) list + + fun createParseCtx fname incDirs = + P.create { fname, incDirs, debugMode = false } + + fun getToken ppc = + let + val (tk, pos, ppc) = P.getToken ppc + in + case tk of + T.LParen | T.LBracket | T.LBrace => raise Unimplemented + | _ => (Tk tk, pos, ppc) + end + + val Punop = fn z => + let + fun Punop (out, unop) = + Printf out `(case unop of + UnopPreInc | UnopPostInc => "++" + | UnopPreDec | UnopPostDec => "--" + | UnopPos => "+" + | UnopNeg => "-" + | UnopAddr => "&" + | UnopDeref => "*" + | UnopComp => "~" + | UnopLogNeg => "!") % + in + bind A1 Punop + end z + + val Pbinop = fn z => + let + fun Pbinop (out, binop) = + case List.find (fn (binop', _, _, _) => binop' = binop) binopTable + of + SOME (_, tk, _, _) => Printf out T.Ptk tk% + | NONE => raise Unreachable + in + bind A1 Pbinop + end z + + fun printExpr off ea = + let + fun printExpr' off (EAug (e, pos)) = + let + fun Pprintf g = printf R off (fn (a, _) => + g (a, fn (_, out) => Printf out `"| " P.PtkPos pos %)) + + fun member (member, ea) s = ( + Pprintf `"(" `s `member %; + printf `"\n" %; + printExpr' (off + 1) ea; + printf `")" % + ) + in + case e of + Eid id => Pprintf `id % + | Enum => Pprintf `"num" % + | Estrlit s => Pprintf `"\"" `s `"\"" % + | EmemberByV pair => member pair "." + | EmemberByP pair => member pair "->" + | Eunop (unop, ea) => ( + Pprintf `"(" Punop unop %; + printf `"\n" %; + printExpr' (off + 1) ea; + printf `")" % + ) + | Ebinop (binop, left, right) => ( + Pprintf `"(" Pbinop binop %; + printf `"\n" %; + printExpr (off + 1) left; + printExpr' (off + 1) right; + printf `")" % + ) + end + in + printExpr' off ea; + printf `"\n" % + end + + fun parseUnaryPrefix ppc acc = + let + val unopPreTable = [ + (T.DoublePlus, UnopPreInc), + (T.DoubleMinus, UnopPreDec), + (T.Plus, UnopPos), + (T.Minus, UnopNeg) + ] + val (tk, pos, ppc') = getToken ppc + in + case tk of + Tk tk => ( + case List.find (fn (tk', _) => tk' = tk) unopPreTable of + SOME (_, unop) => parseUnaryPrefix ppc' ((unop, pos) :: acc) + | _ => (acc, ppc) + ) + | _ => (acc, ppc) + end + + fun parsePrimaryExpr ppc = + let + val (tk, pos, ppc) = getToken ppc + in + (fn e => (EAug (e, pos), ppc)) + (case tk of + Tk (T.Id id) => Eid id + | Tk (T.StringConst s) => Estrlit s + | Tk (T.CharConst _) => raise Unimplemented + | Tk (T.Num _) => Enum + | _ => P.clerror pos [P.Cid, P.Cconst]) + end + + fun parseExprSuffix1 eAug ppc = + let + val (tk, pos1, ppc1) = getToken ppc + + fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ppc1) + fun formMemberOp unop = + let + val (tk, pos2, ppc2) = getToken ppc1 + in + case tk of + Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ppc2) + | _ => P.clerror pos2 [P.Cid] + end + in + case tk of + Tk T.DoublePlus => formUnop1 UnopPostInc + | Tk T.DoubleMinus => formUnop1 UnopPostDec + | Tk T.Dot => formMemberOp EmemberByV + | Tk T.Arrow => formMemberOp EmemberByP + | _ => (NONE, ppc) + end + + fun parseExprSuffix eAug ppc = + let + val (eAug', ppc) = parseExprSuffix1 eAug ppc + in + case eAug' of + SOME eAug => parseExprSuffix eAug ppc + | NONE => (eAug, ppc) + end + + fun parseUnary ppc = + let + val (prefix, ppc) = parseUnaryPrefix ppc [] + val (eAug, ppc) = parsePrimaryExpr ppc + val (eAug, ppc) = parseExprSuffix eAug ppc + + val eAug = List.foldl + (fn ((unop, pos), e) => EAug (Eunop (unop, e), pos)) eAug prefix + in + (EPexpr eAug, ppc) + end + + fun parseBinop ppc = + let + val (tk, pos, ppc) = getToken ppc + in + case tk of + Tk tk => ( + case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of + SOME (binop, _, prio, leftAssoc) => + SOME (EPbinop (binop, pos, prio, leftAssoc), ppc) + | NONE => + if tk = T.EOS then + NONE + else + P.clerror pos [P.Cbinop] + ) + | _ => P.clerror pos [P.Cbinop] + end + + fun constructExpr parts = + let + fun shouldTakePrev _ [] = false + | shouldTakePrev (_, _, p, assoc) ((_, _, p') :: _) = + case Int.compare (p', p) of + GREATER => true + | EQUAL => assoc + | LESS => false + + fun moveHead vstack opstack = + let + fun take2 (x :: y :: tl) = (x, y, tl) + | take2 _ = raise Unreachable + val (right, left, vstack) = take2 vstack + val (binop', pos, _) = hd opstack + + val head = EAug (Ebinop (binop', left, right), pos) + in + (head :: vstack, tl opstack) + end + + fun insert (Q as (binop, pos, p, _)) (vstack, opstack) = + if shouldTakePrev Q opstack then + insert Q (moveHead vstack opstack) + else + (vstack, (binop, pos, p) :: opstack) + + fun finish ([ea], []) = ea + | finish (_, []) = raise Unreachable + | finish (vstack, opstack) = finish $ moveHead vstack opstack + + fun construct (vstack, opstack) (EPexpr ea :: acc) = + construct (ea :: vstack, opstack) acc + | construct stacks (EPbinop Q :: acc) = + construct (insert Q stacks) acc + | construct stacks [] = finish stacks + in + construct ([], []) parts + end + + fun parseExpr ppc = + let + fun collect ppc expVal acc = + if expVal then + let + val (unary, ppc) = parseUnary ppc + in + collect ppc (not expVal) (unary :: acc) + end + else + case parseBinop ppc of + SOME (binop, ppc) => collect ppc (not expVal) (binop :: acc) + | NONE => (rev acc, ppc) + + val (parts, ppc) = collect ppc true [] + val expr = constructExpr parts + in + (expr, ppc) + end + + fun parseDef ppc = + let + val (expr, ppc) = parseExpr ppc + val () = printExpr 0 expr + in + (raise Unimplemented, ppc) + end +end diff --git a/parser.sig b/parser.sig new file mode 100644 index 0000000..7545f22 --- /dev/null +++ b/parser.sig @@ -0,0 +1,10 @@ +signature PARSER = sig + + structure P: PPC + + type parseCtx + type def + + val createParseCtx: string -> string list -> parseCtx + val parseDef: parseCtx -> def * parseCtx +end @@ -147,6 +147,22 @@ struct prefix end + val PtkPos = fn z => + let + fun PtkPos (out, TkPos (p as T.S.Pos (fname, line, col), layers)) = + case layers of + [] => Printf out T.S.Ppos p % + | _ => + let + val prefix = PlayersCompact (out, SOME fname, layers) + val fname = String.extract (fname, size prefix, NONE) + in + Printf out `"; @" T.S.Ppos (T.S.Pos (fname, line, col)) % + end + in + bind A1 PtkPos + end z + val startCache = (0, [], ("", 0)) fun printTokenCompact (off, layers, (fname, line)) out (tk, pos) = @@ -961,7 +977,7 @@ struct updatePpc P u#buffer (updateH head) % end - and getTokenSkipNL ppc = + fun getTokenSkipNL ppc = let val (tk, pos, ppc) = getToken ppc in @@ -13,7 +13,11 @@ signature PPC = sig Cbinop | Cop + val clerror: tkPos -> tkClass list -> 'a + val create: { fname: string, incDirs: string list, debugMode: bool } -> t val getToken: t -> T.token * tkPos * t val debugPrint: string -> string list -> unit + + val PtkPos: (tkPos, 'a, 'b, 'c) a1printer end |