diff options
| -rw-r--r-- | common.sml | 10 | ||||
| -rw-r--r-- | parser.fun | 528 |
2 files changed, 535 insertions, 3 deletions
@@ -179,6 +179,16 @@ type ('t1, 't2, 'a, 'b, 'c) a2printer = (bool * ((string -> unit) * 'a)) * 'b -> 't1 -> 't2 -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c +val Popt = fn z => +let + fun f (out, p, v) = + case v of + NONE => Printf out `"none" % + | SOME v => Printf out p v % +in + bind A2 f +end z + fun die code g = let fun finish (true, _) = raise Unreachable @@ -111,6 +111,31 @@ functor Parser(P: PPC): PARSER = struct (* last two are prio and leftAssoc *) EPbinop of binop * P.tkPos * int * bool + datatype storageSpec = + SpecTypedef | + SpecExtern | + SpecStatic | + SpecRegister + + datatype ctype = + void_t | + char_t | + uchar_t | + short_t | + ushort_t | + int_t | + uint_t | + long_t | + ulong_t | + longlong_t | + ulonglong_t | + float_t | + double_t | + + pointer_t of int * ctype | + function_t of ctype * ctype list | + array_t of ctype + type def = expr datatype token = @@ -120,6 +145,57 @@ functor Parser(P: PPC): PARSER = struct TkBraces of (token * P.tkPos) list | TkTernary of (token * P.tkPos) list + val PstorSpec = fn z => + let + fun f (out, s) = + Printf out `( + case s of + SpecTypedef => "typedef" + | SpecExtern => "extern" + | SpecRegister => "register" + | SpecStatic => "static" + ) % + in + bind A1 f + end z + + val Pctype = fn z => + let + fun Pctype (out, t) = + let + fun &s = Printf out `s % + in + case t of + void_t => &"void" + | char_t => &"char" + | uchar_t => &"unsigned char" + | short_t => &"short" + | ushort_t => &"usigned short" + | int_t => &"int" + | uint_t => &"unsigned int" + | long_t => &"long" + | ulong_t => &"unsigned long" + | longlong_t => &"long long" + | ulonglong_t => &"unsigned long long" + | float_t => &"float" + | double_t => &"double" + | pointer_t (plevel, t) => + Printf out `"[" I plevel `"]" A1 Pctype t % + | function_t (ret, params) => + let + fun Pparams (_, []) = () + | Pparams (out, [p]) = Printf out A1 Pctype p % + | Pparams (out, (p1 :: p2 :: t)) = + Printf out A1 Pctype p1 `", " A1 Pparams (p2 :: t) % + in + Printf out `"(" A1 Pparams params `") -> " A1 Pctype ret % + end + | array_t el => Printf out `"() -> " A1 Pctype el % + end + in + bind A1 Pctype + end z + fun PtokenL (_, []) = () | PtokenL (out, head :: tail) = let @@ -483,11 +559,457 @@ functor Parser(P: PPC): PARSER = struct (expr, ctx) end + val typeSpecs = [ + T.kwVoid, + T.kwChar, + T.kwShort, + T.kwInt, + T.kwLong, + T.kwFloat, + T.kwDouble, + T.kwSigned, + T.kwUnsigned + ] + + fun ts2idx ts = + let + fun find _ [] = raise Unreachable + | find idx (ts' :: tss) = + if ts = ts' then + idx + else + find (idx + 1) tss + in + find 0 typeSpecs + end + + fun idx2ts idx = List.nth (typeSpecs, idx) + + val tsMaxIdxP1 = length typeSpecs + + val prefixes = [ + (void_t, [[T.kwVoid]]), + (char_t, [[T.kwChar], [T.kwChar, T.kwSigned]]), + (uchar_t, [[T.kwUnsigned, T.kwChar]]), + (short_t, [[T.kwShort], [T.kwSigned, T.kwShort], [T.kwSigned, T.kwInt], + [T.kwSigned, T.kwShort, T.kwInt]]), + (ushort_t, [[T.kwUnsigned, T.kwShort], + [T.kwUnsigned, T.kwShort, T.kwInt]]), + (int_t, [[T.kwInt], [T.kwSigned], [T.kwSigned, T.kwInt]]), + (uint_t, [[T.kwUnsigned], [T.kwUnsigned, T.kwInt]]), + (long_t, [[T.kwLong], [T.kwSigned, T.kwLong], [T.kwLong, T.kwInt], + [T.kwSigned, T.kwLong, T.kwInt]]), + (ulong_t, [[T.kwUnsigned, T.kwLong], + [T.kwUnsigned, T.kwLong, T.kwInt]]), + (longlong_t, [[T.kwLong, T.kwLong], [T.kwSigned, T.kwLong, T.kwLong], + [T.kwLong, T.kwLong, T.kwInt], + [T.kwSigned, T.kwLong, T.kwLong, T.kwInt]]), + (ulonglong_t, [[T.kwUnsigned, T.kwLong, T.kwLong], + [T.kwUnsigned, T.kwLong, T.kwLong, T.kwInt]]), + (float_t, [[T.kwFloat]]), + (double_t, [[T.kwDouble]]) + ] + + fun genReprChildren l = + let + open List + fun genWithoutOne i = + if i = length l then + [] + else + let + val e = nth (l, i) + val bef = take (l, i) + val after = drop (l, i + 1) + in + (e, bef @ after) :: genWithoutOne (i + 1) + end + fun unique acc [] = acc + | unique acc ((e, l) :: tail) = + case List.find (fn (e', _) => e' = e) acc of + NONE => unique ((e, l) :: acc) tail + | SOME _ => unique acc tail + in + unique [] $ genWithoutOne 0 + end + + fun addRepr repr (P as (repr2id, _)) = + case List.find (fn (repr', _) => repr' = repr) repr2id of + SOME (_, id) => (id, P) + | NONE => + let + fun createId (repr2id, trs) = + let + val id = length repr2id + in + (id, ((repr, id) :: repr2id, trs)) + end + in + if length repr = 1 then + let + val (id, (repr2id, trs)) = createId P + in + (id, (repr2id, (0, ts2idx $ hd repr, id) :: trs)) + end + else + let + val children = genReprChildren repr + val (P, ids) = List.foldl (fn ((e, l), (P, ids)) => + let + val (id, P) = addRepr l P + in + (P, (id, e) :: ids) + end) (P, []) children + + val (id, (repr2id, trs)) = createId P + val trs = List.foldl (fn ((id', e), trs) => + (id', ts2idx e, id) :: trs) trs ids + in + (id, (repr2id, trs)) + end + end + + fun addTypeRepr ctype repr (repr2id, id2type, trs) = + let + val (id, (repr2id, trs)) = addRepr repr (repr2id, trs) + in + (repr2id, (id, ctype) :: id2type, trs) + end + + fun prefixFsmPrint fsm repr2id = + let + fun findRepr id = + case List.find (fn (_, id') => id' = id) repr2id of + SOME (repr, _) => repr + | NONE => raise Unreachable + + fun printRepr (out, l) = + let + fun printRepr' (_, []) = () + | printRepr' (out, [tk]) = Printf out P.Ptk tk % + | printRepr' (out, tk1 :: tk2 :: tail) = + Printf out P.Ptk tk1 `", " A1 printRepr' (tk2 :: tail) % + in + Printf out `"[" A1 printRepr' l `"]" % + end + + open Array + + fun printRow i = + let + val (ctype, trs) = sub (fsm, i) + fun printTrs () = appi (fn (j, id) => + if id = ~1 then + () + else + printf P.Ptk (idx2ts j) `" -> " I id `", " % + ) trs + fun printType out = + case ctype of + NONE => Printf out `"none" % + | SOME ctype => Printf out Pctype ctype % + in + printf I i `" " A1 printRepr (findRepr i) + `" |" A0 printType `"|: " %; + printTrs (); + printf `"\n" % + end + + val i = ref 0 + in + while !i < length fsm do ( + printRow $ !i; + i := !i + 1 + ) + end + + fun buildPrefixFsm () = + let + val T = ([([], 0)], [], []) + val (repr2id, id2type, trs) = List.foldl (fn ((t, rl), T) => + List.foldl (fn (r, T) => addTypeRepr t r T) T rl) T prefixes + + open Array + + fun fsmInit len = + let + val fsm = array (len, (NONE, array (tsMaxIdxP1, ~1))) + val i = ref 1 + in + while !i < len do ( + update (fsm, !i, (NONE, array (tsMaxIdxP1, ~1))); + i := !i + 1 + ); + fsm + end + + val fsm = fsmInit $ List.length repr2id + + val () = List.app (fn (id, ctype) => + let + val (_, subarray) = sub (fsm, id) + in + update (fsm, id, (SOME ctype, subarray)) + end) id2type + + val () = List.app (fn (id', n, id) => + let + val (_, subarray) = sub (fsm, id') + in + update (subarray, n, id) + end) trs + in + (* prefixFsmPrint fsm repr2id; *) + fsm + end + + val prefixFsm = buildPrefixFsm () + + fun advanceTypeRepr typeReprId (tk, pos) = + let + open Array + val n = ts2idx tk + val (_, subarray) = sub (prefixFsm, typeReprId) + val id = sub (subarray, n) + in + if id = ~1 then + P.error pos `"unexpected type specifier" % + else + id + end + + fun typeRepr2type typeReprId = + valOf o #1 o Array.sub $ (prefixFsm, typeReprId) + + datatype specType = StorageSpec of storageSpec | TypeSpec of T.token + + fun tryGetSpec ctx = + let + val (tk, pos, ctx') = getTokenCtx ctx + + val storageSpecs = [ + (T.kwTypedef, SpecTypedef), + (T.kwExtern, SpecExtern), + (T.kwStatic, SpecStatic), + (T.kwRegister, SpecRegister) + ] + + val cmp = (fn tk' => case tk of Tk tk => tk = tk' | _ => false) + val cmp2 = (fn (tk', _) => case tk of Tk tk => tk = tk' | _ => false) + in + case List.find cmp typeSpecs of + SOME tk => (SOME (TypeSpec tk, pos), ctx') + | NONE => ( + case List.find cmp2 storageSpecs of + SOME (_, spec) => (SOME (StorageSpec spec, pos), ctx') + | NONE => (NONE, ctx) + ) + end + + fun parseDeclPrefix ctx = + let + fun collect ctx (storSpec, typeReprId) = + let + val (spec, ctx) = tryGetSpec ctx + in + case spec of + NONE => + if typeReprId = 0 then + let + val (_, pos, _) = getTokenCtx ctx + in + P.error pos `"expected type specifier" % + end + else + ((storSpec, typeRepr2type typeReprId), ctx) + | SOME (StorageSpec spec, pos) => ( + case storSpec of + NONE => collect ctx (SOME spec, typeReprId) + | SOME _ => + P.error pos `"storage specifier is already provided" % + ) + | SOME (TypeSpec tk, pos) => + collect ctx (storSpec, advanceTypeRepr typeReprId (tk, pos)) + end + in + collect ctx (NONE, 0) + end + + datatype declParts = + Pointer of int | + Id of int * P.tkPos | + FuncApp of (int option * P.tkPos * ctype) list | + ArrayApplication + + fun Ppart (out, part) = + case part of + Pointer plevel => Printf out `"[" I plevel `"] " % + | Id _ => Printf out `"id" % + | FuncApp _ => Printf out `"()" % + | ArrayApplication => Printf out `"[]" % + + fun parseFuncParams ctx = + let + fun collect ctx acc = + let + val (prefix, ctx) = parseDeclPrefix ctx + val (parts, ctx) = parseDeclarator (false, true) [] ctx + val declaredId = assembleDeclarator prefix parts + + val (tk, pos, ctx) = getTokenCtx ctx + in + case tk of + Tk T.EOS => (rev $ declaredId :: acc, ctx) + | Tk T.Comma => collect ctx (declaredId :: acc) + | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.RParen] + end + + fun collect2 () = + let + val (tk, _, _) = getTokenCtx ctx + in + case tk of + Tk T.EOS => ([], ctx) + | _ => collect ctx [] + end + + val (params, ctx) = collect2 () + val params = + map (fn ((id, pos), _, ctype, _) => (id, pos, ctype)) params + in + (FuncApp params, ctx) + end + + and parseDDeclarator (untilEnd, abstractOk) ctx parts = + let + val (tk, pos, ctx) = getTokenCtx ctx + + val (parts, ctx) = + case tk of + Tk (T.Id id) => (Id (id, pos) :: parts, ctx) + | TkParens list => ctxWithLayer ctx list + (fn ctx => parseDeclarator (true, abstractOk) parts ctx) + | _ => P.clerror pos [P.Cid, P.Ctk T.LParen] + + fun collectTail parts ctx = + let + val (tk, pos, ctx') = getTokenCtx ctx + + fun % ctx list f parts = + let + val (part, ctx) = ctxWithLayer ctx list (fn ctx => f ctx) + in + collectTail (part :: parts) ctx + end + in + case tk of + TkParens list => % ctx' list parseFuncParams parts + | TkBrackets _ => collectTail (ArrayApplication :: parts) ctx' + | Tk T.EOS => (parts, ctx) + | _ => + if untilEnd then + P.clerror pos [P.Ctk T.LParen, P.Ctk T.RParen] + else + (parts, ctx) + end + in + collectTail parts ctx + end + + and parseDeclarator conf parts ctx = + let + fun collectPointer plevel ctx = + let + val (tk, pos, ctx') = getTokenCtx ctx + in + case tk of + Tk T.Asterisk => collectPointer (plevel + 1) ctx' + | Tk T.kwConst => P.error pos `"const is not supported" % + | Tk T.kwVolatile => P.error pos `"volatile is not supported" % + | _ => (plevel, ctx) + end + + val (plevel, ctx) = collectPointer 0 ctx + val (parts, ctx) = parseDDeclarator conf ctx parts + in + (if plevel > 0 then + Pointer plevel :: parts + else + parts, ctx) + end + + and assembleDeclarator (storSpec, ctype) parts = + let + val parts = rev parts + + val (id, pos) = + case hd parts of + Id (id, pos) => (id, pos) + | _ => raise Unreachable + + fun complete (Pointer plevel :: tail) = + pointer_t (plevel, complete tail) + | complete (FuncApp params :: tail) = + let + (* TODO: check params uniqness *) + val params = map (fn (_, _, ctype) => ctype) params + in + function_t (complete tail, params) + end + | complete (ArrayApplication :: tail) = array_t (complete tail) + | complete [] = ctype + | complete _ = raise Unreachable + + val params = + case parts of + _ :: FuncApp p :: _ => SOME $ map (fn (id, pos, _) => (id, pos)) p + | _ => NONE + + val idType = complete $ tl parts + in + ((SOME id, pos), storSpec, idType, params) + end + + fun printDeclaredId ((id, _), storSpec, ctype, params) = + let + fun Pstor (_, NONE) = () + | Pstor (out, SOME s) = Printf out PstorSpec s % + in + printf A1 Pstor storSpec Popt P.? id `": " Pctype ctype `"\n" %; + case params of + NONE => () + | SOME params => ( + printf `"params: " %; + List.app (fn (id, _) => printf Popt P.?id `", " %) params; + printf `"\n" % + ) + end + + fun parseDeclaration ctx = + let + val (prefix, ctx) = parseDeclPrefix ctx + + fun collectDeclarators acc ctx = + let + val (parts, ctx) = parseDeclarator (false, false) [] ctx + val declaredId = assembleDeclarator prefix parts + + val (tk, pos, ctx) = getTokenCtx ctx + in + case tk of + Tk T.Comma => collectDeclarators (declaredId :: acc) ctx + | Tk T.Semicolon => (rev $ declaredId :: acc, ctx) + | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon] + end + in + collectDeclarators [] ctx + end + fun parseDef ctx = let - val (expr, ctx) = parseExpr ctx NONE - val () = printf A2 printExpr 0 expr % + val (decls, _) = parseDeclaration ctx in - (raise Unimplemented, ctx) + List.app (fn decl => printDeclaredId decl) decls; + raise Unimplemented end end |