Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!

AST_C_Target.hs

By: VictorCacciari on Feb 16th, 2012  |  syntax: Haskell  |  size: 7.66 KB  |  views: 117  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
This paste has a previous version, view the difference. Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. {-
  2.         This is the translator from the ASTCG to C source code,
  3.         every other translator should follow this template.
  4.         Since we have four AST specific data types, the translator must provide the following
  5.         four functions:
  6.        
  7.         translateField, translateNode, translateKind and translateProgram
  8.        
  9.         Since we're writing files, their type should be:
  10.         translateField :: ASTField -> Flag -> IO ()
  11.        
  12.         Where Flag is a custom type, the only restriction made here is that Flag should provide
  13.         a default value (Except for a ASTProgram, it must be ASTProgram -> IO()).
  14.        
  15.     Copyright (C) 2012 Victor Cacciari Miraldo
  16.  
  17.     This program is free software: you can redistribute it and/or modify
  18.     it under the terms of the GNU General Public License as published by
  19.     the Free Software Foundation, either version 3 of the License, or
  20.     (at your option) any later version.
  21.  
  22.     This program is distributed in the hope that it will be useful,
  23.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  24.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25.     GNU General Public License for more details.
  26.  
  27.     You should have received a copy of the GNU General Public License
  28.     along with this program.  If not, see <http://www.gnu.org/licenses/>.
  29. -}
  30. module AST_C_Target where
  31.  
  32. import AST
  33. import Char
  34.  
  35. data Flag = Decl | Imp | ParmDecl
  36.  
  37. flagDefault :: Flag
  38. flagDefault =  Decl
  39.  
  40. ident :: IO ()
  41. ident = putStr "\t"
  42.  
  43. identn :: Int -> IO()
  44. identn 1 = ident
  45. identn (n+1) = do {ident; identn n}
  46.  
  47. {-
  48.         A "field" in C is simply a declaration of a variable.
  49. -}
  50. translateField :: ASTField -> Flag -> IO ()
  51. translateField (ASTField _ n) Imp =
  52.         do { putStr (n ++ " = " ++ n ++ ";\n") }
  53. translateField (ASTField t n) ParmDecl =
  54.         do { putStr (t ++ " " ++ n) }
  55. translateField (ASTField t n) Decl =
  56.         do { putStr (t ++ " " ++ n ++ ";") }
  57.        
  58. {-
  59.         Now, a kind is somewhat more complex. It is different if we're inside the declaration module,
  60.         the implementation or declaring a parameter.
  61. -}
  62. translateKind :: ASTKind -> Flag -> IO()
  63. translateKind (ASTAtomKind f) Decl =
  64.         do { identn 2; translateField f Decl; putChar '\n' }
  65. translateKind (ASTAtomKind f) ParmDecl =
  66.         do { translateField f ParmDecl }
  67. translateKind (ASTAtomKind (ASTField _ n)) Imp =
  68.         do { ident; putStrLn ("__a->u." ++ n ++ " = " ++ n ++ ";") }
  69.  
  70. {-
  71.         We have some more complicated cases here:
  72.         For the following functions, we will ilustrate the output of the following kind:
  73.        
  74.         ASTKind "binop" [(ASTField "int" "op"), (ASTField "tree*" "lh"), (ASTField "tree*" "rh")]
  75.        
  76.         If it's a declaration, it should be:
  77.        
  78.                 struct {
  79.                         int op;
  80.                         tree* lh;
  81.                         tree* rh;
  82.                 } binop;
  83. -}
  84. translateKind (ASTKind n fields) Decl =
  85.         do
  86.         {       identn 2
  87.         ;       putStr "struct {\n"
  88.         ;       foldr (\h r -> do { identn 3; translateField h Decl; putChar '\n'; r }) (identn 2) fields
  89.         ;       putStr ("} " ++ n ++ ";\n")
  90.         }
  91.  
  92. {-
  93.         If we're inside a initializer:
  94.        
  95.         __a->u.binop.op = op;
  96.         __a->u.binop.lh = lh;
  97.         __a->u.binop.rh = rh;
  98. -}
  99. translateKind (ASTKind n fields) Imp =
  100.         do
  101.         {       foldr
  102.                 (\h r ->
  103.                         do
  104.                         {       ident
  105.                         ;       putStr ("__a->u." ++ n ++ ".")
  106.                         ;       translateField h Imp
  107.                         ;       r
  108.                         }
  109.                 ) (return ()) fields
  110.         }
  111.                                                                
  112. {-
  113.         And if we're dealing with a parameter declaration:
  114.        
  115.         int op, tree* lh, tree* rh
  116. -}
  117. translateKind (ASTKind _ fields) ParmDecl =
  118.         translateParmFieldList fields
  119.  
  120. translateParmFieldList :: [ASTField] -> IO ()
  121. translateParmFieldList fields =
  122.         do
  123.         {       case pushLast fields of
  124.                         (l:tt) ->
  125.                                 foldr
  126.                                 (\h r ->
  127.                                         do
  128.                                         {       translateField h ParmDecl
  129.                                         ;       putStr ", "
  130.                                         ;       r
  131.                                         }
  132.                                 ) (translateField l ParmDecl) tt
  133.                         [] -> return ()
  134.         }
  135.         where
  136.                 pushLast [] = []
  137.                 pushLast [x] = [x]
  138.                 pushLast [x,y] = [y,x]
  139.                 pushLast (h:t) = let (k:ks) = pushLast t in k:h:ks
  140.                
  141. {-
  142.         Ok, we're finally in the node part, this is not hard. Let's consider the following
  143.         node to illustrate our functions:
  144.                
  145.                 ASTNode "Exp" [(ASTField "int" "line")] kindlist
  146.                
  147.         This, in the declaration should become:
  148.        
  149.         struct Exp_st {
  150.                 enum ExpKind_t kind;
  151.                 int line;
  152.                 translate(kindlist)
  153.         };
  154. -}
  155.  
  156. -- Just a simple auxiliar to handle the function prototype name.
  157. translateNodeFuncPrototype :: ASTNode -> ASTKind -> IO ()
  158. translateNodeFuncPrototype (ASTNode name fields kinds) k =
  159.         do
  160.         {       putStr (name ++ "*\t")
  161.         ;       putStr ((map toLower name) ++ "_" ++ (kindName k) ++ "_new(")
  162.         ;       translateParmFieldList (fields ++ (kindFields k))
  163.         ;       putChar ')'
  164.         }
  165.  
  166. translateNode :: ASTNode -> Flag -> IO ()
  167. translateNode node@(ASTNode name fields []) Decl =
  168.         do
  169.         {       putStr ("struct " ++ name ++ "_st {\n")
  170.         ;       foldr (\h r -> do { ident ; translateField h Decl; putChar '\n'; r }) (return ()) fields
  171.         ;       putStr "};\n\n\n"
  172.         ;       putStr (name ++ "*\t")
  173.         ;       putStr ((map toLower name) ++ "_new(")
  174.         ;       translateParmFieldList fields
  175.         ;       putStr ");\n"
  176.         }
  177.  
  178. translateNode node@(ASTNode name fields kinds) Decl =
  179.         do
  180.         {       putStr ("struct " ++ name ++ "_st {\n")
  181.         ;       putStr ("\tenum " ++ name ++ "Kind_t kind;\n")
  182.         ;       foldr (\h r -> do { ident ; translateField h Decl; putChar '\n'; r }) (return ()) fields                       
  183.         ;       putStr "\tunion {\n"
  184.         ;       foldr (\h r -> do { translateKind h Decl; r }) (return ()) kinds
  185.         ;       putStr "\t} u;\n"
  186.         ;       putStr "};\n\n\n"
  187.         {-
  188.         Cool, we're almost there.
  189.         Now, we need the whole function declaration
  190.         We want something like:
  191.  
  192.                 Exp*    exp_binop_new(int line, int binop, tree* lh, tree* rh);
  193.  
  194.         For each different kind!
  195.         -}
  196.         ;       foldr (\k r ->
  197.                                 do
  198.                                 {       translateNodeFuncPrototype node k
  199.                                 ;       putStr ";\n"
  200.                                 ;       r
  201.                                 }
  202.                 ) (return ()) kinds
  203.         ;       putStr "\n\n"
  204.         }
  205.        
  206. {-
  207.         Now we are going to actually implement every function, this is the
  208.         time consuming task.
  209. -}
  210. translateNode node@(ASTNode name fields []) Imp =
  211.         do
  212.         {       putStr (name ++ "*\t")
  213.         ;       putStr ((map toLower name) ++ "_new(")
  214.         ;       translateParmFieldList fields
  215.         ;       putStr ")\n{\n"
  216.         ;       putStr (name ++ "* __a = ALLOC(" ++ name ++ ");\n\n")
  217.         ;       foldr (\f r -> do { putStr "\t__a->"; translateField f Imp; r }) (return ()) fields
  218.         ;       putStr "\n\treturn __a;\n}\n\n"
  219.         }
  220.        
  221. translateNode node@(ASTNode name fields kinds) Imp =
  222.         foldr (\k r ->
  223.                 do
  224.                 {       translateNodeFuncPrototype node k
  225.                 ;       putStr "\n{\n"
  226.                 ;       putStr (name ++ "* __a = ALLOC(" ++ name ++ ");\n\n")
  227.                 ;       putStr ("\t__a->kind = " ++ (map toUpper (name ++ "_" ++ (kindName k))) ++ ";\n")
  228.                 ;       foldr (\f r -> do { putStr "\t__a->"; translateField f Imp; r }) (return ()) fields
  229.                 ;       translateKind k Imp
  230.                 ;       putStr "\n\treturn __a;\n}\n\n"
  231.                 ;       r
  232.                 }
  233.         ) (return ()) kinds
  234.        
  235. {-
  236.         Ok, now it comes the final part, how do we translate a program?
  237.         Let's imagine the following program:
  238.        
  239.         ASTProgram  header footer [ExpNode]
  240.                
  241.         We want something like:
  242.        
  243.                         header
  244.        
  245.                         typedef struct Exp_st Exp;
  246.        
  247.                         struct Exp_st
  248.                         { ... }
  249.        
  250.                         Exp* exp_ ...
  251.                         ...
  252.        
  253.                         footer
  254.                        
  255.                         implementations
  256. -}
  257. translateProgram :: ASTProgram -> IO ()
  258. translateProgram (ASTProgram header footer nodes) =
  259.         do
  260.         {       putStr header
  261.         ;       foldr (\(ASTNode n _ _) r ->
  262.                                 do { putStr ("typedef struct " ++ n ++ "_st " ++ n ++ ";\n"); r }
  263.                                 ) (return ()) nodes
  264.         ;       putStr "\n\n/* E N U M S */\n"
  265.         ;       foldr (\n r -> do { genEnum n ; r }) (return ()) nodes
  266.         ;       putStr "\n\n/* D E C L A R A T I O N S */\n\n"
  267.         ;       foldr (\h r -> do { translateNode h Decl ; r }) (return ()) nodes
  268.         ;       putStr "\n\n"
  269.         ;       putStr footer
  270.         ;       foldr (\h r -> do { translateNode h Imp ; r }) (return ()) nodes
  271.         }
  272.        
  273. genEnum :: ASTNode -> IO ()
  274. genEnum (ASTNode _ _ []) = return ()
  275. genEnum (ASTNode name _ (kh:kinds)) =
  276.         do
  277.         {       putStr ("enum " ++ name ++ "Kind_t {\n")
  278.         ;       foldr (\k r ->
  279.                         do { putStr ("\t" ++ (map toUpper (name ++ "_" ++ (kindName k))) ++ ",\n"); r}
  280.                 ) (putStr ("\t" ++ (map toUpper (name ++ "_" ++ (kindName kh))) ++ "};\n")) kinds
  281.         }
clone this paste RAW Paste Data