build the parse table when compiling from sources

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<PgfPGF> pgf,
+                         PgfMarshaller *m, PgfUnmarshaller *u,
+                         ExprNode *env,
+                         PgfExn *err)
+{
+    this->m = m;
+    this->u = u;
+    this->stack = NULL;
+    this->env   = env;
+}

src/runtime/c/pgf/compute.h

@@ -0,0 +1,69 @@
+#ifndef COMPUTE_H
+#define COMPUTE_H
+
+class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller
+{
+    ref<PgfPGF> pgf;
+    PgfMarshaller *m;
+    PgfUnmarshaller *u;
+    PgfExn *err;
+
+    struct Value {
+        Value *next;                // chain for garabage collection
+    };
+
+    struct VThunk : Value {
+        PgfExpr e;
+    };
+
+    struct VApp : Value {
+        ref<PgfConcrLin> 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<PgfPGF> pgf,
+                PgfMarshaller *m, PgfUnmarshaller *u,
+                ExprNode *env,
+                PgfExn *err);
+};
+
+#endif // COMPUTE_H

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<PgfPGF> pgf = db->revision2pgf(revision);
+    ref<PgfConcr> 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<PgfConcr> concr) : tm(concr)
+    PgfLinBuilder(ref<PgfConcr> 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<PgfConcrLincat> build(ref<PgfAbsCat> 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<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
+            PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err);
         if (lin != 0) {
             Namespace<PgfConcrLin> 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<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
+            PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err);
         if (lin != 0) {
             ref<PgfConcrLin> old_lin;
             Namespace<PgfConcrLin> lins =

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);

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 =

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 ()
 

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 <pgf/pgf.h>
 
 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