diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index e728f476d..a34f4d86e 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -22,77 +22,99 @@ import GF.Text.Pretty import GF.Compile.Compute.Concrete import GF.Data.Operations(Err(..)) import PGF2.Transactions -import qualified Data.Map.Strict as Map import Control.Monad -import Data.List(mapAccumL,sortBy) -import Data.Maybe(fromMaybe) +import Control.Monad.State +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import Data.List(mapAccumL,sortOn) +import Data.Maybe(fromMaybe,isNothing) generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG opts cwd gr cmo@(cm,cmi) - | mstatus cmi == MSComplete && isModCnc cmi = + | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) = do let gr' = prependModule gr cmo - js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi)) - return (cm,cmi{jments = (Map.fromAscList js)}) + (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty + return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)}) | otherwise = return cmo + where + mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m))) -addPMCFG opts cwd gr cmi (id,CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do - defs <- case mdef of +type SequenceSet = Map.Map [Symbol] Int + +addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do + (defs,seqs) <- + case mdef of Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do term <- mkLinDefault gr ty - pmcfgForm gr term [(Explicit,identW,typeStr)] ty + pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do - pmcfgForm gr term [(Explicit,identW,typeStr)] ty - refs <- case mref of + pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs + (refs,seqs) <- + case mref of Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do term <- mkLinReference gr ty - pmcfgForm gr term [(Explicit,identW,ty)] typeStr + pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do - pmcfgForm gr term [(Explicit,identW,ty)] typeStr + pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs mprn <- case mprn of Nothing -> return Nothing Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do prn <- normalForm gr prn return (Just (L loc prn)) - return (id,CncCat mty mdef mref mprn (Just (defs,refs))) -addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do - rules <- checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ - pmcfgForm gr term ctxt val + return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs) +addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do + (rules,seqs) <- + checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ + pmcfgForm gr term ctxt val seqs mprn <- case mprn of Nothing -> return Nothing Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do prn <- normalForm gr prn return (Just (L loc prn)) - return (id,CncFun mty mlin mprn (Just rules)) -addPMCFG opts cwd gr cmi id_info = return id_info + return (CncFun mty mlin mprn (Just rules),seqs) +addPMCFG opts cwd gr cmi id info seqs = return (info,seqs) -pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [Production] -pmcfgForm gr t ctxt ty = - runEvalM gr $ do - ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do - let (ms',_,t) = type2metaTerm gr d ms 0 [] ty - tnk <- newThunk [] t - return ((d+1,ms'),tnk)) - (0,Map.empty) ctxt - sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms] - v <- eval [] t args - (lins,params) <- flatten v ty ([],[]) - lins <- mapM str2lin lins - (r,rs,_) <- compute params - args <- zipWithM tnk2lparam args ctxt - vars <- getVariables - return (Production vars args (LParam r (order rs)) (reverse lins)) - where - tnk2lparam tnk (_,_,ty) = do - v <- force tnk - (_,params) <- flatten v ty ([],[]) - (r,rs,_) <- compute params - return (PArg [] (LParam r (order rs))) +pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet) +pmcfgForm gr t ctxt ty seqs = do + res <- runEvalM gr $ do + ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do + let (ms',_,t) = type2metaTerm gr d ms 0 [] ty + tnk <- newThunk [] t + return ((d+1,ms'),tnk)) + (0,Map.empty) ctxt + sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms] + v <- eval [] t args + (lins,params) <- flatten v ty ([],[]) + lins <- fmap reverse $ mapM str2lin lins + (r,rs,_) <- compute params + args <- zipWithM tnk2lparam args ctxt + vars <- getVariables + let res = LParam r (order rs) + return (vars,args,res,lins) + return (runState (mapM mkProduction res) seqs) + where + tnk2lparam tnk (_,_,ty) = do + v <- force tnk + (_,params) <- flatten v ty ([],[]) + (r,rs,_) <- compute params + return (PArg [] (LParam r (order rs))) - compute [] = return (0,[],1) - compute ((v,ty):params) = do - (r, rs ,cnt ) <- param2int v ty - (r',rs',cnt') <- compute params - return (r*cnt'+r',combine cnt' rs rs',cnt*cnt') + compute [] = return (0,[],1) + compute ((v,ty):params) = do + (r, rs ,cnt ) <- param2int v ty + (r',rs',cnt') <- compute params + return (r*cnt'+r',combine cnt' rs rs',cnt*cnt') + + mkProduction (vars,args,res,lins) = do + lins <- mapM getSeqId lins + return (Production vars args res lins) + where + getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId + getSeqId lin = state $ \m -> + case Map.lookup lin m of + Just seqid -> (seqid,m) + Nothing -> let seqid = Map.size m + in (seqid,Map.insert lin seqid m) type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> (Map.Map MetaId Type,Int,Term) type2metaTerm gr d ms r rs (Sort s) | s == cStr = @@ -238,7 +260,7 @@ combine cnt' ((r,pv):rs) ((r',pv'):rs') = EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs') GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs' -order = sortBy (\(r1,_) (r2,_) -> compare r2 r1) +order = sortOn fst mapAccumM f a [] = return (a,[]) mapAccumM f a (x:xs) = do (a, y) <- f a x diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index ab47e2b8f..8c30f273f 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -18,12 +18,13 @@ import GF.Infra.Option import GF.Infra.UseIO (IOE) import GF.Data.Operations -import Control.Monad(forM_) +import Control.Monad(forM_,foldM) import Data.List import Data.Char import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap +import qualified Data.Sequence as Seq import Data.Array.IArray import Data.Maybe(fromMaybe) import System.FilePath @@ -56,14 +57,18 @@ grammar2PGF opts mb_pgf gr am probs = do createConcrete (mi2i cm) $ do let cflags = err (const noOptions) mflags (lookupModule gr cm) sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags] - let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [[SymCat 0 (LParam 0 [])]] - prods = ([id_prod],[id_prod]) - infos = (((cPredefAbs,cInt), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) - :((cPredefAbs,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) - :((cPredefAbs,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) - : Look.allOrigInfos gr cm) - forM_ infos createCncCats - forM_ infos createCncFuns + let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]] + , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0] + prods = ([id_prod],[id_prod]) + in [(cInt, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) + ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) + ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) + ] + ) + : prepareSeqTbls (Look.allOrigInfos gr cm) + infos <- processInfos createCncCats infos + infos <- processInfos createCncFuns infos + return () return pgf where aflags = err (const noOptions) mflags (lookupModule gr am) @@ -95,19 +100,38 @@ grammar2PGF opts mb_pgf gr am probs = do 0 -> 0 n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n) - createCncCats ((m,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do - createLincat (i2i c) (type2fields gr ty) lindefs linrefs + prepareSeqTbls infos = + (map addSeqTable . Map.toList . Map.fromListWith (++)) + [(m,[(c,info)]) | ((m,c),info) <- infos] + where + addSeqTable (m,infos) = + case lookupModule gr m of + Ok mi -> case mseqs mi of + Just seqs -> (fmap Left seqs,infos) + Nothing -> (Seq.empty,[]) + Bad msg -> error msg + + processInfos f [] = return [] + processInfos f ((seqtbl,infos):rest) = do + seqtbl <- foldM f seqtbl infos + rest <- processInfos f rest + return ((seqtbl,infos):rest) + + createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do + seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl case mprn of Nothing -> return () Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn)) - createCncCats _ = return () + return seqtbl + createCncCats seqtbl _ = return seqtbl - createCncFuns ((m,f),CncFun _ _ mprn (Just prods)) = do - createLin (i2i f) prods + createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do + seqtbl <- createLin (i2i f) prods seqtbl case mprn of Nothing -> return () Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn)) - createCncFuns _ = return () + return seqtbl + createCncFuns seqtbl _ = return seqtbl term2tokens (K tok) = [tok] term2tokens (C t1 t2) = term2tokens t1 ++ term2tokens t2 diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index cbbad5f9b..cf4ba94ea 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -78,7 +78,7 @@ extendModule cwd gr (name,m) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule -rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) = +rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) = checkInModule cwd mi NoLoc empty $ do ---- deps <- moduleDeps ms @@ -115,7 +115,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) = else MSIncomplete unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) - ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ @@ -131,7 +131,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) = js let js1 = Map.union js0 js_ let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1 + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1 return (i,mi') diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index df9120b53..0edf38ed4 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -34,8 +34,8 @@ instance Binary Grammar where instance Binary ModuleInfo where put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi) - get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get - return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments) + get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get + return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments) instance Binary ModuleType where put MTAbstract = putWord8 0 @@ -365,7 +365,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module) decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile' where conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) = - (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty) + (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty) encodeModule :: MonadIO io => FilePath -> SourceModule -> io () encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 98a107425..edef77536 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -74,11 +74,12 @@ import GF.Infra.Location import GF.Data.Operations import PGF2(BindType(..)) -import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)) +import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)) import Data.Array.IArray(Array) import Data.Array.Unboxed(UArray) import qualified Data.Map as Map +import qualified Data.Sequence as Seq import GF.Text.Pretty @@ -100,6 +101,7 @@ data ModuleInfo = ModInfo { mopens :: [OpenSpec], mexdeps :: [ModuleName], msrc :: FilePath, + mseqs :: Maybe (Seq.Seq [Symbol]), jments :: Map.Map Ident Info } diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index f7873e421..c632d8f22 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -132,14 +132,14 @@ ModDef (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } jments <- mapM (checkInfoType mtype) jments defs <- buildAnyTree id jments - return (id, ModInfo mtype mstat opts extends with opens [] "" defs) } + return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) } ModHeader :: { SourceModule } ModHeader : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; (mtype,id) = $2 ; (extends,with,opens) = $4 } - in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) } + in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) } ComplMod :: { ModuleStatus } ComplMod diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 551b27683..b63cdb029 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -25,6 +25,7 @@ module GF.Grammar.Printer import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF2(Literal(..)) +import PGF2.Transactions(SeqId) import GF.Infra.Ident import GF.Infra.Option import GF.Grammar.Values @@ -34,8 +35,9 @@ import GF.Grammar.Grammar import GF.Text.Pretty import Data.Maybe (isNothing) import Data.List (intersperse) +import Data.Foldable (toList) import qualified Data.Map as Map -import qualified Data.Array.IArray as Array +import qualified Data.Sequence as Seq import qualified GHC.Show data TermPrintQual @@ -46,10 +48,11 @@ instance Pretty Grammar where pp = vcat . map (ppModule Qualified) . modules ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) = +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = hdr $$ nest 2 (ppOptions opts $$ - vcat (map (ppJudgement q) (Map.toList jments))) $$ + vcat (map (ppJudgement q) (Map.toList jments)) $$ + maybe empty (ppSequences q) mseqs) $$ ftr where hdr = complModDoc <+> modTypeDoc <+> '=' <+> @@ -160,7 +163,7 @@ ppJudgement q (id, AnyInd cann mid) = Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' _ -> empty -ppPmcfgRule id arg_cats res_cat (Production vars args res lins) = +ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) = pp id <+> (':' <+> (if null vars then empty @@ -169,7 +172,7 @@ ppPmcfgRule id arg_cats res_cat (Production vars args res lins) = then empty else hsep (intersperse (pp '*') (zipWith ppPArg arg_cats args)) <+> "->") <+> ppPmcfgCat res_cat res $$ - '=' <+> brackets (vcat (map (hsep . map ppSymbol) lins))) + '=' <+> brackets (hcat (intersperse (pp ',') (map ppSeqId seqids)))) ppPArg cat (PArg _ p) = ppPmcfgCat cat p @@ -340,6 +343,18 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) +ppSeqId :: SeqId -> Doc +ppSeqId seqid = 'S' <> pp seqid + +ppSequences q seqs + | Seq.null seqs || q /= Internal = empty + | otherwise = "sequences" <+> '{' $$ + nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$ + '}' + where + ppSeq seqid seq = + ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq) + commaPunct f ds = (hcat (punctuate "," (map f ds))) prec d1 d2 doc diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 993f6b755..6f7569efe 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -28,8 +28,9 @@ import PGF2 import PGF2.Transactions hiding (modifyPGF,checkoutPGF) import Data.Char -import Data.List(isPrefixOf) +import Data.List(isPrefixOf,sortOn) import qualified Data.Map as Map +import qualified Data.Sequence as Seq import qualified Text.ParserCombinators.ReadP as RP import System.Directory(getAppUserDataDirectory) import Control.Exception(SomeException,fromException,evaluate,try) @@ -256,9 +257,9 @@ transactionCommand (CreateLin opts f t) pgf = do in return (fields,type2term mo ty) Nothing -> fail ("Function "++f++" is not in the abstract syntax") case runCheck (compileLinTerm sgr mo t ty) of - Ok ((prods,fields'),_) + Ok ((prods,seqtbl,fields'),_) | fields == fields' -> - do lift $ modifyPGF pgf (alterConcrete lang (createLin f prods)) + do lift $ modifyPGF pgf (alterConcrete lang (createLin f prods seqtbl >> return ())) return () | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match" Bad msg -> fail msg @@ -272,8 +273,10 @@ transactionCommand (CreateLin opts f t) pgf = do t <- renameSourceTerm sgr mo (Typed t ty) (t,ty) <- inferLType sgr [] t let (ctxt,res_ty) = typeFormCnc ty - prods <- pmcfgForm sgr t ctxt res_ty - return (prods,type2fields sgr res_ty) + (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty + return (prods,mapToSequence seqs,type2fields sgr res_ty) + where + mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m))) transactionCommand (CreateLincat opts c t) pgf = do sgr <- getGrammar @@ -281,7 +284,7 @@ transactionCommand (CreateLincat opts c t) pgf = do mo <- maybe (fail "no source grammar in scope") return $ greatestResource sgr case runCheck (compileLincatTerm sgr mo t) of - Ok (fields,_)-> do lift $ modifyPGF pgf (alterConcrete lang (createLincat c fields [] [])) + Ok (fields,_)-> do lift $ modifyPGF pgf (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ())) return () Bad msg -> fail msg where diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 09d2b147b..596ae34e5 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -29,7 +29,9 @@ libpgf_la_SOURCES = \ pgf/data.h \ pgf/expr.cxx \ pgf/expr.h \ - pgf/namespace.h + pgf/namespace.h \ + pgf/phrasetable.cxx \ + pgf/phrasetable.h libpgf_la_LDFLAGS = -no-undefined libpgf_la_CXXFLAGS = -fno-rtti -std=c++11 -DCOMPILING_PGF diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx index b04a46492..faaf916b6 100644 --- a/src/runtime/c/pgf/data.cxx +++ b/src/runtime/c/pgf/data.cxx @@ -3,6 +3,7 @@ void PgfFlag::release(ref flag) { pgf_literal_free(flag->value); + PgfDB::free(flag); } void PgfAbsFun::release(ref absfun) @@ -12,11 +13,14 @@ void PgfAbsFun::release(ref absfun) if (absfun->bytecode != 0) { PgfDB::free(absfun->bytecode); } + + PgfDB::free(absfun); } void PgfAbsCat::release(ref abscat) { pgf_context_free(abscat->context); + PgfDB::free(abscat); } void PgfPGF::release(ref pgf) @@ -27,6 +31,7 @@ void PgfPGF::release(ref pgf) namespace_release(pgf->abstract.funs); namespace_release(pgf->abstract.cats); namespace_release(pgf->concretes); + PgfDB::free(pgf); } void PgfConcr::release(ref concr) @@ -35,6 +40,7 @@ void PgfConcr::release(ref concr) namespace_release(concr->lins); namespace_release(concr->lincats); namespace_release(concr->printnames); + PgfDB::free(concr); } void PgfConcrLincat::release(ref lincat) @@ -44,6 +50,29 @@ void PgfConcrLincat::release(ref lincat) } PgfDB::free(lincat->fields); + + for (size_t i = 0; i < lincat->args->len; i++) { + PgfDB::free(vector_elem(lincat->args, i)->param); + } + PgfDB::free(lincat->args); + + for (size_t i = 0; i < lincat->res->len; i++) { + ref res = *vector_elem(lincat->res, i); + if (res->vars != 0) + PgfDB::free(res->vars); + PgfDB::free(res); + } + PgfDB::free(lincat->res); + + for (size_t i = 0; i < lincat->seqs->len; i++) { + ref seq = *vector_elem(lincat->seqs, i); + if (!(--seq->ref_count)) { + PgfSequence::release(seq); + } + } + PgfDB::free(lincat->seqs); + + PgfDB::free(lincat); } PGF_INTERNAL @@ -52,9 +81,9 @@ void pgf_symbol_free(PgfSymbol sym) switch (ref::get_tag(sym)) { case PgfSymbolKP::tag: { auto sym_kp = ref::untagged(sym); - pgf_symbols_free(sym_kp->default_form); + PgfSequence::release(sym_kp->default_form); for (size_t i = 0; i < sym_kp->alts.len; i++) { - pgf_symbols_free(sym_kp->alts.data[i].form); + PgfSequence::release(sym_kp->alts.data[i].form); for (size_t j = 0; j < sym_kp->alts.data[i].prefixes->len; j++) { ref prefix = *vector_elem(sym_kp->alts.data[i].prefixes, j); PgfDB::free(prefix); @@ -75,14 +104,13 @@ void pgf_symbol_free(PgfSymbol sym) } } -PGF_INTERNAL -void pgf_symbols_free(ref> syms) +void PgfSequence::release(ref seq) { - for (size_t i = 0; i < syms->len; i++) { - PgfSymbol sym = *vector_elem(syms, i); + for (size_t i = 0; i < seq->syms.len; i++) { + PgfSymbol sym = *vector_elem(&seq->syms, i); pgf_symbol_free(sym); } - PgfDB::free(syms); + PgfDB::free(seq); } void PgfConcrLin::release(ref lin) @@ -101,17 +129,18 @@ void PgfConcrLin::release(ref lin) PgfDB::free(lin->res); for (size_t i = 0; i < lin->seqs->len; i++) { - ref> syms = *vector_elem(lin->seqs, i); - for (size_t j = 0; j < syms->len; j++) { - PgfSymbol sym = *vector_elem(syms, j); - pgf_symbol_free(sym); - } - PgfDB::free(syms); + ref seq = *vector_elem(lin->seqs, i); + if (!(--seq->ref_count)) { + PgfSequence::release(seq); + } } PgfDB::free(lin->seqs); + + PgfDB::free(lin); } void PgfConcrPrintname::release(ref printname) { PgfDB::free(printname->printname); + PgfDB::free(printname); } diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 33fd7a8f9..dbd65e5c5 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -64,6 +64,7 @@ class PgfConcr; #include "text.h" #include "vector.h" #include "namespace.h" +#include "phrasetable.h" #include "expr.h" struct PGF_INTERNAL_DECL PgfFlag { @@ -128,6 +129,14 @@ struct PGF_INTERNAL_DECL PgfPResult { typedef object PgfSymbol; +struct PGF_INTERNAL_DECL PgfSequence { + size_t seq_id; + size_t ref_count; + Vector syms; + + static void release(ref lincat); +}; + struct PGF_INTERNAL_DECL PgfSymbolCat { static const uint8_t tag = 0; size_t d; @@ -151,7 +160,7 @@ struct PGF_INTERNAL_DECL PgfSymbolKS { }; struct PGF_INTERNAL_DECL PgfAlternative { - ref> form; + ref form; /**< The form of this variant as a list of tokens. */ ref>> prefixes; @@ -161,7 +170,7 @@ struct PGF_INTERNAL_DECL PgfAlternative { struct PGF_INTERNAL_DECL PgfSymbolKP { static const uint8_t tag = 4; - ref> default_form; + ref default_form; Vector alts; }; @@ -192,9 +201,6 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT { PGF_INTERNAL_DECL void pgf_symbol_free(PgfSymbol sym); -PGF_INTERNAL_DECL -void pgf_symbols_free(ref> syms); - struct PGF_INTERNAL_DECL PgfConcrLincat { size_t ref_count; @@ -205,7 +211,7 @@ struct PGF_INTERNAL_DECL PgfConcrLincat { size_t n_lindefs; ref> args; ref>> res; - ref>>> seqs; + ref>> seqs; PgfText name; @@ -219,7 +225,7 @@ struct PGF_INTERNAL_DECL PgfConcrLin { ref> args; ref>> res; - ref>>> seqs; + ref>> seqs; PgfText name; @@ -240,6 +246,7 @@ struct PGF_INTERNAL_DECL PgfConcr { Namespace cflags; Namespace lins; Namespace lincats; + PgfPhrasetable phrasetable; Namespace printnames; // If there are references from the host language to this concrete, diff --git a/src/runtime/c/pgf/db.cxx b/src/runtime/c/pgf/db.cxx index 140efc1af..0d63dd2f1 100644 --- a/src/runtime/c/pgf/db.cxx +++ b/src/runtime/c/pgf/db.cxx @@ -792,7 +792,6 @@ void PgfDB::cleanup_revisions() ref pgf = ms->transient_revisions; ref next = pgf->next; PgfPGF::release(pgf); - PgfDB::free(pgf); ms->transient_revisions = next; } @@ -802,7 +801,6 @@ void PgfDB::cleanup_revisions() concr->ref_count -= concr->ref_count_ex; if (!concr->ref_count) { PgfConcr::release(concr); - PgfDB::free(concr); } ms->transient_concr_revisions = next; } diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx index c9885430a..82c90c6d9 100644 --- a/src/runtime/c/pgf/linearizer.cxx +++ b/src/runtime/c/pgf/linearizer.cxx @@ -52,10 +52,10 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg out->symbol_token(linearizer->printer.get_text()); } -void PgfLinearizer::TreeNode::linearize_syms(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref> syms) +void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref seq) { - for (size_t i = 0; i < syms->len; i++) { - PgfSymbol sym = *vector_elem(syms, i); + for (size_t i = 0; i < seq->syms.len; i++) { + PgfSymbol sym = *vector_elem(&seq->syms, i); switch (ref::get_tag(sym)) { case PgfSymbolCat::tag: { @@ -307,8 +307,8 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf } size_t n_seqs = lin->seqs->len / lin->res->len; - ref> syms = *vector_elem(lin->seqs, (lin_index-1)*n_seqs + lindex); - linearize_syms(out, linearizer, syms); + ref seq = *vector_elem(lin->seqs, (lin_index-1)*n_seqs + lindex); + linearize_seq(out, linearizer, seq); if (linearizer->pre_stack == NULL) out->end_phrase(cat, fid, field, &lin->name); @@ -382,8 +382,8 @@ void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, linearizer->pre_stack->bracket_stack = bracket; } - ref> syms = *vector_elem(lincat->seqs, (lin_index-1)*lincat->fields->len + lindex); - linearize_syms(out, linearizer, syms); + ref seq = *vector_elem(lincat->seqs, (lin_index-1)*lincat->fields->len + lindex); + linearize_seq(out, linearizer, seq); if (linearizer->pre_stack == NULL) out->end_phrase(&lincat->name, fid, field, linearizer->wild); @@ -429,8 +429,8 @@ void PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, ref lincat = args->get_lincat(linearizer); if (lincat != 0) { size_t i = lincat->n_lindefs*lincat->fields->len + (lin_index-1); - ref> syms = *vector_elem(lincat->seqs, i); - linearize_syms(out, linearizer, syms); + ref seq = *vector_elem(lincat->seqs, i); + linearize_seq(out, linearizer, seq); } else { args->linearize(out, linearizer, lindex); } @@ -573,14 +573,14 @@ void PgfLinearizer::flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *t for (size_t j = 0; j < alt->prefixes->len; j++) { ref prefix = *vector_elem(alt->prefixes,j); if (textstarts(token, &(*prefix))) { - pre->node->linearize_syms(out, this, alt->form); + pre->node->linearize_seq(out, this, alt->form); goto done; } } } } - pre->node->linearize_syms(out, this, pre->sym_kp->default_form); + pre->node->linearize_seq(out, this, pre->sym_kp->default_form); done: if (pre->bracket_stack != NULL) diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h index b08f7e4ae..9e61b7576 100644 --- a/src/runtime/c/pgf/linearizer.h +++ b/src/runtime/c/pgf/linearizer.h @@ -45,7 +45,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0; virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r); virtual void linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r); - virtual void linearize_syms(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref> syms); + virtual void linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref seq); virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0; size_t eval_param(PgfLParam *param); virtual ref get_lincat(PgfLinearizer *linearizer)=0; diff --git a/src/runtime/c/pgf/namespace.h b/src/runtime/c/pgf/namespace.h index 0811d4b37..0bb1d7824 100644 --- a/src/runtime/c/pgf/namespace.h +++ b/src/runtime/c/pgf/namespace.h @@ -509,7 +509,6 @@ void namespace_release(Namespace node) if (!(--node->value->ref_count)) { V::release(node->value); - PgfDB::free(node->value); } PgfDB::free(node); diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 182535a8f..d9daf335f 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -273,7 +273,7 @@ PGF_API_DECL void pgf_free_revision(PgfDB *db, PgfRevision revision) { try { - DB_scope scope(db, WRITER_SCOPE); + DB_scope scope(db, READER_SCOPE); ref pgf = PgfDB::revision2pgf(revision); if (pgf->ref_count == 1 && PgfDB::is_persistant_revision(pgf)) { @@ -287,7 +287,6 @@ void pgf_free_revision(PgfDB *db, PgfRevision revision) if (!(--pgf->ref_count)) { PgfDB::unlink_transient_revision(pgf); PgfPGF::release(pgf); - PgfDB::free(pgf); } db->ref_count--; @@ -303,7 +302,7 @@ PGF_API_DECL void pgf_free_concr_revision(PgfDB *db, PgfConcrRevision revision) { try { - DB_scope scope(db, WRITER_SCOPE); + DB_scope scope(db, READER_SCOPE); ref concr = PgfDB::revision2concr(revision); if (!(--concr->ref_count_ex)) { @@ -312,7 +311,6 @@ void pgf_free_concr_revision(PgfDB *db, PgfConcrRevision revision) if (!(--concr->ref_count)) { PgfConcr::release(concr); - PgfDB::free(concr); } db->ref_count--; @@ -357,8 +355,7 @@ struct PgfItorConcrHelper : PgfItor }; static -void iter_concretes_helper(PgfItor *itor, PgfText *key, object value, - PgfExn *err) +void iter_concretes_helper(PgfItor *itor, PgfText *key, object value, PgfExn *err) { PgfItorConcrHelper* helper = (PgfItorConcrHelper*) itor; ref concr = value; @@ -501,8 +498,7 @@ struct PgfItorCatHelper : PgfItor }; static -void iter_by_cat_helper(PgfItor *itor, PgfText *key, object value, - PgfExn *err) +void iter_by_cat_helper(PgfItor *itor, PgfText *key, object value, PgfExn *err) { PgfItorCatHelper* helper = (PgfItorCatHelper*) itor; ref absfun = value; @@ -830,6 +826,19 @@ void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision, } PGF_API_END } +PGF_API +void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, + PgfSequenceItor *itor, PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + ref concr = PgfDB::revision2concr(cnc_revision); + + size_t next_id = 0; + phrasetable_iter(concr->phrasetable, itor, &next_id, err); + } PGF_API_END +} + PGF_API void pgf_get_lincat_counts_internal(object o, size_t *counts) { @@ -847,15 +856,14 @@ PgfText *pgf_get_lincat_field_internal(object o, size_t i) } PGF_API -void pgf_get_lin_counts_internal(object o, size_t *counts) +size_t pgf_get_lin_get_prod_count(object o) { ref lin = o; - counts[0] = lin->res->len; - counts[1] = lin->seqs->len / lin->res->len; + return lin->res->len; } PGF_API -PgfText *pgf_print_lindef_sig_internal(object o, size_t i) +PgfText *pgf_print_lindef_internal(object o, size_t i) { ref lincat = o; @@ -877,29 +885,24 @@ PgfText *pgf_print_lindef_sig_internal(object o, size_t i) printer.efun(&lincat->name); printer.puts("("); printer.lparam(ref::from_ptr(&res->param)); - printer.puts(")"); - - return printer.get_text(); -} - -PGF_API -PgfText *pgf_print_lindef_seq_internal(object o, size_t i, size_t j) -{ - ref lincat = o; - - PgfInternalMarshaller m; - PgfPrinter printer(NULL,0,&m); + printer.puts(") = ["); size_t n_seqs = lincat->fields->len; - ref> syms = *vector_elem(lincat->seqs, i*n_seqs + j); + for (size_t j = 0; j < n_seqs; j++) { + if (j > 0) + printer.puts(","); - printer.symbols(syms); + ref seq = *vector_elem(lincat->seqs, i*n_seqs + j); + printer.seq_id(seq->seq_id); + } + + printer.puts("]"); return printer.get_text(); } PGF_API -PgfText *pgf_print_linref_sig_internal(object o, size_t i) +PgfText *pgf_print_linref_internal(object o, size_t i) { ref lincat = o; @@ -919,29 +922,19 @@ PgfText *pgf_print_linref_sig_internal(object o, size_t i) printer.efun(&lincat->name); printer.puts("("); printer.lparam(vector_elem(lincat->args, lincat->n_lindefs+i)->param); - printer.puts(") -> String(0)"); + printer.puts(") -> String(0) = ["); + + size_t n_seqs = lincat->fields->len; + ref seq = *vector_elem(lincat->seqs, lincat->n_lindefs*n_seqs+i); + printer.seq_id(seq->seq_id); + + printer.puts("]"); return printer.get_text(); } PGF_API -PgfText *pgf_print_linref_seq_internal(object o, size_t i) -{ - ref lincat = o; - - PgfInternalMarshaller m; - PgfPrinter printer(NULL,0,&m); - - size_t n_seqs = lincat->fields->len; - ref> syms = *vector_elem(lincat->seqs, lincat->n_lindefs*n_seqs+i); - - printer.symbols(syms); - - return printer.get_text(); -} - -PGF_API -PgfText *pgf_print_lin_sig_internal(object o, size_t i) +PgfText *pgf_print_lin_internal(object o, size_t i) { ref lin = o; ref ty = lin->absfun->type; @@ -974,23 +967,33 @@ PgfText *pgf_print_lin_sig_internal(object o, size_t i) printer.efun(&ty->name); printer.puts("("); printer.lparam(ref::from_ptr(&res->param)); - printer.puts(")"); + printer.puts(") = ["); + + size_t n_seqs = lin->seqs->len / lin->res->len; + for (size_t j = 0; j < n_seqs; j++) { + if (j > 0) + printer.puts(","); + + ref seq = *vector_elem(lin->seqs, i*n_seqs + j); + printer.seq_id(seq->seq_id); + } + + printer.puts("]"); return printer.get_text(); } PGF_API -PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j) +PgfText *pgf_print_sequence_internal(object o) { - ref lin = o; + ref seq = o; PgfInternalMarshaller m; PgfPrinter printer(NULL,0,&m); - size_t n_seqs = lin->seqs->len / lin->res->len; - ref> syms = *vector_elem(lin->seqs, i*n_seqs + j); - - printer.symbols(syms); + printer.seq_id(seq->seq_id); + printer.puts(" = "); + printer.sequence(seq); return printer.get_text(); } @@ -1256,6 +1259,7 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, concr->cflags = 0; concr->lins = 0; concr->lincats = 0; + concr->phrasetable = 0; concr->printnames = 0; concr->prev = 0; concr->next = 0; @@ -1348,9 +1352,11 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface { + ref concr; + ref> args; ref>> res; - ref>>> seqs; + ref>> seqs; size_t var_index; size_t arg_index; @@ -1362,7 +1368,7 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface size_t n_lindefs; size_t n_linrefs; - ref> syms; + ref seq; size_t pre_sym_index; @@ -1370,8 +1376,10 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface "Detected incorrect use of the linearization builder"; public: - PgfLinBuilder() + PgfLinBuilder(ref concr) { + this->concr = concr; + this->args = 0; this->res = 0; this->seqs = 0; @@ -1383,11 +1391,11 @@ public: this->alt_index = (size_t) -1; this->n_lindefs = 0; this->n_linrefs = 0; - this->syms = 0; + this->seq = 0; this->pre_sym_index = (size_t) -1; } - ref build(ref abscat, PgfConcr *concr, + ref build(ref abscat, size_t n_fields, PgfText **fields, size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err) @@ -1395,7 +1403,7 @@ public: size_t n_prods = n_lindefs+n_linrefs; this->args = vector_new(n_prods); this->res = vector_new>(n_prods); - this->seqs = vector_new>>(n_lindefs*n_fields+n_linrefs); + this->seqs = vector_new>(n_lindefs*n_fields+n_linrefs); this->n_lindefs = n_lindefs; this->n_linrefs = n_linrefs; @@ -1434,7 +1442,7 @@ public: return lincat; } - ref build(ref absfun, PgfConcr *concr, size_t n_prods, + ref build(ref absfun, size_t n_prods, PgfBuildLinIface *build, PgfExn *err) { ref lincat = @@ -1445,7 +1453,7 @@ public: this->args = vector_new(n_prods*absfun->type->hypos->len); this->res = vector_new>(n_prods); - this->seqs = vector_new>>(n_prods*lincat->fields->len); + this->seqs = vector_new>(n_prods*lincat->fields->len); this->n_lindefs = n_prods; ref lin = PgfDB::malloc(absfun->name.size+1); @@ -1569,8 +1577,12 @@ public: if (seq_index >= seqs->len) throw pgf_error(builder_error_msg); - syms = vector_new(n_syms); - *vector_elem(seqs, seq_index) = syms; + seq = PgfDB::malloc(n_syms*sizeof(PgfSymbol)); + seq->seq_id = 0; + seq->ref_count = 1; + seq->syms.len = n_syms; + + *vector_elem(seqs, seq_index) = seq; sym_index = 0; } PGF_API_END } @@ -1581,7 +1593,7 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); ref symcat = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -1594,7 +1606,7 @@ public: symcat->r.terms[i].var = terms[2*i+1]; } - *vector_elem(syms, sym_index) = ref::tagged(symcat); + *vector_elem(&seq->syms, sym_index) = ref::tagged(symcat); sym_index++; } PGF_API_END } @@ -1605,7 +1617,7 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); ref symlit = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -1618,7 +1630,7 @@ public: symlit->r.terms[i].var = terms[2*i+1]; } - *vector_elem(syms, sym_index) = ref::tagged(symlit); + *vector_elem(&seq->syms, sym_index) = ref::tagged(symlit); sym_index++; } PGF_API_END } @@ -1629,14 +1641,14 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); ref symvar = PgfDB::malloc(); symvar->d = d; symvar->r = r; - *vector_elem(syms, sym_index) = ref::tagged(symvar); + *vector_elem(&seq->syms, sym_index) = ref::tagged(symvar); sym_index++; } PGF_API_END } @@ -1647,13 +1659,13 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); ref symtok = PgfDB::malloc(token->size+1); memcpy(&symtok->token, token, sizeof(PgfText)+token->size+1); - *vector_elem(syms, sym_index) = ref::tagged(symtok); + *vector_elem(&seq->syms, sym_index) = ref::tagged(symtok); sym_index++; } PGF_API_END } @@ -1664,19 +1676,22 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len || pre_sym_index != (size_t) -1) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len || pre_sym_index != (size_t) -1) throw pgf_error(builder_error_msg); - ref> def = vector_new(n_syms); + ref def = PgfDB::malloc(n_syms*sizeof(PgfSymbol)); + def->seq_id = 0; + def->ref_count = 1; + def->syms.len = n_syms; ref symkp = PgfDB::malloc(n_alts*sizeof(PgfAlternative)); symkp->default_form = def; symkp->alts.len = n_alts; - *vector_elem(syms, sym_index) = ref::tagged(symkp); + *vector_elem(&seq->syms, sym_index) = ref::tagged(symkp); pre_sym_index = sym_index; - syms = def; + seq = def; sym_index = 0; alt_index = 0; } PGF_API_END @@ -1691,7 +1706,10 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - ref> form = vector_new(n_syms); + ref form = PgfDB::malloc(n_syms*sizeof(PgfSymbol)); + form->seq_id = 0; + form->ref_count = 1; + form->syms.len = n_syms; ref>> prefixes = vector_new>(n_prefs); for (size_t i = 0; i < n_prefs; i++) { @@ -1699,14 +1717,14 @@ public: *vector_elem(prefixes, i) = pref; } - syms = *vector_elem(seqs, seq_index); - ref symkp = ref::untagged(*vector_elem(syms, pre_sym_index)); + seq = *vector_elem(seqs, seq_index); + ref symkp = ref::untagged(*vector_elem(&seq->syms, pre_sym_index)); ref alt = ref::from_ptr(&symkp->alts.data[alt_index]); alt->form = form; alt->prefixes = prefixes; - syms = form; + seq = form; sym_index = 0; } PGF_API_END } @@ -1720,8 +1738,8 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - syms = *vector_elem(seqs, seq_index); - ref symkp = ref::untagged(*vector_elem(syms, pre_sym_index)); + seq = *vector_elem(seqs, seq_index); + ref symkp = ref::untagged(*vector_elem(&seq->syms, pre_sym_index)); if (alt_index >= symkp->alts.len) throw pgf_error(builder_error_msg); @@ -1738,7 +1756,7 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - syms = *vector_elem(seqs, seq_index); + seq = *vector_elem(seqs, seq_index); sym_index = pre_sym_index+1; alt_index = 0; pre_sym_index = (size_t) -1; @@ -1751,10 +1769,10 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } @@ -1765,10 +1783,10 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } @@ -1779,10 +1797,10 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } @@ -1793,10 +1811,10 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } @@ -1807,10 +1825,10 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } @@ -1821,27 +1839,57 @@ public: return; PGF_API_BEGIN { - if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms->len) + if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.len) throw pgf_error(builder_error_msg); - *vector_elem(syms, sym_index) = ref::tagged(0); + *vector_elem(&seq->syms, sym_index) = ref::tagged(0); sym_index++; } PGF_API_END } - void end_sequence(PgfExn *err) + object end_sequence(PgfExn *err) + { + if (err->type != PGF_EXN_NONE) + return 0; + + ref res = 0; + + PGF_API_BEGIN { + if (seq == 0 || sym_index != seq->syms.len) + throw pgf_error(builder_error_msg); + + PgfPhrasetable phrasetable = + phrasetable_internalize(concr->phrasetable, &seq); + if (phrasetable != concr->phrasetable) { + phrasetable_release(concr->phrasetable); + concr->phrasetable = phrasetable; + } else { + *vector_elem(seqs, seq_index) = seq; + } + + res = seq; + + sym_index = (size_t) -1; + seq = 0; + seq_index++; + } PGF_API_END + + return res.as_object(); + } + + void add_sequence_id(object seq_id, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (syms == 0 || sym_index != syms->len) + if (seq_index >= seqs->len) throw pgf_error(builder_error_msg); - sym_index = (size_t) -1; - syms = 0; + + *vector_elem(seqs, seq_index) = seq_id; seq_index++; } PGF_API_END - } + } void end_production(PgfExn *err) { @@ -1882,33 +1930,33 @@ public: PgfDB::free(res); for (size_t i = 0; i < seq_index; i++) { - ref> syms = *vector_elem(seqs, i); - pgf_symbols_free(syms); + ref seq = *vector_elem(seqs, i); + PgfSequence::release(seq); } if (sym_index != (size_t) -1) { - ref> syms = *vector_elem(seqs, seq_index); + ref seq = *vector_elem(seqs, seq_index); if (pre_sym_index != (size_t) -1) { - auto sym_kp = ref::untagged(*vector_elem(syms, pre_sym_index)); + auto sym_kp = ref::untagged(*vector_elem(&seq->syms, pre_sym_index)); - if (this->syms == sym_kp->default_form) { + if (this->seq == sym_kp->default_form) { for (size_t i = 0; i < sym_index; i++) { - PgfSymbol sym = *vector_elem(syms, i); + PgfSymbol sym = *vector_elem(&seq->syms, i); pgf_symbol_free(sym); } - PgfDB::free(syms); + PgfDB::free(seq); } else { - pgf_symbols_free(sym_kp->default_form); + PgfSequence::release(sym_kp->default_form); for (size_t i = 0; i < alt_index; i++) { - pgf_symbols_free(sym_kp->alts.data[i].form); + PgfSequence::release(sym_kp->alts.data[i].form); for (size_t j = 0; j < sym_kp->alts.data[i].prefixes->len; j++) { ref prefix = *vector_elem(sym_kp->alts.data[i].prefixes, j); PgfDB::free(prefix); } } for (size_t i = 0; i < sym_index; i++) { - PgfSymbol sym = *vector_elem(sym_kp->alts.data[alt_index].form, i); + PgfSymbol sym = *vector_elem(&sym_kp->alts.data[alt_index].form->syms, i); pgf_symbol_free(sym); } PgfDB::free(sym_kp->alts.data[alt_index].form); @@ -1923,10 +1971,10 @@ public: } for (size_t j = 0; j < sym_index; j++) { - PgfSymbol sym = *vector_elem(syms, j); + PgfSymbol sym = *vector_elem(&seq->syms, j); pgf_symbol_free(sym); } - PgfDB::free(syms); + PgfDB::free(seq); } PgfDB::free(seqs); @@ -1954,7 +2002,7 @@ void pgf_create_lincat(PgfDB *db, } ref lincat = - PgfLinBuilder().build(abscat, concr, n_fields, fields, n_lindefs, n_linrefs, build, err); + PgfLinBuilder(concr).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err); if (lincat != 0) { Namespace lincats = namespace_insert(concr->lincats, lincat); @@ -2004,7 +2052,7 @@ void pgf_create_lin(PgfDB *db, } ref lin = - PgfLinBuilder().build(absfun, concr, n_prods, build, err); + PgfLinBuilder(concr).build(absfun, n_prods, build, err); if (lin != 0) { Namespace lins = namespace_insert(concr->lins, lin); diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index b77c325e8..e2275b553 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -396,6 +396,15 @@ PGF_API_DECL void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision, PgfItor *itor, PgfExn *err); +typedef struct PgfSequenceItor PgfSequenceItor; +struct PgfSequenceItor { + void (*fn)(PgfSequenceItor* self, object value, PgfExn *err); +}; + +PGF_API +void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, + PgfSequenceItor *itor, PgfExn *err); + PGF_API_DECL void pgf_get_lincat_counts_internal(object o, size_t *counts); @@ -403,25 +412,19 @@ PGF_API_DECL PgfText *pgf_get_lincat_field_internal(object o, size_t i); PGF_API_DECL -void pgf_get_lin_counts_internal(object o, size_t *counts); +size_t pgf_get_lin_get_prod_count(object o); PGF_API_DECL -PgfText *pgf_print_lindef_sig_internal(object o, size_t i); +PgfText *pgf_print_lindef_internal(object o, size_t i); PGF_API_DECL -PgfText *pgf_print_lindef_seq_internal(object o, size_t i, size_t j); +PgfText *pgf_print_linref_internal(object o, size_t i); PGF_API_DECL -PgfText *pgf_print_linref_sig_internal(object o, size_t i); +PgfText *pgf_print_lin_internal(object o, size_t i); PGF_API_DECL -PgfText *pgf_print_linref_seq_internal(object o, size_t i); - -PGF_API_DECL -PgfText *pgf_print_lin_sig_internal(object o, size_t i); - -PGF_API_DECL -PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j); +PgfText *pgf_print_sequence_internal(object o); PGF_API_DECL void pgf_check_expr(PgfDB *db, PgfRevision revision, @@ -515,7 +518,8 @@ struct PgfLinBuilderIface { virtual void add_symsoftspace(PgfExn *err)=0; virtual void add_symcapit(PgfExn *err)=0; virtual void add_symallcapit(PgfExn *err)=0; - virtual void end_sequence(PgfExn *err)=0; + virtual object end_sequence(PgfExn *err)=0; + virtual void add_sequence_id(object seq_id, PgfExn *err)=0; virtual void end_production(PgfExn *err)=0; }; @@ -545,7 +549,8 @@ typedef struct { void (*add_symsoftspace)(PgfLinBuilderIface *this, PgfExn *err); void (*add_symcapit)(PgfLinBuilderIface *this, PgfExn *err); void (*add_symallcapit)(PgfLinBuilderIface *this, PgfExn *err); - void (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err); + object (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err); + void (*add_sequence_id)(PgfLinBuilderIface *this, object seq_id, PgfExn *err); void (*end_production)(PgfLinBuilderIface *this, PgfExn *err); } PgfLinBuilderIfaceVtbl; diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx new file mode 100644 index 000000000..15dcec72f --- /dev/null +++ b/src/runtime/c/pgf/phrasetable.cxx @@ -0,0 +1,239 @@ +#include "data.h" + +static +int lparam_cmp(PgfLParam *p1, PgfLParam *p2) +{ + if (p1->i0 < p2->i0) + return -1; + else if (p1->i0 > p2->i0) + return 1; + + for (size_t i = 0; ; i++) { + if (i >= p1->n_terms) + return -(i < p2->n_terms); + if (i >= p2->n_terms) + return 1; + + if (p1->terms[i].factor > p2->terms[i].factor) + return 1; + else if (p1->terms[i].factor < p2->terms[i].factor) + return -1; + else if (p1->terms[i].var > p2->terms[i].var) + return 1; + else if (p1->terms[i].var < p2->terms[i].var) + return -1; + } + + return 0; +} + +static +int sequence_cmp(ref seq1, ref seq2); + +static +void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2]) +{ + uint8_t t1 = ref::get_tag(sym1); + uint8_t t2 = ref::get_tag(sym2); + + if (t1 != t2) { + res[0] = (res[1] = ((int) t1) - ((int) t2)); + return; + } + + switch (t1) { + case PgfSymbolCat::tag: { + auto sym_cat1 = ref::untagged(sym1); + auto sym_cat2 = ref::untagged(sym2); + if (sym_cat1->d < sym_cat2->d) + res[0] = (res[1] = -1); + else if (sym_cat1->d > sym_cat2->d) + res[0] = (res[1] = 1); + else + res[0] = (res[1] = lparam_cmp(&sym_cat1->r, &sym_cat2->r)); + break; + } + case PgfSymbolLit::tag: { + auto sym_lit1 = ref::untagged(sym1); + auto sym_lit2 = ref::untagged(sym2); + if (sym_lit1->d < sym_lit2->d) + res[0] = (res[1] = -1); + else if (sym_lit1->d > sym_lit2->d) + res[0] = (res[1] = 1); + else + res[0] = (res[1] = lparam_cmp(&sym_lit1->r, &sym_lit2->r)); + break; + } + case PgfSymbolVar::tag: { + auto sym_var1 = ref::untagged(sym1); + auto sym_var2 = ref::untagged(sym2); + if (sym_var1->d < sym_var2->d) + res[0] = (res[1] = -1); + else if (sym_var1->d > sym_var2->d) + res[0] = (res[1] = 1); + else if (sym_var1->r < sym_var2->r) + res[0] = (res[1] = -1); + else if (sym_var1->r > sym_var2->r) + res[0] = (res[1] = 1); + break; + } + case PgfSymbolKS::tag: { + auto sym_ks1 = ref::untagged(sym1); + auto sym_ks2 = ref::untagged(sym2); + texticmp(&sym_ks1->token,&sym_ks2->token,res); + break; + } + case PgfSymbolKP::tag: { + auto sym_kp1 = ref::untagged(sym1); + auto sym_kp2 = ref::untagged(sym2); + res[0] = (res[1] = sequence_cmp(sym_kp1->default_form, sym_kp2->default_form)); + if (res[0] != 0) + return; + + for (size_t i = 0; ; i++) { + if (i >= sym_kp1->alts.len) { + res[0] = (res[1] = -(i < sym_kp2->alts.len)); + return; + } + if (i >= sym_kp2->alts.len) { + res[0] = (res[1] = 1); + return; + } + + res[0] = (res[1] = sequence_cmp(sym_kp1->alts.data[i].form, sym_kp2->alts.data[i].form)); + if (res[0] != 0) + return; + + ref>> prefixes1 = sym_kp1->alts.data[i].prefixes; + ref>> prefixes2 = sym_kp2->alts.data[i].prefixes; + for (size_t j = 0; ; j++) { + if (j >= prefixes1->len) { + res[0] = (res[1] = -(j < prefixes2->len)); + return; + } + if (j >= prefixes2->len) { + res[0] = (res[1] = 1); + return; + } + + res[0] = (res[1] = textcmp(&(**vector_elem(prefixes1, j)), &(**vector_elem(prefixes2, j)))); + if (res[0] != 0) + return; + } + } + } + case PgfSymbolBIND::tag: + case PgfSymbolSOFTBIND::tag: + case PgfSymbolNE::tag: + case PgfSymbolSOFTSPACE::tag: + case PgfSymbolCAPIT::tag: + case PgfSymbolALLCAPIT::tag: + break; + default: + throw pgf_error("Unknown symbol tag"); + } +} + +static +int sequence_cmp(ref seq1, ref seq2) +{ + int res[2] = {0,0}; + for (size_t i = 0; ; i++) { + if (i >= seq1->syms.len) { + if (i < seq2->syms.len) + return -1; + return res[1]; + } + if (i >= seq2->syms.len) + return 1; + + symbol_cmp(seq1->syms.data[i], seq2->syms.data[i], res); + if (res[0] != 0) + return res[0]; + } + + return 0; +} + +PGF_INTERNAL +PgfPhrasetable phrasetable_internalize(PgfPhrasetable table, ref *pseq) +{ + if (table == 0) { + PgfPhrasetable table = Node::new_node(*pseq); + Node::add_value_ref(table->value); + return table; + } + + int cmp = sequence_cmp(*pseq,table->value); + if (cmp < 0) { + PgfPhrasetable left = phrasetable_internalize(table->left, pseq); + if (left == table->left) + return table; + else { + PgfPhrasetable node = Node::balanceL(table->value,left,table->right); + namespace_release(left); + return node; + } + } else if (cmp > 0) { + PgfPhrasetable right = phrasetable_internalize(table->right, pseq); + if (right == table->right) + return table; + else { + PgfPhrasetable node = Node::balanceR(table->value, table->left, right); + phrasetable_release(right); + return node; + } + } else { + if (!(--(*pseq)->ref_count)) { + PgfSequence::release(*pseq); + } + + Node::add_value_ref(table->value); + + *pseq = table->value; + return table; + } +} + +PGF_INTERNAL_DECL +ref phrasetable_get(PgfPhrasetable table, size_t seq_id) +{ + while (table != 0) { + size_t left_sz = table->left->sz; + if (seq_id < left_sz) + table = table->left; + else if (seq_id == left_sz) + return table->value; + else { + table = table->right; + seq_id -= left_sz+1; + } + } + return 0; +} + +PGF_INTERNAL +void phrasetable_iter(PgfPhrasetable table, PgfSequenceItor* itor, size_t *p_next_id, PgfExn *err) +{ + if (table == 0) + return; + + phrasetable_iter(table->left, itor, p_next_id, err); + if (err->type != PGF_EXN_NONE) + return; + + table->value->seq_id = (*p_next_id)++; + itor->fn(itor, table->value.as_object(), err); + if (err->type != PGF_EXN_NONE) + return; + + phrasetable_iter(table->right, itor, p_next_id, err); + if (err->type != PGF_EXN_NONE) + return; +} + +PGF_INTERNAL +void phrasetable_release(PgfPhrasetable table) +{ + namespace_release(table); +} diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h new file mode 100644 index 000000000..b67182118 --- /dev/null +++ b/src/runtime/c/pgf/phrasetable.h @@ -0,0 +1,20 @@ +#ifndef PHRASETABLE_H +#define PHRASETABLE_H + +class PgfSequence; +class PgfSequenceItor; +typedef ref> PgfPhrasetable; + +PGF_INTERNAL_DECL +PgfPhrasetable phrasetable_internalize(PgfPhrasetable table, ref *seq); + +PGF_INTERNAL_DECL +ref phrasetable_get(PgfPhrasetable table, size_t seq_id); + +PGF_INTERNAL_DECL +void phrasetable_iter(PgfPhrasetable table, PgfSequenceItor* itor, size_t *p_next_id, PgfExn *err); + +PGF_INTERNAL_DECL +void phrasetable_release(PgfPhrasetable table); + +#endif diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx index ba2209f3b..7c7aba94d 100644 --- a/src/runtime/c/pgf/printer.cxx +++ b/src/runtime/c/pgf/printer.cxx @@ -529,11 +529,11 @@ void PgfPrinter::symbol(PgfSymbol sym) auto sym_kp = ref::untagged(sym); puts("pre {"); - symbols(sym_kp->default_form); + sequence(sym_kp->default_form); for (size_t i = 0; i < sym_kp->alts.len; i++) { puts("; "); - symbols(sym_kp->alts.data[i].form); + sequence(sym_kp->alts.data[i].form); puts(" /"); for (size_t j = 0; j < sym_kp->alts.data[i].prefixes->len; j++) { puts(" "); @@ -565,16 +565,21 @@ void PgfPrinter::symbol(PgfSymbol sym) } } -void PgfPrinter::symbols(ref> syms) +void PgfPrinter::sequence(ref seq) { - for (size_t i = 0; i < syms->len; i++) { + for (size_t i = 0; i < seq->syms.len; i++) { if (i > 0) puts(" "); - symbol(*vector_elem(syms, i)); + symbol(*vector_elem(&seq->syms, i)); } } +void PgfPrinter::seq_id(size_t seq_id) +{ + nprintf(5, "S%zu", seq_id); +} + void PgfPrinter::free_ref(object x) { } diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h index 019222810..7207ce6e2 100644 --- a/src/runtime/c/pgf/printer.h +++ b/src/runtime/c/pgf/printer.h @@ -56,8 +56,9 @@ public: void lvar(size_t var); void lparam(ref lparam); void lvar_ranges(ref> vars); + void seq_id(size_t seqid); void symbol(PgfSymbol sym); - void symbols(ref> syms); + void sequence(ref seq); virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body); virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg); diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 693a119d6..611959600 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -7,6 +7,7 @@ PgfReader::PgfReader(FILE *in) { this->in = in; this->abstract = 0; + this->concrete = 0; } uint8_t PgfReader::read_uint8() @@ -515,14 +516,14 @@ PgfSymbol PgfReader::read_symbol() sym_kp->alts.len = n_alts; for (size_t i = 0; i < n_alts; i++) { - auto form = read_vector(&PgfReader::read_symbol2); + auto form = read_seq(); auto prefixes = read_vector(&PgfReader::read_text2); sym_kp->alts.data[i].form = form; sym_kp->alts.data[i].prefixes = prefixes; } - auto default_form = read_vector(&PgfReader::read_symbol2); + auto default_form = read_seq(); sym_kp->default_form = default_form; sym = ref::tagged(sym_kp); @@ -559,6 +560,32 @@ PgfSymbol PgfReader::read_symbol() return sym; } +ref PgfReader::read_seq() +{ + size_t n_syms = read_len(); + + ref seq = PgfDB::malloc(n_syms*sizeof(PgfSymbol)); + seq->seq_id = 0; + seq->ref_count = 1; + seq->syms.len = n_syms; + + for (size_t i = 0; i < n_syms; i++) { + PgfSymbol sym = read_symbol(); + *vector_elem(&seq->syms,i) = sym; + } + + return seq; +} + +void PgfReader::read_seq_id(ref> r) +{ + size_t seq_id = read_len(); + ref seq = phrasetable_get(concrete->phrasetable, seq_id); + if (seq == 0) + throw pgf_error("Invalid sequence id"); + *r = seq; +} + ref PgfReader::read_lincat() { ref lincat = read_name(&PgfConcrLincat::name); @@ -568,7 +595,7 @@ ref PgfReader::read_lincat() lincat->n_lindefs = read_len(); lincat->args = read_vector(&PgfReader::read_parg); lincat->res = read_vector(&PgfReader::read_presult2); - lincat->seqs = read_vector(&PgfReader::read_seq2); + lincat->seqs = read_vector(&PgfReader::read_seq_id); return lincat; } @@ -579,7 +606,7 @@ ref PgfReader::read_lin() lin->absfun = namespace_lookup(abstract->funs, &lin->name); lin->args = read_vector(&PgfReader::read_parg); lin->res = read_vector(&PgfReader::read_presult2); - lin->seqs = read_vector(&PgfReader::read_seq2); + lin->seqs = read_vector(&PgfReader::read_seq_id); return lin; } @@ -593,16 +620,17 @@ ref PgfReader::read_printname() ref PgfReader::read_concrete() { - ref concr = read_name(&PgfConcr::name); - concr->ref_count = 1; - concr->ref_count_ex = 0; - concr->cflags = read_namespace(&PgfReader::read_flag); - concr->lincats = read_namespace(&PgfReader::read_lincat); - concr->lins = read_namespace(&PgfReader::read_lin); - concr->printnames = read_namespace(&PgfReader::read_printname); - concr->prev = 0; - concr->next = 0; - return concr; + concrete = read_name(&PgfConcr::name); + concrete->ref_count = 1; + concrete->ref_count_ex = 0; + concrete->cflags = read_namespace(&PgfReader::read_flag); + concrete->phrasetable = read_namespace(&PgfReader::read_seq); + concrete->lincats = read_namespace(&PgfReader::read_lincat); + concrete->lins = read_namespace(&PgfReader::read_lin); + concrete->printnames = read_namespace(&PgfReader::read_printname); + concrete->prev = 0; + concrete->next = 0; + return concrete; } ref PgfReader::read_pgf() diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index 30d9b32c4..87c678b61 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -73,6 +73,8 @@ public: void read_parg(ref parg); ref read_presult(); PgfSymbol read_symbol(); + ref read_seq(); + void read_seq_id(ref> r); ref read_lin(); ref read_printname(); @@ -84,14 +86,13 @@ public: private: FILE *in; ref abstract; + ref concrete; object read_name_internal(size_t struct_size); object read_text_internal(size_t struct_size); - void read_text2(ref> r) { auto text = read_text(); *r = text; }; - void read_lparam(ref> r) { auto lparam = read_lparam(); *r = lparam; }; - void read_symbol2(ref r) { auto sym = read_symbol(); *r = sym; }; - void read_seq2(ref>> r) { auto seq = read_vector(&PgfReader::read_symbol2); *r = seq; } + void read_text2(ref> r) { auto text = read_text(); *r = text; } + void read_lparam(ref> r) { auto lparam = read_lparam(); *r = lparam; } void read_presult2(ref> r) { auto res = read_presult(); *r = res; } template diff --git a/src/runtime/c/pgf/text.cxx b/src/runtime/c/pgf/text.cxx index 9d10a66f8..37d811189 100644 --- a/src/runtime/c/pgf/text.cxx +++ b/src/runtime/c/pgf/text.cxx @@ -5,7 +5,7 @@ int textcmp(PgfText *t1, PgfText *t2) { for (size_t i = 0; ; i++) { if (i >= t1->size) - return (i - t2->size); + return -(i < t2->size); if (i >= t2->size) return 1; @@ -16,6 +16,48 @@ int textcmp(PgfText *t1, PgfText *t2) } } +PGF_INTERNAL +void texticmp(PgfText *t1, PgfText *t2, int res[2]) +{ + const uint8_t *s1 = (uint8_t*) &t1->text; + const uint8_t *e1 = s1+t1->size; + + const uint8_t *s2 = (uint8_t*) &t2->text; + const uint8_t *e2 = s2+t2->size; + + for (;;) { + if (s1 >= e1) { + res[0] = (res[1] = -(s2 < e2)); + return; + } + if (s2 >= e2) { + res[0] = (res[1] = 1); + return; + } + + uint32_t ucs1 = pgf_utf8_decode(&s1); + uint32_t ucs1i = pgf_utf8_to_upper(ucs1); + + uint32_t ucs2 = pgf_utf8_decode(&s2); + uint32_t ucs2i = pgf_utf8_to_upper(ucs2); + + if (ucs1i > ucs2i) { + res[0] = (res[1] = 1); + return; + } + else if (ucs1i < ucs2i) { + res[0] = (res[1] = -1); + return; + } + else if (res[1] == 0) { + if (ucs1 > ucs2) + res[1] = 1; + else if (ucs1 < ucs2) + res[1] = -1; + } + } +} + PGF_INTERNAL bool textstarts(PgfText *t, PgfText *prefix) { @@ -49,7 +91,7 @@ ref textdup_db(PgfText *t1) } PGF_API uint32_t -pgf_utf8_decode(const uint8_t** src_inout) +pgf_utf8_decode(const uint8_t **src_inout) { const uint8_t* src = *src_inout; uint8_t c = src[0]; @@ -74,7 +116,7 @@ pgf_utf8_decode(const uint8_t** src_inout) } PGF_API void -pgf_utf8_encode(uint32_t ucs, uint8_t** buf) +pgf_utf8_encode(uint32_t ucs, uint8_t **buf) { uint8_t* p = *buf; if (ucs < 0x80) { diff --git a/src/runtime/c/pgf/text.h b/src/runtime/c/pgf/text.h index 639ef88ae..471e0b12a 100644 --- a/src/runtime/c/pgf/text.h +++ b/src/runtime/c/pgf/text.h @@ -1,9 +1,19 @@ #ifndef TEXT_H #define TEXT_H +/* Case sensitive comparison */ PGF_INTERNAL_DECL int textcmp(PgfText *t1, PgfText *t2); +/* Performs both case-insensitive and case-sensitive comparison. + * The first element in res contains the result from + * the case-insensitive comparison. The second the result + * from case-sensitive one. Usually res must be initialized + * with {0,0}. If it is not then that can be used + * to chain a list of comparisons.*/ +PGF_INTERNAL_DECL +void texticmp(PgfText *t1, PgfText *t2, int res[2]); + PGF_INTERNAL_DECL bool textstarts(PgfText *t, PgfText *prefix); diff --git a/src/runtime/c/pgf/vector.h b/src/runtime/c/pgf/vector.h index 96b1d3ed5..26b0498b5 100644 --- a/src/runtime/c/pgf/vector.h +++ b/src/runtime/c/pgf/vector.h @@ -30,4 +30,10 @@ ref vector_elem(ref> v, size_t index) return ref::from_ptr(&v->data[index]); } +template inline +A *vector_elem(Vector *v, size_t index) +{ + return &v->data[index]; +} + #endif // VECTOR_H diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx index 17939a62b..bdb46c5e5 100644 --- a/src/runtime/c/pgf/writer.cxx +++ b/src/runtime/c/pgf/writer.cxx @@ -135,7 +135,7 @@ void PgfWriter::write_text(PgfText *text) template void PgfWriter::write_namespace(Namespace nmsp, void (PgfWriter::*write_value)(ref)) { - write_len(nmsp->sz); + write_len(namespace_size(nmsp)); write_namespace_helper(nmsp, write_value); } @@ -393,10 +393,11 @@ void PgfWriter::write_symbol(PgfSymbol sym) auto sym_kp = ref::untagged(sym); write_len(sym_kp->alts.len); for (size_t i = 0; i < sym_kp->alts.len; i++) { - write_seq(sym_kp->alts.data[i].form); - write_vector(sym_kp->alts.data[i].prefixes, &PgfWriter::write_text); + PgfAlternative *alt = vector_elem(&sym_kp->alts, i); + write_vector(ref>::from_ptr(&alt->form->syms), &PgfWriter::write_symbol); + write_vector(alt->prefixes, &PgfWriter::write_text); } - write_seq(sym_kp->default_form); + write_vector(ref>::from_ptr(&sym_kp->default_form->syms), &PgfWriter::write_symbol); break; } case PgfSymbolBIND::tag: @@ -411,9 +412,10 @@ void PgfWriter::write_symbol(PgfSymbol sym) } } -void PgfWriter::write_seq(ref> seq) +void PgfWriter::write_seq(ref seq) { - write_vector(seq, &PgfWriter::write_symbol); + seq->seq_id = next_seq_id++; + write_vector(ref>::from_ptr(&seq->syms), &PgfWriter::write_symbol); } void PgfWriter::write_lincat(ref lincat) @@ -423,7 +425,7 @@ void PgfWriter::write_lincat(ref lincat) write_len(lincat->n_lindefs); write_vector(lincat->args, &PgfWriter::write_parg); write_vector(lincat->res, &PgfWriter::write_presult); - write_vector(lincat->seqs, &PgfWriter::write_seq); + write_vector(lincat->seqs, &PgfWriter::write_seq_id); } void PgfWriter::write_lin(ref lin) @@ -431,7 +433,7 @@ void PgfWriter::write_lin(ref lin) write_name(&lin->name); write_vector(lin->args, &PgfWriter::write_parg); write_vector(lin->res, &PgfWriter::write_presult); - write_vector(lin->seqs, &PgfWriter::write_seq); + write_vector(lin->seqs, &PgfWriter::write_seq_id); } void PgfWriter::write_printname(ref printname) @@ -442,8 +444,11 @@ void PgfWriter::write_printname(ref printname) void PgfWriter::write_concrete(ref concr) { + next_seq_id = 0; + write_name(&concr->name); write_namespace(concr->cflags, &PgfWriter::write_flag); + write_namespace(concr->phrasetable, &PgfWriter::write_seq); write_namespace(concr->lincats, &PgfWriter::write_lincat); write_namespace(concr->lins, &PgfWriter::write_lin); write_namespace(concr->printnames, &PgfWriter::write_printname); diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h index fda06dd33..807330f66 100644 --- a/src/runtime/c/pgf/writer.h +++ b/src/runtime/c/pgf/writer.h @@ -44,7 +44,8 @@ public: void write_parg(ref linarg); void write_presult(ref linres); void write_symbol(PgfSymbol sym); - void write_seq(ref> seq); + void write_seq(ref seq); + void write_seq_id(ref> r) { write_len((*r)->seq_id); }; void write_lin(ref lin); void write_printname(ref printname); @@ -58,10 +59,11 @@ private: void write_text(ref> r) { write_text(&(**r)); }; void write_lparam(ref> r) { write_lparam(*r); }; - void write_seq(ref>> r) { write_seq(*r); }; void write_symbol(ref r) { write_symbol(*r); }; void write_presult(ref> r) { write_presult(*r); }; + size_t next_seq_id; + FILE *out; ref abstract; }; diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index c2a539145..8f5001eaa 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -222,11 +222,15 @@ showPGF p = def <- bracket (pgf_print_function_internal val) free peekText modifyIORef ref (\doc -> doc $$ text def) - ppConcr name c = - text "concrete" <+> text name <+> char '{' $$ - nest 2 (ppLincats c $$ - ppLins c) $$ - char '}' + ppConcr name c = unsafePerformIO $ do + doc <- prepareSequences c -- run first to update all seq_id + return (text "concrete" <+> text name <+> char '{' $$ + nest 2 (ppLincats c $$ + ppLins c $$ + (text "sequences" <+> char '{' $$ + nest 2 doc $$ + char '}')) $$ + char '}') ppLincats c = unsafePerformIO $ do ref <- newIORef empty @@ -248,32 +252,20 @@ showPGF p = n_lindefs <- peekElemOff pcounts 1 n_linrefs <- peekElemOff pcounts 2 return (n_fields,n_lindefs,n_linrefs) - fields <- allocaBytes (3*(#size size_t)) $ \pcounts -> do - forM (init [0..n_fields]) $ \i -> do - pgf_get_lincat_field_internal val i >>= peekText + fields <- forM (init [0..n_fields]) $ \i -> do + pgf_get_lincat_field_internal val i >>= peekText let def = text "lincat" <+> (text name <+> char '=' <+> char '[' $$ nest 2 (vcat (map (text.show) fields)) $$ char ']') modifyIORef ref $ (\doc -> doc $$ def) forM_ (init [0..n_lindefs]) $ \i -> do - sig <- bracket (pgf_print_lindef_sig_internal val i) free $ \c_text -> do + def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do fmap text (peekText c_text) - seqs <- forM (init [0..n_fields]) $ \j -> - bracket (pgf_print_lindef_seq_internal val i j) free $ \c_text -> do - fmap text (peekText c_text) - let def = text "lindef" <+> (sig <+> char '=' <+> char '[' $$ - nest 2 (vcat seqs) $$ - char ']') - modifyIORef ref $ (\doc -> doc $$ def) + modifyIORef ref (\doc -> doc $$ text "lindef" <+> def) forM_ (init [0..n_linrefs]) $ \i -> do - sig <- bracket (pgf_print_linref_sig_internal val i) free $ \c_text -> do + def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do fmap text (peekText c_text) - seq <- bracket (pgf_print_linref_seq_internal val i) free $ \c_text -> do - fmap text (peekText c_text) - let def = text "linref" <+> (sig <+> char '=' <+> char '[' $$ - nest 2 seq $$ - char ']') - modifyIORef ref $ (\doc -> doc $$ def) + modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def) ppLins c = unsafePerformIO $ do ref <- newIORef empty @@ -285,22 +277,28 @@ showPGF p = readIORef ref where getLins :: IORef Doc -> ItorCallback - getLins ref itor key val exn = - allocaBytes (2*(#size size_t)) $ \pcounts -> do - pgf_get_lin_counts_internal val pcounts - n_prods <- peekElemOff pcounts 0 - n_seqs <- peekElemOff pcounts 1 - forM_ (init [0..n_prods]) $ \i -> do - sig <- bracket (pgf_print_lin_sig_internal val i) free $ \c_text -> do - fmap text (peekText c_text) - syms <- forM (init [0..n_seqs]) $ \j -> - bracket (pgf_print_lin_seq_internal val i j) free $ \c_text -> do - fmap text (peekText c_text) - let def = text "lin" <+> (sig <+> char '=' <+> char '[' $$ - nest 2 (vcat syms) $$ - char ']') - modifyIORef ref $ (\doc -> doc $$ def) - return () + getLins ref itor key val exn = do + n_prods <- pgf_get_lin_get_prod_count val + forM_ (init [0..n_prods]) $ \i -> do + def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do + fmap text (peekText c_text) + modifyIORef ref (\doc -> doc $$ text "lin" <+> def) + return () + + prepareSequences c = do + ref <- newIORef empty + (allocaBytes (#size PgfSequenceItor) $ \itor -> + bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (c_revision c) $ \c_revision -> do + (#poke PgfSequenceItor, fn) itor fptr + withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor)) + readIORef ref + where + getSequences :: IORef Doc -> SequenceItorCallback + getSequences ref itor val exn = do + def <- bracket (pgf_print_sequence_internal val) free $ \c_text -> do + fmap text (peekText c_text) + modifyIORef ref $ (\doc -> doc $$ def) -- | The abstract language name is the name of the top-level -- abstract module diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index be3149cbf..58e10b821 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -45,6 +45,7 @@ data PgfBuildLinIface data PgfLinBuilderIface data PgfLinearizationOutputIface data PgfGraphvizOptions +data PgfSequenceItor type Wrapper a = a -> IO (FunPtr a) type Dynamic a = FunPtr a -> a @@ -110,23 +111,25 @@ foreign import ccall pgf_iter_lincats :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor - foreign import ccall pgf_iter_lins :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -> Ptr PgfExn -> IO () +type SequenceItorCallback = Ptr PgfSequenceItor -> Ptr () -> Ptr PgfExn -> IO () + +foreign import ccall "wrapper" wrapSequenceItorCallback :: Wrapper SequenceItorCallback + +foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfExn -> IO () + foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO () foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_print_lindef_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_print_lindef_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_print_linref_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize -foreign import ccall pgf_print_linref_seq_internal :: Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_get_lin_counts_internal :: Ptr () -> Ptr CSize -> IO () - -foreign import ccall pgf_print_lin_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) - -foreign import ccall pgf_print_lin_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_sequence_internal :: Ptr () -> IO (Ptr PgfText) type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO () @@ -200,6 +203,8 @@ foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIfac foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ()) +foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize) + foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 41a799db3..5fff30d4e 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -13,7 +13,7 @@ module PGF2.Transactions , setAbstractFlag -- concrete syntax - , Token, LIndex, LVar, LParam(..) + , Token, SeqId, LIndex, LIndex, LVar, LParam(..) , PArg(..), Symbol(..), Production(..) , createConcrete @@ -21,6 +21,7 @@ module PGF2.Transactions , dropConcrete , mergePGF , setConcreteFlag + , SeqTable , createLincat , dropLincat , createLin @@ -35,6 +36,8 @@ import PGF2.ByteCode import Foreign import Foreign.C import Control.Exception +import qualified Data.Sequence as Seq +import Data.IORef #include @@ -197,10 +200,11 @@ setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn -> type Token = String +type SeqId = Int type LIndex = Int type LVar = Int data LParam = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)] - deriving (Eq,Show) + deriving (Eq,Ord,Show) data Symbol = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LParam @@ -214,21 +218,23 @@ data Symbol | SymSOFT_SPACE -- the special SOFT_SPACE token | SymCAPIT -- the special CAPIT token | SymALL_CAPIT -- the special ALL_CAPIT token - deriving (Eq,Show) + deriving (Eq,Ord,Show) data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam deriving (Eq,Show) -data Production = Production [(LVar,LIndex)] [PArg] LParam [[Symbol]] +data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId] deriving (Eq,Show) -createLincat :: Cat -> [String] -> [Production] -> [Production] -> Transaction Concr () -createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn -> +type SeqTable = Seq.Seq (Either [Symbol] SeqId) + +createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable +createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> let n_fields = length fields in withText name $ \c_name -> allocaBytes (n_fields*(#size PgfText*)) $ \c_fields -> withTexts c_fields 0 fields $ - withBuildLinIface (lindefs++linrefs) $ \c_build -> + withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build -> pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral n_fields) c_fields (fromIntegral (length lindefs)) (fromIntegral (length linrefs)) @@ -245,19 +251,21 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> pgf_drop_lincat c_db c_revision c_name c_exn -createLin :: Fun -> [Production] -> Transaction Concr () -createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn -> +createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable +createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> - withBuildLinIface prods $ \c_build -> + withBuildLinIface prods seqtbl $ \c_build -> pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn -withBuildLinIface prods f = - allocaBytes (#size PgfBuildLinIface) $ \c_build -> - allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl -> - bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do - (#poke PgfBuildLinIface, vtbl) c_build vtbl - (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback - f c_build +withBuildLinIface prods seqtbl f = do + ref <- newIORef seqtbl + (allocaBytes (#size PgfBuildLinIface) $ \c_build -> + allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl -> + bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do + (#poke PgfBuildLinIface, vtbl) c_build vtbl + (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback + f c_build) + readIORef ref where forM_ [] c_exn f = return () forM_ (x:xs) c_exn f = do @@ -266,9 +274,9 @@ withBuildLinIface prods f = then f x >> forM_ xs c_exn f else return () - build _ c_builder c_exn = do + build ref _ c_builder c_exn = do vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder - forM_ prods c_exn $ \(Production vars args res seqs) -> do + forM_ prods c_exn $ \(Production vars args res seqids) -> do fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl callLinBuilder0 fun c_builder c_exn fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl @@ -279,12 +287,17 @@ withBuildLinIface prods f = fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl forM_ vars c_exn $ \(v,r) -> callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn - forM_ seqs c_exn $ \syms -> do - fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl - callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn - forM_ syms c_exn (addSymbol c_builder vtbl c_exn) - fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl - callLinBuilder0 fun c_builder c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl + seqtbl <- readIORef ref + forM_ seqids c_exn $ \seqid -> + case Seq.index seqtbl seqid of + Left syms -> do fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl + callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn + forM_ syms c_exn (addSymbol c_builder vtbl c_exn) + fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl + seqid' <- callLinBuilder7 fun c_builder c_exn + writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl + Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl callLinBuilder0 fun c_builder c_exn