From 5649bc1ef0ed806ec2079a89a8dc10551d902bf6 Mon Sep 17 00:00:00 2001 From: krangelov Date: Tue, 16 Nov 2021 11:49:02 +0100 Subject: [PATCH] started piping PMCFG rules to the runtime --- src/compiler/GF/Compile/GrammarToPGF.hs | 14 +- src/runtime/c/pgf/pgf.cxx | 184 +++++++++++++++++++++- src/runtime/c/pgf/pgf.h | 64 +++++++- src/runtime/haskell/PGF2/FFI.hsc | 101 ++++++------ src/runtime/haskell/PGF2/Transactions.hsc | 75 ++++++++- 5 files changed, 375 insertions(+), 63 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 564ac75c3..b2d4ecc49 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -18,7 +18,7 @@ import GF.Infra.Option import GF.Infra.UseIO (IOE) import GF.Data.Operations -import Control.Monad(forM) +import Control.Monad(forM_) import Data.List import Data.Char import qualified Data.Set as Set @@ -49,10 +49,12 @@ grammar2PGF opts gr am probs = do sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags] sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats] sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs] - forM (allConcretes gr am) $ \cm -> + forM_ (allConcretes gr am) $ \cm -> createConcrete (mi2i cm) $ do let cflags = err (const noOptions) mflags (lookupModule gr cm) sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags] + forM_ (Look.allOrigInfos gr cm) createCncCats + forM_ (Look.allOrigInfos gr cm) createCncFuns return pgf where aflags = err (const noOptions) mflags (lookupModule gr am) @@ -84,6 +86,14 @@ grammar2PGF opts gr am probs = do 0 -> 0 n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n) + createCncCats ((m,c),CncCat _ _ _ _ _) = do + createLincat (i2i c) [] + createCncCats _ = return () + + createCncFuns ((m,f),CncFun _ _ _ (Just prods)) = do + createLin (i2i f) prods + createCncFuns _ = return () + i2i :: Ident -> String i2i = showIdent diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index eefdfffca..fc7dfa3dc 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -970,6 +970,182 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, } PGF_API_END } +class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface +{ + ref lin; + size_t arg_index; + size_t res_index; + size_t seq_index; + size_t sym_index; + +public: + PgfLinBuilder(ref lin) { + this->lin = lin; + this->arg_index = 0; + this->res_index = 0; + this->seq_index = 0; + this->sym_index = 0; + } + + void start_production(PgfExn *err) + { + } + + void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + { + ref param = PgfDB::malloc(n_terms*2*sizeof(size_t)); + param->i0 = i0; + param->n_terms = n_terms; + + for (size_t i = 0; i < n_terms; i++) { + param->terms[i].factor = terms[2*i]; + param->terms[i].var = terms[2*i+1]; + } + + ref parg = vector_elem(lin->args, arg_index); + parg->param = param; + + arg_index++; + } + + void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + { + ref param = PgfDB::malloc(n_terms*2*sizeof(size_t)); + param->i0 = i0; + param->n_terms = n_terms; + + for (size_t i = 0; i < n_terms; i++) { + param->terms[i].factor = terms[2*i]; + param->terms[i].var = terms[2*i+1]; + } + + *vector_elem(lin->res, res_index) = param; + } + + void start_sequence(size_t n_syms, PgfExn *err) + { + *vector_elem(lin->seqs, seq_index) = vector_new(n_syms); + sym_index = 0; + } + + void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + { + ref symcat = PgfDB::malloc(n_terms*2*sizeof(size_t)); + symcat->d = d; + symcat->r.i0 = i0; + symcat->r.n_terms = n_terms; + + for (size_t i = 0; i < n_terms; i++) { + symcat->r.terms[i].factor = terms[2*i]; + symcat->r.terms[i].var = terms[2*i+1]; + } + + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(symcat); + + sym_index++; + } + + void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + { + ref symlit = PgfDB::malloc(n_terms*2*sizeof(size_t)); + symlit->d = d; + symlit->r.i0 = i0; + symlit->r.n_terms = n_terms; + + for (size_t i = 0; i < n_terms; i++) { + symlit->r.terms[i].factor = terms[2*i]; + symlit->r.terms[i].var = terms[2*i+1]; + } + + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(symlit); + + sym_index++; + } + + void add_symvar(size_t d, size_t r, PgfExn *err) + { + ref symvar = PgfDB::malloc(); + symvar->d = d; + symvar->r = r; + + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(symvar); + + sym_index++; + } + + void add_symks(PgfText *token, PgfExn *err) + { + ref symtok = PgfDB::malloc(token->size+1); + memcpy(&symtok->token, token, sizeof(PgfText)+token->size+1); + + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(symtok); + + sym_index++; + } + + void add_symbind(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void add_symsoftbind(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void add_symne(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void add_symsoftspace(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void add_symcapit(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void add_symallcapit(PgfExn *err) + { + ref> syms = *vector_elem(lin->seqs, seq_index); + *vector_elem(syms, sym_index) = ref::tagged(0); + + sym_index++; + } + + void end_sequence(PgfExn *err) { + seq_index++; + } + + void end_production(PgfExn *err) + { + this->res_index++; + } +}; + + PGF_API void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, @@ -1023,7 +1199,9 @@ void pgf_drop_lincat(PgfDB *db, PGF_API void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, - PgfText *name, size_t n_prods, PgfExn *err) + PgfText *name, size_t n_prods, + PgfBuildLinIface *build, + PgfExn *err) { PGF_API_BEGIN { DB_scope scope(db, WRITER_SCOPE); @@ -1051,8 +1229,8 @@ void pgf_create_lin(PgfDB *db, lin->res = vector_new>(n_prods); lin->seqs = vector_new>>(n_prods*lincat->fields->len); - for (size_t i = 0; i < n_prods; i++) { - } + PgfLinBuilder builder(lin); + build->build(&builder, err); Namespace lins = namespace_insert(concr->lins, lin); diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 9a35cc383..98125ce95 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -429,10 +429,72 @@ PGF_API_DECL void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision, PgfText *name, PgfExn *err); +#ifdef __cplusplus +struct PgfLinBuilderIface { + virtual void start_production(PgfExn *err)=0; + virtual void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void start_sequence(size_t n_syms, PgfExn *err)=0; + virtual void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void add_symvar(size_t d, size_t r, PgfExn *err)=0; + virtual void add_symks(PgfText *token, PgfExn *err)=0; + virtual void add_symbind(PgfExn *err)=0; + virtual void add_symsoftbind(PgfExn *err)=0; + virtual void add_symne(PgfExn *err)=0; + 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 void end_production(PgfExn *err)=0; +}; + +struct PgfBuildLinIface { + virtual void build(PgfLinBuilderIface *builder, PgfExn *err)=0; +}; +#else +typedef struct PgfLinBuilderIface PgfLinBuilderIface; + +typedef struct { + void (*start_production)(PgfLinBuilderIface *this, PgfExn *err); + void (*add_argument)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*set_result)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, PgfExn *err); + void (*add_symcat)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*add_symlit)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*add_symvar)(PgfLinBuilderIface *this, size_t d, size_t r, PgfExn *err); + void (*add_symks)(PgfLinBuilderIface *this, PgfText *token, PgfExn *err); + void (*add_symbind)(PgfLinBuilderIface *this, PgfExn *err); + void (*add_symsoftbind)(PgfLinBuilderIface *this, PgfExn *err); + void (*add_symne)(PgfLinBuilderIface *this, PgfExn *err); + 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); + void (*end_production)(PgfLinBuilderIface *this, PgfExn *err); +} PgfLinBuilderIfaceVtbl; + +struct PgfLinBuilderIface { + PgfLinBuilderIfaceVtbl *vtbl; +}; + +typedef struct PgfBuildLinIface PgfBuildLinIface; + +typedef struct { + void (*build)(PgfBuildLinIface *this, PgfLinBuilderIface *builder, PgfExn *err); +} PgfBuildLinIfaceVtbl; + +struct PgfBuildLinIface { + PgfBuildLinIfaceVtbl *vtbl; +}; +#endif + PGF_API_DECL void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, - PgfText *name, size_t n_prods, PgfExn *err); + PgfText *name, size_t n_prods, + PgfBuildLinIface *build, + PgfExn *err); PGF_API_DECL void pgf_drop_lin(PgfDB *db, PgfConcrRevision revision, diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 9202a3d00..d8ef80f84 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -41,6 +41,11 @@ data PgfPrintContext data PgfTypeHypo data PgfMarshaller data PgfUnmarshaller +data PgfBuildLinIface +data PgfLinBuilderIface + +type Wrapper a = a -> IO (FunPtr a) +type Dynamic a = FunPtr a -> a foreign import ccall unsafe "pgf_utf8_decode" pgf_utf8_decode :: Ptr CString -> IO Word32 @@ -90,8 +95,7 @@ foreign import ccall "pgf_read_type" type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO () -foreign import ccall "wrapper" - wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback) +foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback foreign import ccall pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () @@ -139,11 +143,25 @@ foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText - foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () +foreign import ccall "wrapper" wrapLinBuild :: Wrapper (Ptr PgfBuildLinIface -> Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder0 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ()) + +foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfText -> Ptr PgfExn -> IO ()) + foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () -foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO () +foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () @@ -272,99 +290,75 @@ type CBindType = (#type PgfBindType) type EAbsFun = Ptr PgfUnmarshaller -> (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEAbsFun :: FunPtr EAbsFun -> EAbsFun +foreign import ccall "dynamic" callEAbsFun :: Dynamic EAbsFun -foreign import ccall "wrapper" - wrapEAbsFun :: EAbsFun -> IO (FunPtr EAbsFun) +foreign import ccall "wrapper" wrapEAbsFun :: Wrapper EAbsFun type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEAppFun :: FunPtr EAppFun -> EAppFun +foreign import ccall "dynamic" callEAppFun :: Dynamic EAppFun -foreign import ccall "wrapper" - wrapEAppFun :: EAppFun -> IO (FunPtr EAppFun) +foreign import ccall "wrapper" wrapEAppFun :: Wrapper EAppFun type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callELitFun :: FunPtr ELitFun -> ELitFun +foreign import ccall "dynamic" callELitFun :: Dynamic ELitFun -foreign import ccall "wrapper" - wrapELitFun :: ELitFun -> IO (FunPtr ELitFun) +foreign import ccall "wrapper" wrapELitFun :: Wrapper ELitFun type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEMetaFun :: FunPtr EMetaFun -> EMetaFun +foreign import ccall "dynamic" callEMetaFun :: Dynamic EMetaFun -foreign import ccall "wrapper" - wrapEMetaFun :: EMetaFun -> IO (FunPtr EMetaFun) +foreign import ccall "wrapper" wrapEMetaFun :: Wrapper EMetaFun type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEFunFun :: FunPtr EFunFun -> EFunFun +foreign import ccall "dynamic" callEFunFun :: Dynamic EFunFun -foreign import ccall "wrapper" - wrapEFunFun :: EFunFun -> IO (FunPtr EFunFun) +foreign import ccall "wrapper" wrapEFunFun :: Wrapper EFunFun type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEVarFun :: FunPtr EVarFun -> EVarFun +foreign import ccall "dynamic" callEVarFun :: Dynamic EVarFun -foreign import ccall "wrapper" - wrapEVarFun :: EVarFun -> IO (FunPtr EVarFun) +foreign import ccall "wrapper" wrapEVarFun :: Wrapper EVarFun type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callETypedFun :: FunPtr ETypedFun -> ETypedFun +foreign import ccall "dynamic" callETypedFun :: Dynamic ETypedFun -foreign import ccall "wrapper" - wrapETypedFun :: ETypedFun -> IO (FunPtr ETypedFun) +foreign import ccall "wrapper" wrapETypedFun :: Wrapper ETypedFun type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr) -foreign import ccall "dynamic" - callEImplArgFun :: FunPtr EImplArgFun -> EImplArgFun +foreign import ccall "dynamic" callEImplArgFun :: Dynamic EImplArgFun -foreign import ccall "wrapper" - wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun) +foreign import ccall "wrapper" wrapEImplArgFun :: Wrapper EImplArgFun type LIntFun = Ptr PgfUnmarshaller -> (#type size_t) -> Ptr (#type uintmax_t) -> IO (StablePtr Literal) -foreign import ccall "dynamic" - callLIntFun :: FunPtr LIntFun -> LIntFun +foreign import ccall "dynamic" callLIntFun :: Dynamic LIntFun -foreign import ccall "wrapper" - wrapLIntFun :: LIntFun -> IO (FunPtr LIntFun) +foreign import ccall "wrapper" wrapLIntFun :: Wrapper LIntFun type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal) -foreign import ccall "dynamic" - callLFltFun :: FunPtr LFltFun -> LFltFun +foreign import ccall "dynamic" callLFltFun :: Dynamic LFltFun -foreign import ccall "wrapper" - wrapLFltFun :: LFltFun -> IO (FunPtr LFltFun) +foreign import ccall "wrapper" wrapLFltFun :: Wrapper LFltFun type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal) -foreign import ccall "dynamic" - callLStrFun :: FunPtr LStrFun -> LStrFun +foreign import ccall "dynamic" callLStrFun :: Dynamic LStrFun -foreign import ccall "wrapper" - wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun) +foreign import ccall "wrapper" wrapLStrFun :: Wrapper LStrFun type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type) -foreign import ccall "dynamic" - callDTypFun :: FunPtr DTypFun -> DTypFun +foreign import ccall "dynamic" callDTypFun :: Dynamic DTypFun -foreign import ccall "wrapper" - wrapDTypFun :: DTypFun -> IO (FunPtr DTypFun) +foreign import ccall "wrapper" wrapDTypFun :: Wrapper DTypFun foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr a -> StablePtr a -> IO ()) @@ -372,10 +366,7 @@ foreign import ccall "&hs_free_marshaller" hs_free_marshaller :: FinalizerPtr Pg foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FinalizerPtr PgfUnmarshaller -type MatchFun a = Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a) - -foreign import ccall "wrapper" - wrapMatchFun :: MatchFun a -> IO (FunPtr (MatchFun a)) +foreign import ccall "wrapper" wrapMatchFun :: Wrapper (Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a)) {-# NOINLINE marshaller #-} marshaller = unsafePerformIO $ do diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 7adbea58b..4e0b4ecce 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -31,6 +31,7 @@ import PGF2.Expr import Foreign import Foreign.C +import Control.Monad import Control.Exception #include @@ -224,9 +225,79 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn -> pgf_drop_lincat c_db c_revision c_name c_exn createLin :: Fun -> [Production] -> Transaction Concr () -createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn -> +createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> - pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_exn + 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 + pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + where + build _ c_builder c_exn = do + vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder + forM_ prods $ \(Production args res seqs) -> do + fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl + callLinBuilder0 fun c_builder c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl + forM_ args $ \(PArg _ param) -> + callLParam (callLinBuilder3 fun c_builder) param c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl + callLParam (callLinBuilder3 fun c_builder) res c_exn + forM_ seqs $ \syms -> do + fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl + callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn + mapM_ (addSymbol c_builder vtbl c_exn) syms + fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl + callLinBuilder0 fun c_builder c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl + callLinBuilder0 fun c_builder c_exn + return () + + addSymbol c_builder vtbl c_exn (SymCat d r) = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcat) vtbl + callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn + addSymbol c_builder vtbl c_exn (SymLit d r) = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symlit) vtbl + callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn + addSymbol c_builder vtbl c_exn (SymVar d r) = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl + callLinBuilder2 fun c_builder (fromIntegral d) (fromIntegral r) c_exn + addSymbol c_builder vtbl c_exn (SymKS tok) = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl + withText tok $ \c_tok -> + callLinBuilder5 fun c_builder c_tok c_exn + addSymbol c_builder vtbl c_exn SymBIND = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symbind) vtbl + callLinBuilder0 fun c_builder c_exn + addSymbol c_builder vtbl c_exn SymSOFT_BIND = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftbind) vtbl + callLinBuilder0 fun c_builder c_exn + addSymbol c_builder vtbl c_exn SymNE = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symne) vtbl + callLinBuilder0 fun c_builder c_exn + addSymbol c_builder vtbl c_exn SymSOFT_SPACE = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftspace) vtbl + callLinBuilder0 fun c_builder c_exn + addSymbol c_builder vtbl c_exn SymCAPIT = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcapit) vtbl + callLinBuilder0 fun c_builder c_exn + addSymbol c_builder vtbl c_exn SymALL_CAPIT = do + fun <- (#peek PgfLinBuilderIfaceVtbl, add_symallcapit) vtbl + callLinBuilder0 fun c_builder c_exn + + callLParam f (LParam i0 terms) c_exn = + allocaBytes ((#size size_t)*2*n_terms) $ \c_terms -> do + pokeTerms c_terms terms + f (fromIntegral i0) (fromIntegral n_terms) c_terms c_exn + where + n_terms = length terms + + pokeTerms c_terms [] = return () + pokeTerms c_terms ((index,var):terms) = do + pokeElemOff c_terms 0 (fromIntegral index) + pokeElemOff c_terms 1 (fromIntegral var) + pokeTerms (c_terms `plusPtr` ((#size size_t) * 2)) terms dropLin :: Fun -> Transaction Concr () dropLin name = Transaction $ \c_db _ c_revision c_exn ->