From 83403860338fcf3c602f00fd330415f57ab14713 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 6 May 2026 18:41:50 +0200 Subject: [PATCH] build the parse table when compiling from sources --- src/runtime/c/pgf/compute.cxx | 142 ++++++++++++++++++++++ src/runtime/c/pgf/compute.h | 69 +++++++++++ src/runtime/c/pgf/pgf.cxx | 52 +++++++- src/runtime/c/pgf/pgf.h | 12 +- src/runtime/haskell/PGF2.hsc | 7 +- src/runtime/haskell/PGF2/FFI.hsc | 15 ++- src/runtime/haskell/PGF2/Transactions.hsc | 112 +++++++++-------- 7 files changed, 344 insertions(+), 65 deletions(-) create mode 100644 src/runtime/c/pgf/compute.cxx create mode 100644 src/runtime/c/pgf/compute.h diff --git a/src/runtime/c/pgf/compute.cxx b/src/runtime/c/pgf/compute.cxx new file mode 100644 index 000000000..4e03ead11 --- /dev/null +++ b/src/runtime/c/pgf/compute.cxx @@ -0,0 +1,142 @@ +#include "data.h" +#include "compute.h" + +PgfExpr PgfEvalExpr::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body) +{ + if (stack != NULL) { + ExprNode *tmp; + tmp = stack->next; + stack->next = env; + env = stack; + stack = tmp; + return m->match_expr(this, body); + } else { + return 0; + } +} + +PgfExpr PgfEvalExpr::eapp(PgfExpr fun, PgfExpr arg) +{ + ExprNode node; + node.e = arg; + node.value = 0; + node.next = stack; + stack = &node; + PgfExpr e = m->match_expr(this, fun); + if (node.value != 0) { + //u->free_ref(node.value); + } + return e; +} + +PgfExpr PgfEvalExpr::elit(PgfLiteral lit) +{ + lit = m->match_lit(this, lit); + PgfExpr e = u->elit(lit); + u->free_ref(lit); + return e; +} + +PgfExpr PgfEvalExpr::emeta(PgfMetaId meta_id) +{ + return apply(u->emeta(meta_id)); +} + +PgfExpr PgfEvalExpr::efun(PgfText *name) +{ + return apply(u->efun(name)); +} + +PgfExpr PgfEvalExpr::evar(int index) +{ + ExprNode *node = env; + while (index > 0) { + if (node == NULL) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = strdup("Unbounded variable"); + return 0; + } + node = node->next; + } + + if (node == NULL) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = strdup("Unbounded variable"); + return 0; + } + return apply(force(node)); +} + +PgfExpr PgfEvalExpr::etyped(PgfExpr expr, PgfType ty) +{ + return m->match_expr(this, expr); +} + +PgfExpr PgfEvalExpr::eimplarg(PgfExpr expr) +{ + return m->match_expr(this, expr); +} + +PgfLiteral PgfEvalExpr::lint(size_t size, uintmax_t *val) +{ + return u->lint(size, val); +} + +PgfLiteral PgfEvalExpr::lflt(double val) +{ + return u->lflt(val); +} + +PgfLiteral PgfEvalExpr::lstr(PgfText *val) +{ + return u->lstr(val); +} + +PgfType PgfEvalExpr::dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *name, + size_t n_exprs, PgfExpr *exprs) +{ + return 0; +} + +void PgfEvalExpr::free_ref(object x) +{ + return u->free_ref(x); +} + +PgfExpr PgfEvalExpr::force(ExprNode *node) +{ + if (node->value == 0) { + PgfEvalExpr eval(pgf,m,u,env,err); + node->value = m->match_expr(&eval, node->e); + } + return node->value; +} + +PgfExpr PgfEvalExpr::apply(PgfExpr e) +{ + while (stack != NULL) { + PgfExpr arg = force(stack); + if (arg == 0) { + u->free_ref(e); + return 0; + } + + PgfExpr app = u->eapp(e,arg); + u->free_ref(e); + e = app; + stack = stack->next; + } + return e; +} + +PgfEvalExpr::PgfEvalExpr(ref pgf, + PgfMarshaller *m, PgfUnmarshaller *u, + ExprNode *env, + PgfExn *err) +{ + this->m = m; + this->u = u; + this->stack = NULL; + this->env = env; +} diff --git a/src/runtime/c/pgf/compute.h b/src/runtime/c/pgf/compute.h new file mode 100644 index 000000000..51171fc61 --- /dev/null +++ b/src/runtime/c/pgf/compute.h @@ -0,0 +1,69 @@ +#ifndef COMPUTE_H +#define COMPUTE_H + +class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller +{ + ref pgf; + PgfMarshaller *m; + PgfUnmarshaller *u; + PgfExn *err; + + struct Value { + Value *next; // chain for garabage collection + }; + + struct VThunk : Value { + PgfExpr e; + }; + + struct VApp : Value { + ref lin; + Value *args[]; + }; + + struct VMeta : Value { + PgfMetaId id; + Value *args[]; + }; + + struct VClosure : Value { + PgfExpr e; + }; + + struct ExprNode { + PgfExpr e; + PgfExpr value; + ExprNode *next; + }; + + ExprNode *stack; + ExprNode *env; + + virtual PgfExpr eabs(PgfBindType bind_type, PgfText *name, PgfExpr body); + virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg); + virtual PgfExpr elit(PgfLiteral lit); + virtual PgfExpr emeta(PgfMetaId meta_id); + virtual PgfExpr efun(PgfText *name); + virtual PgfExpr evar(int index); + virtual PgfExpr etyped(PgfExpr expr, PgfType ty); + virtual PgfExpr eimplarg(PgfExpr expr); + virtual PgfLiteral lint(size_t size, uintmax_t *val); + virtual PgfLiteral lflt(double val); + virtual PgfLiteral lstr(PgfText *val); + + virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *name, + size_t n_exprs, PgfExpr *exprs); + virtual void free_ref(object x); + + PgfExpr force(ExprNode *node); + PgfExpr apply(PgfExpr e); + +public: + PgfEvalExpr(ref pgf, + PgfMarshaller *m, PgfUnmarshaller *u, + ExprNode *env, + PgfExn *err); +}; + +#endif // COMPUTE_H diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 82bc65a5e..8c473327c 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -705,6 +705,14 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision, return INFINITY; } +PGF_API +PgfExpr pgf_compute(PgfDB *db, PgfRevision revision, PgfExpr expr, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err) +{ + return 0; +} + PGF_API PgfText *pgf_concrete_name(PgfDB *db, PgfConcrRevision revision, PgfExn *err) @@ -1638,6 +1646,7 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision, PGF_API PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, PgfText *name, + void **p_tm, PgfExn *err) { PGF_API_BEGIN { @@ -1669,6 +1678,8 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, object rev = db->register_concr_revision(revision, index); + *p_tm = new PgfParseTableMaker(concr); + db->ref_count++; return rev; } PGF_API_END @@ -1678,6 +1689,7 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, PGF_API PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, PgfText *name, + void **p_tm, PgfExn *err) { PGF_API_BEGIN { @@ -1693,6 +1705,8 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, concr = clone_concrete(pgf, concr); + *p_tm = new PgfParseTableMaker(concr); + object rev = db->register_concr_revision(revision, index); db->ref_count++; return rev; @@ -1700,6 +1714,22 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, return 0; } +PGF_API +void pgf_free_parse_table(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker_) +{ + PgfParseTableMaker* table_maker = (PgfParseTableMaker*) table_maker_; + + DB_scope scope(db, WRITER_SCOPE); + + ref pgf = db->revision2pgf(revision); + ref concr = db->revision2concr(cnc_revision); + + concr->last_fid = table_maker->get_last_fid(); + delete table_maker; +} + PGF_API void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfText *name, @@ -1742,13 +1772,13 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface size_t pre_sym_index; - PgfParseTableMaker tm; + PgfParseTableMaker *table_maker; const char *builder_error_msg = "Detected incorrect use of the linearization builder"; public: - PgfLinBuilder(ref concr) : tm(concr) + PgfLinBuilder(ref concr, PgfParseTableMaker *table_maker) { this->concr = concr; @@ -1763,6 +1793,7 @@ public: this->rule_index = 0; this->syms = 0; this->pre_sym_index = (size_t) -1; + this->table_maker = table_maker; } ref build(ref abscat, @@ -1809,6 +1840,10 @@ public: return 0; } + for (size_t i = lincat->n_lindefs; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } + return lincat; } @@ -1855,6 +1890,10 @@ public: return 0; } + for (size_t i = 0; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } + return lin; } @@ -2269,6 +2308,7 @@ public: PGF_API void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_fields, PgfText **fields, size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err) @@ -2286,7 +2326,7 @@ void pgf_create_lincat(PgfDB *db, } ref lincat = - PgfLinBuilder(concr).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err); if (lincat != 0) { Namespace lincats = namespace_insert(concr->lincats, lincat); @@ -2334,6 +2374,7 @@ void pgf_drop_lincat(PgfDB *db, PGF_API void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err) @@ -2354,7 +2395,7 @@ void pgf_create_lin(PgfDB *db, } ref lin = - PgfLinBuilder(concr).build(absfun, n_rules, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err); if (lin != 0) { Namespace lins = namespace_insert(concr->lins, lin); @@ -2369,6 +2410,7 @@ void pgf_create_lin(PgfDB *db, PGF_API void pgf_alter_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err) @@ -2386,7 +2428,7 @@ void pgf_alter_lin(PgfDB *db, } ref lin = - PgfLinBuilder(concr).build(absfun, n_rules, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err); if (lin != 0) { ref old_lin; Namespace lins = diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index d4360dcc0..8a590591c 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -612,14 +612,19 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision, PGF_API_DECL PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, - PgfText *name, + PgfText *name, void **p_tm, PgfExn *err); PGF_API_DECL PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, - PgfText *name, + PgfText *name, void **p_tm, PgfExn *err); +PGF_API_DECL +void pgf_free_parse_table(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker); + PGF_API_DECL void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfText *name, @@ -696,6 +701,7 @@ struct PgfBuildLinIface { PGF_API_DECL void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_fields, PgfText **fields, size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err); @@ -708,6 +714,7 @@ void pgf_drop_lincat(PgfDB *db, PGF_API_DECL void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err); @@ -715,6 +722,7 @@ void pgf_create_lin(PgfDB *db, PGF_API_DECL void pgf_alter_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index e81030fcf..05226ab3d 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -595,7 +595,12 @@ checkContext :: PGF -> [Hypo] -> Either String [Hypo] checkContext pgf ctxt = Right ctxt compute :: PGF -> Expr -> Expr -compute = error "TODO: compute" +compute p e = + unsafePerformIO $ + withForeignPtr (a_revision p) $ \c_revision -> + bracket (newStablePtr e) freeStablePtr $ \c_e -> + bracket (withPgfExn "compute" (pgf_compute (a_db p) c_revision c_e marshaller unmarshaller)) freeStablePtr $ \c_e -> + deRefStablePtr c_e concreteName :: Concr -> ConcName concreteName c = diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 1ad73a18f..6b3e90447 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -50,6 +50,7 @@ data PgfMorphoCallback data PgfCohortsCallback data PgfExprEnum data PgfAlignmentPhrase +data PgfParseTableMaker type Wrapper a = a -> IO (FunPtr a) type Dynamic a = FunPtr a -> a @@ -205,6 +206,8 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) +foreign import ccall pgf_compute :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) + foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) foreign import ccall pgf_generate_random_from :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) @@ -225,9 +228,11 @@ foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () -foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr) +foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr) -foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr) +foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr) + +foreign import ccall pgf_free_parse_table :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> IO () foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () @@ -249,13 +254,13 @@ foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIfac 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_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> 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_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () -foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () +foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 8b1c8a8a7..513a67388 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} module PGF2.Transactions ( -- transactions TxnID @@ -50,27 +50,31 @@ import Data.IORef #include newtype Transaction k a = - Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a) + Transaction (Ptr PgfDB -> Ptr PGF -> TransactionCtxt k -> Ptr PgfExn -> IO a) + +type family TransactionCtxt a +type instance TransactionCtxt PGF = () +type instance TransactionCtxt Concr = (Ptr Concr, Ptr PgfParseTableMaker) instance Functor (Transaction k) where - fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do - res <- g c_db c_abstr c_revision c_exn + fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do + res <- g c_db c_abstr ctxt c_exn return (f res) instance Applicative (Transaction k) where - pure x = Transaction $ \c_db _ c_revision c_exn -> return x + pure x = Transaction $ \c_db _ _ c_exn -> return x f <*> g = do f <- f g <- g return (f g) instance Monad (Transaction k) where - (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do - res <- f c_db c_abstr c_revision c_exn + (Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do + res <- f c_db c_abstr ctxt c_exn ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) then case g res of - Transaction g -> g c_db c_abstr c_revision c_exn + Transaction g -> g c_db c_abstr ctxt c_exn else return undefined #if !(MIN_VERSION_base(4,13,0)) @@ -79,7 +83,7 @@ instance Monad (Transaction k) where #endif instance Fail.MonadFail (Transaction k) where - fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg + fail msg = Transaction $ \c_db c_abstr ctxt c_exn -> fail msg data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF) @@ -103,7 +107,7 @@ inTransaction :: TxnID -> Transaction PGF a -> IO a inTransaction (TxnID db fptr) (Transaction f) = withForeignPtr fptr $ \c_revision -> do withPgfExn "inTransaction" $ \c_exn -> - f db c_revision c_revision c_exn + f db c_revision () c_exn {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the transaction @t@. The changes are applied to the new grammar @@ -117,7 +121,7 @@ modifyPGF p (Transaction f) = c_revision <- pgf_start_transaction (a_db p) c_exn ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) - then do ((restore (f (a_db p) c_revision c_revision c_exn)) + then do ((restore (f (a_db p) c_revision () c_exn)) `catch` (\e -> do pgf_free_revision_ (a_db p) c_revision @@ -151,11 +155,11 @@ checkoutPGF p = do already a function with the same name then an exception is thrown. -} createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun -createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn -> +createFunction name ty arity bytecode prob = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr ty) freeStablePtr $ \c_ty -> (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do - c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn + c_name <- pgf_create_function c_db c_abstr c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn if c_name == nullPtr then return "" else do name <- peekText c_name @@ -163,68 +167,72 @@ createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_ return name dropFunction :: Fun -> Transaction PGF () -dropFunction name = Transaction $ \c_db _ c_revision c_exn -> +dropFunction name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_function c_db c_revision c_name c_exn + pgf_drop_function c_db c_abstr c_name c_exn createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF () -createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn -> +createCategory name hypos prob = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> withHypos hypos $ \n_hypos c_hypos -> do - pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn + pgf_create_category c_db c_abstr c_name n_hypos c_hypos prob marshaller c_exn dropCategory :: Cat -> Transaction PGF () -dropCategory name = Transaction $ \c_db _ c_revision c_exn -> +dropCategory name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_category c_db c_revision c_name c_exn + pgf_drop_category c_db c_abstr c_name c_exn createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF () -createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> - withText name $ \c_name -> do - bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn) - (pgf_free_concr_revision_ c_db) $ \c_concr_revision -> - f c_db c_abstr c_concr_revision c_exn +createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn -> + withText name $ \c_name -> + bracketCnc c_exn + (pgf_create_concrete c_db c_abstr c_name) + (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do + f c_db c_abstr ctxt c_exn alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a -alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> +alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - bracketPtr (pgf_clone_concrete c_db c_revision c_name c_exn) - (pgf_free_concr_revision_ c_db) $ \c_concr_revision -> - f c_db c_abstr c_concr_revision c_exn + bracketCnc c_exn + (pgf_clone_concrete c_db c_abstr c_name) + (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do + f c_db c_abstr ctxt c_exn -bracketPtr before after thing = +bracketCnc c_exn before after thing = + alloca $ \p_tm -> mask $ \restore -> do - a <- before - if a == nullPtr + c <- before p_tm c_exn + if c == nullPtr then return undefined - else do r <- restore (thing a) `onException` after a - _ <- after a + else do tm <- peek p_tm + r <- restore (thing (c,tm)) `onException` after c tm + _ <- after c tm return r dropConcrete :: ConcName -> Transaction PGF () -dropConcrete name = Transaction $ \c_db _ c_revision c_exn -> +dropConcrete name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_concrete c_db c_revision c_name c_exn + pgf_drop_concrete c_db c_abstr c_name c_exn mergePGF :: FilePath -> Transaction PGF () -mergePGF fpath = Transaction $ \c_db _ c_revision c_exn -> +mergePGF fpath = Transaction $ \c_db c_abstr _ c_exn -> withCString fpath $ \c_fpath -> - pgf_merge_pgf c_db c_revision c_fpath c_exn + pgf_merge_pgf c_db c_abstr c_fpath c_exn setGlobalFlag :: String -> Literal -> Transaction PGF () -setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setGlobalFlag name value = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> - pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn + pgf_set_global_flag c_db c_abstr c_name c_value marshaller c_exn setAbstractFlag :: String -> Literal -> Transaction PGF () -setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setAbstractFlag name value = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> - pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn + pgf_set_abstract_flag c_db c_abstr c_name c_value marshaller c_exn setConcreteFlag :: String -> Literal -> Transaction Concr () -setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setConcreteFlag name value = Transaction $ \c_db _ (c_revision,_) c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn @@ -258,13 +266,13 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam deriving (Eq,Show) createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr () -createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn -> +createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) 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 -> - pgf_create_lincat c_db c_abstr c_revision c_name + pgf_create_lincat c_db c_abstr c_revision tm c_name (fromIntegral n_fields) c_fields (fromIntegral (length lindefs)) (fromIntegral (length linrefs)) c_build c_exn @@ -276,21 +284,21 @@ createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revisio withTexts p (i+1) ss f dropLincat :: Cat -> Transaction Concr () -dropLincat name = Transaction $ \c_db c_abstr c_revision c_exn -> +dropLincat name = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> pgf_drop_lincat c_db c_abstr c_revision c_name c_exn createLin :: Fun -> [Rule] -> Transaction Concr () -createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn -> +createLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> withBuildLinIface rules $ \c_build -> - pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn + pgf_create_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn alterLin :: Fun -> [Rule] -> Transaction Concr () -alterLin name rules = Transaction $ \c_db c_abstr c_revision c_exn -> +alterLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> withBuildLinIface rules $ \c_build -> - pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn + pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn withBuildLinIface rules f = do (allocaBytes (#size PgfBuildLinIface) $ \c_build -> @@ -394,12 +402,12 @@ withBuildLinIface rules f = do pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms dropLin :: Fun -> Transaction Concr () -dropLin name = Transaction $ \c_db c_abstr c_revision c_exn -> +dropLin name = Transaction $ \c_db c_abstr (c_revision,_) c_exn -> withText name $ \c_name -> pgf_drop_lin c_db c_abstr c_revision c_name c_exn setPrintName :: Fun -> String -> Transaction Concr () -setPrintName fun name = Transaction $ \c_db _ c_revision c_exn -> +setPrintName fun name = Transaction $ \c_db _ (c_revision,_) c_exn -> withText fun $ \c_fun -> withText name $ \c_name -> do pgf_set_printname c_db c_revision c_fun c_name c_exn @@ -422,7 +430,7 @@ getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do -- | A monadic version of 'categoryFields' which returns the fields of -- a category from grammar in the current transaction. getCategoryFields :: Cat -> Transaction Concr (Maybe [String]) -getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn -> +getCategoryFields cat = Transaction $ \c_db _ (c_revision,_) c_exn -> withText cat $ \c_cat -> alloca $ \p_n_fields -> do c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn