summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Command/Commands.hs4
-rw-r--r--src/compiler/GF/Compile/GenerateBC.hs75
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs20
-rw-r--r--src/compiler/GF/Compile/PGFtoHaskell.hs2
-rw-r--r--src/compiler/GF/Compile/PGFtoJS.hs4
-rw-r--r--src/compiler/GF/Compile/PGFtoLProlog.hs20
-rw-r--r--src/compiler/GF/Compile/PGFtoProlog.hs6
-rw-r--r--src/compiler/GF/Compile/PGFtoPython.hs4
-rw-r--r--src/compiler/GF/Infra/Option.hs2
-rw-r--r--src/compiler/GF/Speech/VoiceXML.hs2
10 files changed, 109 insertions, 30 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 18194f340..11ae46713 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1071,7 +1071,7 @@ allCommands env@(pgf, mos) = Map.fromList [
if null (functionsToCat pgf id)
then empty
else space $$
- vcat [ppFun fid (ty,0,Just [],0) | (fid,ty) <- functionsToCat pgf id])
+ vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id])
return void
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
@@ -1246,7 +1246,7 @@ allCommands env@(pgf, mos) = Map.fromList [
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
- funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
+ funsigs pgf = [(f,ty) | (f,(ty,_,_,_,_)) <- Map.assocs (funs (abstract pgf))]
showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
morphos opts s =
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
new file mode 100644
index 000000000..d5b18c725
--- /dev/null
+++ b/src/compiler/GF/Compile/GenerateBC.hs
@@ -0,0 +1,75 @@
+module GF.Compile.GenerateBC(generateByteCode) where
+
+import GF.Grammar
+import GF.Compile.Instructions
+import PGF.Data
+
+import Data.Maybe
+import qualified Data.IntMap as IntMap
+import qualified Data.ByteString as BSS
+import qualified Data.ByteString.Lazy as BS
+import Data.Binary
+
+generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString)
+generateByteCode = runGenM . mapM genFun
+
+type BCLabel = (Int, BCAddr)
+
+genFun (id,info@(AbsFun (Just (L _ ty)) ma pty _)) = do
+ l1 <- newLabel
+ emitLabel l1
+ emit Ins_fail
+ l2 <- newLabel
+ l3 <- newLabel
+ emit (Ins_switch_on_reg (1,addr l2,addr l3))
+ emitLabel l2
+ emit (Ins_try (1,addr l3))
+ emit (Ins_trust_ext (1,1))
+ emit (Ins_try_me_else (0,addr l1))
+ emitLabel l3
+ l4 <- newLabel
+ l5 <- newLabel
+ emit (Ins_switch_on_term (addr l4,addr l5,addr l1,addr l4))
+ emitLabel l4
+ emitLabel l5
+ return (id,info,addr l1)
+genFun (id,info@(AbsCat (Just (L _ cont)))) = do
+ l1 <- newLabel
+ return (id,info,addr l1)
+
+newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr ->
+ IntMap.IntMap BCAddr ->
+ [Instruction] ->
+ (a,IntMap.IntMap BCAddr,[Instruction])}
+
+instance Monad GenM where
+ return x = GenM (\fm cm is -> (x,cm,is))
+ f >>= g = GenM (\fm cm is -> case unGenM f fm cm is of
+ (x,cm,is) -> unGenM (g x) fm cm is)
+
+runGenM :: GenM a -> (a, BSS.ByteString)
+runGenM f =
+ let (x, cm, is) = unGenM f cm IntMap.empty []
+ in (x, BSS.concat (BS.toChunks (encode (BC (reverse is)))))
+
+emit :: Instruction -> GenM ()
+emit i = GenM (\fm cm is -> ((), cm, i:is))
+
+newLabel :: GenM BCLabel
+newLabel = GenM (\fm cm is ->
+ let lbl = IntMap.size cm
+ addr = fromMaybe (error "newLabel") (IntMap.lookup lbl fm)
+ in ((lbl,addr), IntMap.insert lbl 0 cm, is))
+
+emitLabel :: BCLabel -> GenM ()
+emitLabel (lbl,addr) = GenM (\fm cm is ->
+ ((), IntMap.insert lbl (length is) cm, is))
+
+addr :: BCLabel -> BCAddr
+addr (lbl,addr) = addr
+
+data ByteCode = BC [Instruction]
+
+instance Binary ByteCode where
+ put (BC is) = mapM_ putInstruction is
+ get = error "get ByteCode"
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index c30afb0ee..ae627f9e2 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -3,6 +3,7 @@ module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export
import GF.Compile.GeneratePMCFG
+import GF.Compile.GenerateBC
import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString)
@@ -41,26 +42,27 @@ mkCanon2pgf opts gr am = do
cncs <- mapM (mkConcr gr) (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
- mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
+ mkAbstr gr am = return (i2i am, D.Abstr flags funs cats bcode)
where
aflags =
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
- adefs =
- [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
- Look.allOrigInfos gr am
+ (adefs,bcode) =
+ generateByteCode $
+ [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
+ Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
- funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
- ((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
+ funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
+ ((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
- cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
- ((m,c),AbsCat (Just (L _ cont))) <- adefs]
+ cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, addr)) |
+ ((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
- [(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
+ [(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
mkConcr gr cm = do
let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,
diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 90bb804c9..846b1df14 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -264,7 +264,7 @@ hSkeleton gr =
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
- jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
+ jty (f,(ty,_,_,_,_)) = (f,catSkeleton ty)
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 1e9b00169..b7b3d5545 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/src/compiler/GF/Compile/PGFtoJS.hs
@@ -33,8 +33,8 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
-absdef2js :: (CId,(Type,Int,Maybe [Equation],Double)) -> JS.Property
-absdef2js (f,(typ,_,_,_)) =
+absdef2js :: (CId,(Type,Int,Maybe [Equation],Double,BCAddr)) -> JS.Property
+absdef2js (f,(typ,_,_,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs
index a9dc551f2..670e3a952 100644
--- a/src/compiler/GF/Compile/PGFtoLProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoLProlog.hs
@@ -12,25 +12,25 @@ import Debug.Trace
grammar2lambdaprolog_mod pgf = render $
text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$
- vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)),
+ vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)),
let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]]
where
ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$
- vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$
+ vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_,_)) <- fns] $$
space $$
- vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_)) <- fns] $$
+ vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_,_)) <- fns] $$
space
grammar2lambdaprolog_sig pgf = render $
text "sig" <+> ppCId (absname pgf) <> char '.' $$
space $$
- vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
+ vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
space $$
- vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$
+ vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_,_)) <- Map.toList (funs (abstract pgf))] $$
space $$
- vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
- vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))]
+ vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
+ vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_,_)) <- Map.toList (funs (abstract pgf))]
ppCat :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
@@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args =
in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of
- Just (_,_,Just _,_) -> let e = EFun (mkVar i)
- in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
- _ -> (goals,i,foldl EApp (EFun f) args)
+ Just (_,_,Just _,_,_) -> let e = EFun (mkVar i)
+ in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
+ _ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args =
(goals,i,foldl EApp (EVar j) args)
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 03a29871b..de50d86d1 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -49,16 +49,16 @@ plAbstract name abs
(f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] |
- (cat, (hypos, _)) <- Map.assocs (cats abs),
+ (cat, (hypos, _, _)) <- Map.assocs (cats abs),
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
- (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
+ (fun, (typ, _, _, _, _)) <- Map.assocs (funs abs),
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] |
- (fun, (_, _, Just eqs, _)) <- Map.assocs (funs abs),
+ (fun, (_, _, Just eqs, _, _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
)
where plType cat args = plTerm (plp cat) (map plp args)
diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs
index d81a531e2..00910171b 100644
--- a/src/compiler/GF/Compile/PGFtoPython.hs
+++ b/src/compiler/GF/Compile/PGFtoPython.hs
@@ -40,8 +40,8 @@ pgf2python pgf = ("# -*- coding: UTF-8 -*-" ++++
abs = abstract pgf
cncs = concretes pgf
-pyAbsdef :: (Type, Int, Maybe [Equation], Double) -> String
-pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
+pyAbsdef :: (Type, Int, Maybe [Equation], Double, BCAddr) -> String
+pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ
pyLiteral :: Literal -> String
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 79e1b9f73..7408d0783 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -89,6 +89,7 @@ data OutputFormat = FmtPGFPretty
| FmtHaskell
| FmtProlog
| FmtLambdaProlog
+ | FmtByteCode
| FmtBNF
| FmtEBNF
| FmtRegular
@@ -436,6 +437,7 @@ outputFormatsExpl =
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("prolog", FmtProlog),"Prolog (whole grammar)"),
(("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
+ (("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"),
(("regular", FmtRegular),"* regular grammar"),
diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs
index 57168c78c..23a07b62f 100644
--- a/src/compiler/GF/Speech/VoiceXML.hs
+++ b/src/compiler/GF/Speech/VoiceXML.hs
@@ -39,7 +39,7 @@ type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs])
- | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
+ | (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))]
--
-- * Questions to ask
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:17:55 +0000