msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

CFGtoPGF is now extended to support context-free grammars with primitive parameters

Browse Source
This commit is contained in:
krasimir
2016-03-22 10:28:15 +00:00
parent fbdf21d862
commit ce70720859
9 changed files with 192 additions and 166 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -17,7 +17,7 @@ import Data.List
-- the compiler ----------
--------------------------
cf2pgf :: FilePath -> CFG -> PGF
cf2pgf :: FilePath -> ParamCFG -> PGF
cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf
@@ -26,18 +26,21 @@ cf2pgf fpath cf =
aname = mkCId (name ++ "Abs")
cname = mkCId name
cf2abstr :: CFG -> Abstr
cf2abstr :: ParamCFG -> Abstr
cf2abstr cfg = Abstr aflags afuns acats
where
aflags = Map.singleton (mkCId "startcat") (LStr (cfgStartCat cfg))
acats = Map.fromList [(mkCId cat, ([], [(0,mkRuleName rule)
| rule <- Set.toList rules], 0))
| (cat,rules) <- Map.toList (cfgRules cfg)]
afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0))
| (cat,rules) <- Map.toList (cfgRules cfg)
, rule <- Set.toList rules]
aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
cf2concr :: CFG -> Concr
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
[(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg]
cat2id = mkCId . fst
cf2concr :: ParamCFG -> Concr
cf2concr cfg = Concr Map.empty Map.empty
cncfuns lindefsrefs lindefsrefs
sequences productions
@@ -46,51 +49,64 @@ cf2concr cfg = Concr Map.empty Map.empty
IntMap.empty
totalCats
where
cats = allCats' cfg
rules = allRules cfg
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
[mkSequence rule | rules <- Map.elems (cfgRules cfg), rule <- Set.toList rules])
map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
idFun = CncFun wildCId (listArray (0,0) [seqid])
where
seq = listArray (0,0) [SymCat 0 0]
seqid = binSearch seq sequences (bounds sequences)
((fun_cnt,cncfuns0),productions0) = mapAccumL convertRules (1,[idFun]) (Map.toList (cfgRules cfg))
productions = IntMap.fromList productions0
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
lbls = listArray (0,0) ["s"]
(totalCats,cnccats0) = mapAccumL mkCncCat 0 (Map.toList (cfgRules cfg))
cnccats = Map.fromList ((mkCId "Int", CncCat fidInt fidInt lbls) :
(mkCId "Float", CncCat fidFloat fidFloat lbls) :
(mkCId "String", CncCat fidString fidString lbls) :
cnccats0)
(fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
[(c,p) | (c,ps) <- cats, p <- ps]
((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
cnccats = Map.fromList cnccats0
lindefsrefs =
IntMap.fromList (map mkLinDefRef (Map.keys (cfgRules cfg)))
lindefsrefs =
IntMap.fromList (map mkLinDefRef cats)
convertRules st (cat,rules) =
let (st',prods) = mapAccumL convertRule st (Set.toList rules)
in (st',(cat2fid cat,Set.fromList prods))
convertRule (funid,funs) rule =
let args = [PArg [] (cat2fid c) | NonTerminal c <- ruleRhs rule]
convertRule cs (funid,funs) rule =
let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
prod = PApply funid args
seqid = binSearch (mkSequence rule) sequences (bounds sequences)
fun = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
funid' = funid+1
in funid' `seq` ((funid',fun:funs),prod)
in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
mkSequence rule = listArray (0,length syms-1) syms
where
syms = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
convertSymbol d (NonTerminal c) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
convertSymbol d (Terminal t) = (d, SymKS t)
convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
convertSymbol d (Terminal t) = (d, SymKS t)
mkCncCat fid (cat,_) = (fid+1, (mkCId cat,CncCat fid fid lbls))
mkCncCat fid (cat,n)
| cat == "Int" = (fid, (mkCId cat, CncCat fidInt fidInt lbls))
| cat == "Float" = (fid, (mkCId cat, CncCat fidFloat fidFloat lbls))
| cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
| otherwise = let fid' = fid+n+1
in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
mkLinDefRef cat =
(cat2fid cat,[0])
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
mkCoercions (fid,cs) c@(cat,ps ) =
let fid' = fid+1
in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
mkLinDefRef (cat,_) =
(cat2fid cat 0,[0])
addProd prods (fid,prod) =
case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods
Nothing -> IntMap.insert fid (Set.singleton prod) prods
binSearch v arr (i,j)
| i <= j = case compare v (arr ! k) of
@@ -101,11 +117,17 @@ cf2concr cfg = Concr Map.empty Map.empty
where
k = (i+j) `div` 2
cat2fid cat =
cat2fid cat p =
case Map.lookup (mkCId cat) cnccats of
Just (CncCat fid _ _) -> fid
Just (CncCat fid _ _) -> fid+p
_ -> error "cat2fid"
cat2arg c@(cat,[p]) = cat2fid cat p
cat2arg c@(cat,ps ) =
case Map.lookup c cs of
Just fid -> fid
Nothing -> error "cat2arg"
mkRuleName rule =
case ruleName rule of
CFObj n _ -> n