summaryrefslogtreecommitdiff
path: root/src/tools/c/gfcc2c.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/tools/c/gfcc2c.hs')
-rw-r--r--src/tools/c/gfcc2c.hs223
1 files changed, 223 insertions, 0 deletions
diff --git a/src/tools/c/gfcc2c.hs b/src/tools/c/gfcc2c.hs
new file mode 100644
index 000000000..75eb10fb8
--- /dev/null
+++ b/src/tools/c/gfcc2c.hs
@@ -0,0 +1,223 @@
+import GFCC.Abs
+import GFCC.ErrM
+import GFCC.Lex
+import GFCC.Par
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Numeric
+import System.Environment
+import System.Exit
+import System.IO
+
+constrType :: Grammar -> String
+constrType g = unlines $
+ ["typedef enum { "]
+ ++ map (\x -> " " ++ x ++ "," ) ds
+ ++ ["} Fun;"]
+ where fs = [id2c n | (n,_) <- constructors g ]
+ ds = case fs of
+ [] -> []
+ (x:xs) -> (x ++ " = ATOM_FIRST_FUN"):xs
+
+mkFunSigs :: Grammar -> String
+mkFunSigs g = unlines [mkFunSig n ats | (n,(ats,_)) <- constructors g]
+
+mkFunSig :: CId -> [CId] -> String
+mkFunSig n ats =
+ "extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ");"
+ where
+ adecls = map ("Tree *" ++) args
+ args = [ "x" ++ show x | x <- [0..c-1] ]
+ c = length ats
+
+mkFuns :: Grammar -> String
+mkFuns g = unlines [mkFun n ats | (n,(ats,_)) <- constructors g]
+
+mkFun :: CId -> [CId] -> String
+mkFun n ats = unlines $
+ ["extern Tree *mk_" ++ id2c n ++ "(" ++ commaSep adecls ++ ") {",
+ " Tree *t = tree_fun(" ++ id2c n ++ "," ++ show c ++ ");"]
+ ++ [" tree_set_child(" ++ commaSep ["t",show i, args!!i] ++ ");" | i <- [0..c-1]]
+ ++ [" return t;",
+ "}"]
+ where
+ adecls = map ("Tree *" ++) args
+ args = [ "x" ++ show x | x <- [0..c-1] ]
+ c = length ats
+
+doDie :: String -> [String] -> [String]
+doDie s args = ["fprintf(" ++ commaSep ("stderr":show s':args) ++ ");",
+ "exit(1);"]
+ where s' = "Error: " ++ s ++ "\n"
+
+mkLin :: Grammar -> CId -> String
+mkLin g l = unlines $
+ ["extern Term *" ++ langLinName_ l ++ "(Tree *t) {",
+ " Term **cs = NULL;",
+ " int n = arity(t);",
+ " if (n > 0) {",
+ " int i;",
+ " cs = (Term**)term_alloc(n * sizeof(Term *));", -- FIXME: handle failure
+ " for (i = 0; i < n; i++) {",
+ " cs[i] = " ++ langLinName_ l ++ "(tree_get_child(t,i));",
+ " }",
+ " }",
+ "",
+ " switch (t->type) {",
+ " case ATOM_STRING: return term_str(t->value.string_value);",
+-- " case ATOM_INTEGER: return NULL;", -- FIXME!
+-- " case ATOM_DOUBLE: return NULL;", -- FIXME!
+ " case ATOM_META: return term_meta();"]
+ ++ [" case " ++ id2c n ++ ": return " ++ linFunName n ++ "(cs);"
+ | (n,_) <- constructors g]
+ ++ [" default: "]
+ ++ map (" " ++) (doDie (langLinName_ l ++ " %d") ["t->type"])
+ ++ [" return NULL;",
+ " }",
+ "}",
+ "",
+ "extern Term *" ++ langLinName l ++ "(Tree *t) {",
+ " Term *r;",
+ " term_alloc_pool(1000000);", -- FIXME: size?
+ " r = " ++ langLinName_ l ++ "(t);",
+ " /* term_free_pool(); */", -- FIXME: copy term?
+ " return r;",
+ "}"]
+
+langLinName :: CId -> String
+langLinName n = id2c n ++ "_lin"
+
+langLinName_ :: CId -> String
+langLinName_ n = id2c n ++ "_lin_"
+
+linFunName :: CId -> String
+linFunName n = "lin_" ++ id2c n
+
+
+mkLinFuns :: [CncDef] -> String
+mkLinFuns cs = unlines $ map mkLinFunSig cs ++ [""] ++ map mkLinFun cs
+
+mkLinFunSig :: CncDef -> String
+mkLinFunSig (Lin n t) =
+ "static Term *" ++ linFunName n ++ "(Term **cs);"
+
+mkLinFun :: CncDef -> String
+mkLinFun (Lin (CId n) t) | "__" `isPrefixOf` n = ""
+mkLinFun (Lin n t) = unlines [
+ "static Term *" ++ linFunName n ++ "(Term **cs) {",
+ " return " ++ term2c t ++ ";",
+ "}"
+ ]
+
+term2c :: Tree a -> String
+term2c t = case t of
+ -- terms
+ R terms -> fun "term_array" terms
+ -- an optimization of t!n where n is a constant int
+ P term0 (C n) -> "term_sel_int("++ term2c term0 ++ "," ++ show n ++ ")"
+ P term0 term1 -> "term_sel(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
+ S terms -> fun "term_seq" terms
+ K tokn -> term2c tokn
+ V n -> "cs[" ++ show n ++ "]"
+ C n -> "term_int(" ++ show n ++ ")"
+ F cid -> linFunName cid ++ "(cs)"
+ FV terms -> fun "term_variants" terms
+ W str term -> "term_suffix(" ++ string2c str ++ "," ++ term2c term ++ ")"
+ RP term0 term1 -> "term_rp(" ++ term2c term0 ++ "," ++ term2c term1 ++ ")"
+ TM -> "term_meta()"
+ -- tokens
+ KS s -> "term_str(" ++ string2c s ++ ")"
+ KP strs vars -> error $ show t -- FIXME: pre token
+ _ -> error $ show t
+ where fun f ts = f ++ "(" ++ commaSep (show (length ts):map term2c ts) ++ ")"
+
+commaSep = concat . intersperse ","
+
+
+id2c :: CId -> String
+id2c (CId s) = s -- FIXME: convert ticks
+
+string2c :: String -> String
+string2c s = "\"" ++ concatEsc (map esc s) ++ "\""
+ where
+ esc c | isAscii c && isPrint c = [c]
+ esc '\n' = "\\n"
+ esc c = "\\x" ++ map toUpper (showHex (ord c) "")
+ concatEsc [] = ""
+ concatEsc (x:xs) | length x <= 2 = x ++ concatEsc xs
+ | otherwise = x ++ "\" \"" ++ concatEsc xs
+
+lang2file :: CId -> String -> String
+lang2file n ext = id2c n ++ "." ++ ext
+
+constructors :: Grammar -> [(CId, ([CId],CId))]
+constructors (Grm _ (Abs ads) _) = [(n,(ats,rt)) | Fun n (Typ ats rt) _ <- ads]
+
+absHFile :: Grammar -> FilePath
+absHFile (Grm (Hdr a _) _ _) = lang2file a "h"
+
+cncHFile :: Concrete -> FilePath
+cncHFile (Cnc l _) = lang2file l "h"
+
+mkAbsH :: Grammar -> String
+mkAbsH g = unlines ["#include \"gfcc-tree.h\"",
+ "#include \"gfcc-term.h\"",
+ constrType g,
+ "",
+ mkFunSigs g]
+
+mkAbsC :: Grammar -> String
+mkAbsC g = unlines [include (absHFile g),
+ "",
+ mkFuns g]
+
+mkCncH :: Grammar -> Concrete -> String
+mkCncH g (Cnc l _) = unlines
+ [include (absHFile g),
+ "",
+ "extern Term *" ++ langLinName l ++ "(Tree *);"]
+
+mkCncC :: Grammar -> Concrete -> String
+mkCncC g c@(Cnc l cds) = unlines $
+ ["#include <stdio.h>",
+ "#include <stdlib.h>",
+ include (cncHFile c),
+ ""]
+ ++ [mkLinFuns cds, mkLin g l]
+
+mkH :: FilePath -> String -> (FilePath, String)
+mkH f c = (f, c')
+ where c' = unlines ["#ifndef " ++ s, "#define " ++ s, "", c, "#endif"]
+ s = [if x=='.' then '_' else toUpper x | x <- f]
+
+include :: FilePath -> String
+include f = "#include " ++ show f
+
+-- returns list of file name, file contents
+gfcc2c :: Grammar -> [(FilePath, String)]
+gfcc2c g@(Grm (Hdr a _) _ cs) =
+ [mkH (absHFile g) (mkAbsH g), (lang2file a "c", mkAbsC g)]
+ ++ concat [[mkH (cncHFile cnc) (mkCncH g cnc),(lang2file c "c", mkCncC g cnc)] | cnc@(Cnc c _) <- cs]
+
+parse :: String -> Err Grammar
+parse = pGrammar . myLexer
+
+die :: String -> IO ()
+die s = do hPutStrLn stderr "Usage: gfcc2c <gfcc file>"
+ exitFailure
+
+createFile :: FilePath -> String -> IO ()
+createFile f c = do hPutStrLn stderr $ "Writing " ++ f ++ "..."
+ writeFile f c
+
+main :: IO ()
+main = do args <- getArgs
+ case args of
+ [file] -> do c <- readFile file
+ case parse c of
+ Bad err -> die err
+ Ok g -> do let fs = gfcc2c g
+ mapM_ (uncurry createFile) fs
+ _ -> die "Usage: gfcc2c <gfcc file>"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:03:06 +0000