diff --git a/src/runtime/c/pgf/db.h b/src/runtime/c/pgf/db.h
index 2dbca1c75..810510e80 100644
--- a/src/runtime/c/pgf/db.h
+++ b/src/runtime/c/pgf/db.h
@@ -22,8 +22,8 @@ public:
A* operator->() const { return (A*) (current_base+offset); }
operator A*() const { return (A*) (current_base+offset); }
- bool operator ==(ref& other) const { return offset==other->offset; }
- bool operator !=(ref& other) const { return offset!=other->offset; }
+ bool operator ==(ref& other) const { return offset==other.as_object(); }
+ bool operator !=(ref& other) const { return offset!=other.as_object(); }
bool operator ==(object other_offset) const { return offset==other_offset; }
bool operator !=(object other_offset) const { return offset!=other_offset; }
diff --git a/src/runtime/c/pgf/namespace.h b/src/runtime/c/pgf/namespace.h
index 2a0b2c694..32b8668f7 100644
--- a/src/runtime/c/pgf/namespace.h
+++ b/src/runtime/c/pgf/namespace.h
@@ -287,7 +287,87 @@ Namespace namespace_insert(Namespace map, ref value)
return Node::new_node(value,map->left,map->right);
}
}
-
+
+template
+Namespace namespace_delete(Namespace map, PgfText* name)
+{
+ if (map == 0)
+ return 0;
+
+ int cmp = textcmp(name,&map->value->name);
+ if (cmp < 0) {
+ Namespace left = namespace_delete(map->left, name);
+ if (left == map->left)
+ return map;
+ Namespace node = Node::balanceR(map->value,left,map->right);
+ namespace_release(left);
+ return node;
+ } else if (cmp > 0) {
+ Namespace right = namespace_delete(map->right, name);
+ if (right == map->right)
+ return map;
+ Namespace node = Node::balanceL(map->value,map->left,right);
+ namespace_release(right);
+ return node;
+ } else {
+ if (map->left == 0) {
+ if (map->right != 0)
+ map->right->ref_count++;
+ return map->right;
+ } else if (map->right == 0) {
+ if (map->left != 0)
+ map->left->ref_count++;
+ return map->left;
+ } else if (map->left->sz > map->right->sz) {
+ ref value;
+ Namespace new_left = namespace_pop_last(map->left, &value);
+ Namespace node = Node::balanceR(value, new_left, map->right);
+ namespace_release(new_left);
+ return node;
+ } else {
+ ref value;
+ Namespace new_right = namespace_pop_first(map->right, &value);
+ Namespace node = Node::balanceL(value, map->left, new_right);
+ namespace_release(new_right);
+ return node;
+ }
+ }
+}
+
+template
+Namespace namespace_pop_first(Namespace map, ref *res)
+{
+ if (map == 0) {
+ return 0;
+ } else if (map->left == 0) {
+ *res = map->value;
+ if (map->right != 0)
+ map->right->ref_count++;
+ return map->right;
+ } else {
+ Namespace new_left = namespace_pop_first(map->left, res);
+ Namespace node = Node::balanceR(map->value, new_left, map->right);
+ namespace_release(new_left);
+ return node;
+ }
+}
+
+template
+Namespace namespace_pop_last(Namespace map, ref *res)
+{
+ if (map == 0) {
+ return 0;
+ } else if (map->right == 0) {
+ *res = map->value;
+ if (map->left != 0)
+ map->left->ref_count++;
+ return map->left;
+ } else {
+ Namespace new_right = namespace_pop_last(map->right, res);
+ return Node::balanceR(map->value, map->left, new_right);
+ }
+}
+
template
ref namespace_lookup(Namespace map, PgfText *name)
{
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 32ed0d4af..ece0580e8 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -534,9 +534,26 @@ void pgf_create_function(PgfDB *db, PgfRevision revision,
absfun->ep.expr = ref::tagged(efun);
memcpy(&absfun->name, name, sizeof(PgfText)+name->size+1);
- Namespace nmsp =
+ Namespace funs =
namespace_insert(pgf->abstract.funs, absfun);
namespace_release(pgf->abstract.funs);
- pgf->abstract.funs = nmsp;
+ pgf->abstract.funs = funs;
+ } PGF_API_END
+}
+
+PGF_API
+void pgf_drop_function(PgfDB *db, PgfRevision revision,
+ PgfText *name,
+ PgfExn *err)
+{
+ PGF_API_BEGIN {
+ DB_scope scope(db, WRITER_SCOPE);
+
+ ref pgf = PgfDB::revision2pgf(revision);
+
+ Namespace funs =
+ namespace_delete(pgf->abstract.funs, name);
+ namespace_release(pgf->abstract.funs);
+ pgf->abstract.funs = funs;
} PGF_API_END
}
diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc
index b2f1f8cdc..1aa8d6e0e 100644
--- a/src/runtime/haskell/PGF2/FFI.hsc
+++ b/src/runtime/haskell/PGF2/FFI.hsc
@@ -116,6 +116,8 @@ foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr Pg
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
+
-----------------------------------------------------------------------
-- Texts
diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc
index c6e03f0a2..e67027f97 100644
--- a/src/runtime/haskell/PGF2/Transactions.hsc
+++ b/src/runtime/haskell/PGF2/Transactions.hsc
@@ -4,6 +4,7 @@ module PGF2.Transactions
, branchPGF
, checkoutPGF
, createFunction
+ , dropFunction
) where
import PGF2.FFI
@@ -110,3 +111,8 @@ createFunction name ty prob = Transaction $ \c_db c_revision c_exn ->
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
withForeignPtr marshaller $ \m -> do
pgf_create_function c_db c_revision c_name c_ty prob m c_exn
+
+dropFunction :: Fun -> Transaction ()
+dropFunction name = Transaction $ \c_db c_revision c_exn ->
+ withText name $ \c_name -> do
+ pgf_drop_function c_db c_revision c_name c_exn
diff --git a/src/runtime/haskell/tests/transactions.hs b/src/runtime/haskell/tests/transactions.hs
index 21010f615..3ae455518 100644
--- a/src/runtime/haskell/tests/transactions.hs
+++ b/src/runtime/haskell/tests/transactions.hs
@@ -12,6 +12,8 @@ main = do
Just gr4 <- checkoutPGF gr1 "master"
Just gr5 <- checkoutPGF gr1 "bar_branch"
+ gr6 <- modifyPGF gr1 (dropFunction "ind")
+
runTestTTAndExit $
TestList $
[TestCase (assertEqual "original functions" ["c","ind","s","z"] (functions gr1))
@@ -19,6 +21,7 @@ main = do
,TestCase (assertEqual "branched functions" ["bar","c","ind","s","z"] (functions gr3))
,TestCase (assertEqual "checked-out extended functions" ["c","foo","ind","s","z"] (functions gr4))
,TestCase (assertEqual "checked-out branched functions" ["bar","c","ind","s","z"] (functions gr5))
+ ,TestCase (assertEqual "reduced functions" ["c","s","z"] (functions gr6))
,TestCase (assertEqual "old function type" Nothing (functionType gr1 "foo"))
,TestCase (assertEqual "new function type" (Just ty) (functionType gr2 "foo"))
,TestCase (assertEqual "old function prob" (-log 0) (functionProb gr1 "foo"))