diff options
| -rw-r--r-- | common.sml | 26 | ||||
| -rw-r--r-- | emit.fun | 76 | ||||
| -rw-r--r-- | parser.fun | 11 |
3 files changed, 70 insertions, 43 deletions
@@ -4,6 +4,32 @@ fun $ (x, y) = x y infixr 0 $ fun id x = x +val compare = fn a => fn b => Int.compare (a, b) + +fun sort _ [] = [] + | sort _ [x] = [x] + | sort le l = + let + fun divide [] accp = accp + | divide [x] (acc1, acc2) = (x :: acc1, acc2) + | divide (x :: y :: tail) (acc1, acc2) = + divide tail (x :: acc1, y :: acc2) + val (part1, part2) = divide l ([], []) + val part1 = sort le part1 + val part2 = sort le part2 + + fun merge [] [] acc = acc + | merge [] ys acc = rev $ List.revAppend (ys, acc) + | merge xs [] acc = rev $ List.revAppend (xs, acc) + | merge (x :: xs) (y :: ys) acc = + if le (x, y) then + merge xs (y :: ys) (x :: acc) + else + merge (x :: xs) ys (y :: acc) + in + merge part1 part2 [] + end + fun assert truth = if not truth then raise Unreachable else () structure Fold = struct @@ -149,31 +149,57 @@ functor Emit(I: IL) = struct fun handleStrlits strlits = let + fun unique l = + let + val l = sort (op <=) l + fun u [] acc = rev acc + | u (x :: xs) [] = u xs [x] + | u (x :: xs) (y :: ys) = + if x = y then + u xs (y :: ys) + else + u xs (x :: y :: ys) + in + u l [] + end + fun emitStrlit id = let - val () = fprint `".S" I id `":\t" % val symbols = PP.T.strlit2charList (PP.?? id) - fun pc c out = - if Char.isPrint c andalso not (Char.isSpace c) then - Printf out `"'" C c `"'" % + datatype strPart = SpStr of string | SpOrd of int + + open Char + + fun collectStr (c :: cs) acc = + if isPrint c andalso (c = #" " orelse not (isSpace c)) then + collectStr cs (c :: acc) else - Printf out I (ord c) % + let + val p = SpOrd (ord c) + val l = collectStr cs [] + in + if null acc then l else SpStr (implode $ rev acc) :: p :: l + end + | collectStr [] acc = + if null acc then [] else [SpStr (implode $ rev acc)] - fun outputStrlit (c :: []) = fprint A1 pc c % - | outputStrlit [] = raise Unreachable - | outputStrlit (c :: cs) = ( - fprint A1 pc c `", " %; - outputStrlit cs - ) + fun printPart (SpStr s) out = Printf out `"'" `s `"'" % + | printPart (SpOrd v) out = Printf out I v % + fun printStr [] = () + | printStr (p :: ps) = (fprint A1 printPart p `", " %; printStr ps) + + val parts = collectStr symbols [] in + fprint `".S" I id `":\t" %; fprint `"db " %; - outputStrlit symbols + List.app (fn p => fprint A1 printPart p `", " %) parts; + fprint `"0\n" % end in fprint `"\n" %; - List.app emitStrlit strlits + List.app emitStrlit (unique strlits) end fun handleLocalIniLayouts () = @@ -490,30 +516,6 @@ functor Emit(I: IL) = struct Array.appi p rinfo end - fun sort _ [] = [] - | sort _ [x] = [x] - | sort le l = - let - fun divide [] accp = accp - | divide [x] (acc1, acc2) = (x :: acc1, acc2) - | divide (x :: y :: tail) (acc1, acc2) = - divide tail (x :: acc1, y :: acc2) - val (part1, part2) = divide l ([], []) - val part1 = sort le part1 - val part2 = sort le part2 - - fun merge [] [] acc = acc - | merge [] ys acc = rev $ List.revAppend (ys, acc) - | merge xs [] acc = rev $ List.revAppend (xs, acc) - | merge (x :: xs) (y :: ys) acc = - if le (x, y) then - merge xs (y :: ys) (x :: acc) - else - merge (x :: xs) ys (y :: acc) - in - merge part1 part2 [] - end - fun updateI i = fn z => let fun from rinfo active pool intervals stackOff = @@ -272,9 +272,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; strlits: int list } - val intCompare = fn a => fn b => Int.compare (a, b) - val lookup = fn z => Tree.lookup intCompare z - val lookup2 = fn z => Tree.lookup2 intCompare z + val lookup = fn z => Tree.lookup compare z + val lookup2 = fn z => Tree.lookup2 compare z fun updateCtx (Ctx ctx) = fn z => let @@ -2621,7 +2620,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; = let val newBufId = D.length types - val (_, aggrTypeNames) = Tree.insert intCompare aggrTypeNames id newBufId + val (_, aggrTypeNames) = Tree.insert compare aggrTypeNames id newBufId val status = if isSome body then "complete" else "incomplete" @@ -3347,7 +3346,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val () = D.push localVars ({ name = id, pos, t, onStack = not $ isScalar t }) - val (_, scope) = Tree.insert intCompare scope id varId + val (_, scope) = Tree.insert compare scope id varId in (varId, id, updateCtx (Ctx ctx) u#localScopes (fn scs => scope :: tl scs) %) @@ -3844,7 +3843,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; = let val localVar = { name = id, pos, t, onStack = false } - val (_, scope) = Tree.insert intCompare scope id curVarId + val (_, scope) = Tree.insert compare scope id curVarId in D.push localVars localVar; createLocalVars scope (curVarId + 1) ts params |