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

some adjustments in GFCC generation (old)

Browse Source
This commit is contained in:
aarne
2007-12-10 16:46:04 +00:00
parent 3e788e5bbd
commit 77a502085d
2 changed files with 14 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
src/GF/Canon/CanonToGrammar.hs
View File

@@ -73,6 +73,11 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
par' <- mapM redParam par par' <- mapM redParam par
return $ G.ResParam (Yes (par',Nothing)) ---- list of values return $ G.ResParam (Yes (par',Nothing)) ---- list of values
ResOper pty ptr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
return $ G.ResOper (Yes ty') (Yes trm')
CncCat pty ptr ppr -> do CncCat pty ptr ppr -> do
ty' <- redCType pty ty' <- redCType pty
trm' <- redCTerm ptr trm' <- redCTerm ptr
@@ -145,13 +150,13 @@ redCTerm x = case x of
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
T ctype cases -> do T ctype cases -> do
ctype' <- redCType ctype ctype' <- redCType ctype
let (ps,ts) = unzip [(ps,t) | Cas ps t <- cases] let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases]
ps' <- mapM (mapM redPatt) ps ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts ts' <- mapM redCTerm ts
let tinfo = case ps' of let tinfo = case ps' of
[[G.PV _]] -> G.TTyped ctype' [G.PV _] -> G.TTyped ctype'
_ -> G.TComp ctype' _ -> G.TComp ctype'
return $ G.TSh tinfo $ zip ps' ts' return $ G.T tinfo $ zip ps' ts'
V ctype ts -> do V ctype ts -> do
ctype' <- redCType ctype ctype' <- redCType ctype
ts' <- mapM redCTerm ts ts' <- mapM redCTerm ts

6
src/GF/Devel/GrammarToGFCC.hs
View File

@@ -129,6 +129,7 @@ mkTerm tr = case tr of
EInt i -> C.C $ fromInteger i EInt i -> C.C $ fromInteger i
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l)) P t l -> C.P (mkTerm t) (C.C (mkLab l))
TSh _ _ -> error $ show tr
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
V _ cs -> C.R [mkTerm t | t <- cs] V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p) S t p -> C.P (mkTerm t) (mkTerm p)
@@ -378,6 +379,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
(i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
P t l -> r2r tr P t l -> r2r tr
PI t l i -> EInt $ toInteger i PI t l i -> EInt $ toInteger i
T _ [_] -> error $ "single" +++ prt tr
T (TWild _) _ -> error $ "wild" +++ prt tr
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts] V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
@@ -457,7 +461,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
(FV ts,_) -> ts (FV ts,_) -> ts
_ -> [tr] _ -> [tr]
valNumFV ts = case ts of valNumFV ts = case ts of
[tr] -> trace (unwords (map prt (Map.keys typs))) $ [tr] -> trace (unwords (map prt (Map.keys untyps))) $
prtTrace tr $ K "66667" prtTrace tr $ K "66667"
_ -> FV $ map valNum ts _ -> FV $ map valNum ts