module Gen where import Prelude hiding (lookup) import Data.Map hiding (map) import Text.PrettyPrint import Data genVal :: Int -> Int -> String genVal i j = "__" ++ "val" ++ "_" ++ show i ++ "_" ++ show j genRes :: Int -> Int -> String genRes i j = "__" ++ "res" ++ "_" ++ show i ++ "_" ++ show j fname :: String -> String fname cs = "aurochs_" ++ cs genLabel :: String -> String genLabel cs = "label_" ++ cs genIfElse doc1 doc2 doc3 = genIf doc1 doc2 $$ text "else{" $+$ nest 4 doc3 $$ text "}" genIf doc1 doc2 = text "if(" <> doc1 <> text "){" $+$ nest 4 doc2 $$ text "}" genIncludes :: Doc genIncludes = text "#include" $$ text "#include" $$ text "#include" $$ text "#include" genInit :: Table -> Doc genInit table = (text ("void auinit(char *s)") $$ text "{") $+$ nest 4 (genI table) $$ text "}" where genI table = text "int i;" $$ text "int tsize;" $$ text "size = strlen(s);" $$ text "tsize = size + 1;" $$ text "fill_table = (struct Item_fill *)malloc(sizeof(struct Item_fill) * tsize);" $$ text "pos_table = (struct Item_pos *)malloc(sizeof(struct Item_pos) * tsize);" $$ text "val_table = (struct Item_val *)malloc(sizeof(struct Item_val) * tsize);" $$ text "for(i = 0; i <= size; i++){" $+$ nest 4 (vcat (map genSetZero (toList table))) $$ text "}" where genSetZero (name, _) = text ("fill_table[i]." ++ name ++ " = FALSE;") genExit :: Doc genExit = (text ("void auexit()") $$ text "{") $+$ nest 4 (text "free(fill_table);" $$ text "free(pos_table);" $$ text "free(val_table);") $$ text "}" genEntry :: Table -> String -> Doc genEntry table name = case lookup name table of Just t -> (text (t ++ " auentry(char* s)") $$ text "{") $+$ nest 4 (text "int errpos = 0;" $$ text "auinit(s);" $$ text ("struct Res_" ++ name ++ " res = " ++ fname name ++ "(0, s, &errpos);") $$ text "if(res.pos == -1){" $+$ nest 4 ((text "printf (\"Parse error at %d: unexpected '%c'.\", errpos, s[errpos]);") $$ (text "exit(1);")) $$ text "}" $$ text "auexit();" $$ text "return res.val;") $$ text "}" Nothing -> error $ "Impossible thing happens in genEntry: no type declaration for " ++ name genGlobalDcls :: Table -> Doc genGlobalDcls table = text "#define TRUE 1" $$ text "#define FALSE 0" $$ text "int size;" $$ genGD (toList table) where genGD nts = genRes nts $$ genTables nts $$ genFDcls nts genRes nts = vcat (map genR nts) genR (name, t) = text ("struct Res_" ++ name ++ "{") $+$ nest 4 (text ("int pos;") $$ text (t ++ " " ++ "val;")) $$ text "};" genTables nts = genFillTable nts $$ genPosTable nts $$ genValTable nts $$ text "struct Item_fill* fill_table;" $$ text "struct Item_pos* pos_table;" $$ text "struct Item_val* val_table;" genFillTable nts = text ("struct Item_fill{") $+$ nest 4 (genFTable nts) $$ text "};" genPosTable nts = text ("struct Item_pos{") $+$ nest 4 (genPTable nts) $$ text "};" genValTable nts = text ("struct Item_val{") $+$ nest 4 (genVTable nts) $$ text "};" genFTable nts = vcat (map genFT nts) genFT (name, _) = text ("int" ++ " " ++ name ++ ";") genPTable nts = vcat (map genPT nts) genPT (name, t) = text ("int" ++ " " ++ name ++ ";") genVTable nts = vcat (map genVT nts) genVT (name, t) = text (t ++ " " ++ name ++ ";") genFDcls nts = vcat (map genFD nts) genFD (name, t) = text ("struct Res_" ++ name ++ " " ++ fname name) <> parens (text "int pos, char* s, int* errp") <> text ";" gen :: Table -> Generator -> Doc gen table g@(Generator name body) = ((text $ "struct Res_" ++ name) <+> text (fname name) <> parens (text "int pos, char* s, int *errp") $$ text "{") $+$ nest 4 (genA name body) $$ text "}" where genA name body = text ("struct Res_" ++ name ++ " res;") $$ genD body 0 $$ genHead name $$ genAux name body 0 genD body i = text "int __pos;" $$ text "int __oldpos;" $$ (case lookup name table of Just t -> text (t ++ " __oldval;") Nothing -> error $ "Impossible thing happens in genD: no type declaration for " ++ name) $$ text "char c;" $$ genDcls body i genDcls [] i = text "" genDcls ((matches, _) : dcls) i = genDcl matches i 0 $$ genDcls dcls (i + 1) genDcl (Normal tokens) i j = genDclNormal tokens i j genDcl (ChainL _ opToken token) i j = genDclChain opToken token i j genDclNormal [] i j = text "" genDclNormal (NonTerminal cs : tokens) i j = (case lookup cs table of Just ts -> text (ts ++ " " ++ genVal i j ++ ";") Nothing -> error $ "Impossible thing happens in genDclNormal: no type declaration for " ++ cs) $$ genDclNormal tokens i (j + 1) genDclNormal (Terminal _ : tokens) i j = text ("char " ++ genVal i j ++ ";") $$ genDclNormal tokens i (j + 1) genDclChain (NonTerminal opCs) (NonTerminal cs) i j = (case lookup opCs table of Just ts -> text (ts ++ " " ++ genVal i (j + 1) ++ ";") Nothing -> error $ "Impossible thing happens in genDclChain: no type declaration for " ++ opCs) $$ (case lookup cs table of Just ts -> text (ts ++ " " ++ genVal i j ++ ";") Nothing -> error $ "Impossible thing happens in genDclChain: no type declaration for " ++ cs) genDclChain (Terminal _) (NonTerminal cs) i j = text ("char " ++ genVal i (j + 1) ++ ";") $$ (case lookup cs table of Just ts -> text (ts ++ " " ++ genVal i j ++ ";") Nothing -> error $ "Impossible thing happens in genDclChain: no type declaration for " ++ cs) genDclChain (NonTerminal opCs) (Terminal _) i j = (case lookup opCs table of Just ts -> text (ts ++ " " ++ genVal i (j + 1) ++ ";") Nothing -> error $ "Impossible thing happens in genDclChain: no type declaration for " ++ opCs) $$ text ("char " ++ genVal i j ++ ";") genDclChain (Terminal _) (Terminal _) i j = text ("char " ++ genVal i (j + 1) ++ ";") $$ text ("char " ++ genVal i j ++ ";") genHead name = genIf (text $ "fill_table[pos]." ++ name ++ " == TRUE") (vcat $ map text ["res.pos = pos_table[pos]." ++ name ++ ";", "res.val = val_table[pos]." ++ name ++ ";", "return res;" ]) genAux name [] i = vcat $ map text [genLabel (name ++ "_" ++ show i) ++ ":", "res.pos = -1;", -- "res.value.errpos = pos;", "return res;" ] genAux name (branch : body) i = genB name branch i $$ genAux name body (i + 1) genB name branch i = (text $ genLabel (name ++ "_" ++ show i) ++ ":") $$ text ("__pos = pos;") $$ genBranch name branch i genBranch name (matches, actions) i = genMatches name matches i 0 $$ genAct name actions i where genMatches name (Normal tokens) i j = genNormal name tokens i j genMatches name (ChainL op opToken token) i j = genChainL name op opToken token i j genNormal name [] i j = text "" genNormal name (Terminal cs : tokens) i j = genTerminal name cs i j $$ genNormal name tokens i (j + 1) genNormal name (NonTerminal cs : tokens) i j = genNonTerminal name cs i j $$ genNormal name tokens i (j + 1) genNonTerminal name cs i j = genNonTerminalAux name cs i j (genNext i) genTerminal name cs i j = genTerminalAux name cs i j (genNext i) genNext i = text ("*errp = __pos;") $$ text ("goto " ++ genLabel (name ++ "_" ++ show (i + 1)) ++ ";") genNonTerminalAux name cs i j doc = (vcat $ map text ["Res_" ++ cs ++ " " ++ genRes i j ++ " = " ++ fname cs ++ "(" ++ "__pos" ++ ", s, errp);", "__pos" ++ " = " ++ genRes i j ++ ".pos;", genVal i j ++ " = " ++ genRes i j ++ ".val;" ]) $$ genIf (text $ "__pos" ++ " == -1") doc genTerminalAux name cs i j doc = genIf (text $ "__pos" ++ " >= size") doc $$ (text $ "c = s[" ++ "__pos" ++ "];") $$ genIf (text $ "!" ++ cs ++ "(c)") doc $$ (vcat $ map text ["__pos" ++ " = " ++ "__pos" ++ " + 1;", genVal i j ++ " = c;" ]) genChainL name op opToken token i j = genChainLAux name op (toGen opToken) (toGen token) i j toGen (Terminal cs) = (genTerminalAux, cs) toGen (NonTerminal cs) = (genNonTerminalAux, cs) genChainLAux name op (opTokenGen, opCs) (tokenGen, cs) i j = tokenGen name cs i j (text $ "goto " ++ genLabel (name ++ "_" ++ show (i + 1)) ++ ";") $$ text "__oldpos = __pos;" $$ text ("__oldval = " ++ genVal i j ++ ";") $$ text "while(TRUE){" $+$ nest 4 (opTokenGen name opCs i (j + 1) ((text $ "__pos = __oldpos;") $$ (text $ genVal i j ++ " = __oldval;") $$ (text $ "break;")) $$ tokenGen name cs i j ((text $ "__pos = __oldpos;") $$ (text $ genVal i j ++ " = " ++ "__oldval;") $$ (text $ "break;")) $$ text "__oldpos = __pos;" $$ text ("__oldval = " ++ op ++ "(__oldval, " ++ genVal i j ++ ");")) $$ text "}" genAct name actions i = (text $ "res.pos = " ++ "__pos" ++ ";") $$ ((text $ "res.val = (") <> genActions name actions i <> text ");") $$ (vcat $ map text ["fill_table[pos]." ++ name ++ " = TRUE;", "pos_table[pos]." ++ name ++ " = " ++ "__pos;", "val_table[pos]." ++ name ++ " = " ++ "res.val;", "return res;" ]) genActions name [] i = text "" genActions name (Match j : actions) i = genMatch name i j <> genActions name actions i genActions name (Fill cs : actions) i = genFill cs <> genActions name actions i genMatch name i j = text $ genVal i j genFill cs = text cs genProg header table name gs extra = genIncludes $$ text header $$ genGlobalDcls table $$ genInit table $$ genExit $$ vcat (map (gen table) gs) $$ genEntry table name $$ text extra testTable = fromList [("exp", "int"), ("num", "int"), ("epsilon", "int"), ("digit", "int")] --test = genProg "" testTable "exp" [--(Generator "num" "int" [(Normal [Terminal "isdigit", NonTerminal "num"], -- [Fill "(int)(", Match 0, Fill "- '0')", Fill "+", Match 1, Fill "* 10"]), -- (Normal [],[Fill "0"]) -- ]), -- (Generator "exp" [(ChainL "add" (Terminal "isaddop") (NonTerminal "num"), [Match 0])]), -- (Generator "num" [(ChainL "addnum" (NonTerminal "epsilon") (NonTerminal "digit"), [Match 0])]), -- (Generator "epsilon" [(Normal [], [Fill "0"])]), -- (Generator "digit" [(Normal [Terminal "isdigit"], [Fill "(int)(", Match 0, Fill "-'0')"])])] -- testIfElse = genIfElse (text "a") (text "b") (text "c")