mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 13:59:31 -06:00
224 lines
6.9 KiB
Haskell
224 lines
6.9 KiB
Haskell
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>"
|