mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-04 16:52:50 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
223
src-3.0/tools/c/gfcc2c.hs
Normal file
223
src-3.0/tools/c/gfcc2c.hs
Normal file
@@ -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>"
|
||||
Reference in New Issue
Block a user