msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

introduce probspace and maintain consistency after delete

Browse Source
This commit is contained in:
Krasimir Angelov
2023-03-02 09:40:39 +01:00
parent 23a5a3cdef
commit 8fc73b5d05
11 changed files with 359 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/runtime/c/Makefile.am
View File

@@ -38,7 +38,9 @@ libpgf_la_SOURCES = \
pgf/expr.h \
pgf/namespace.h \
pgf/phrasetable.cxx \
pgf/phrasetable.h
pgf/phrasetable.h \
pgf/probspace.cxx \
pgf/probspace.h
libpgf_la_LDFLAGS = -no-undefined -version-info 4:0:0
libpgf_la_CXXFLAGS = -fno-rtti -std=c++11 -DCOMPILING_PGF

1
src/runtime/c/pgf/data.cxx
View File

@@ -30,6 +30,7 @@ void PgfPGF::release(ref<PgfPGF> pgf)
namespace_release(pgf->abstract.aflags);
namespace_release(pgf->abstract.funs);
namespace_release(pgf->abstract.cats);
probspace_release(pgf->abstract.funs_by_cat);
namespace_release(pgf->concretes);
PgfDB::free(pgf);
}

10
src/runtime/c/pgf/data.h
View File

@@ -5,6 +5,7 @@
#include <assert.h>
#include <exception>
#include <stdexcept>
#include <functional>
#include "pgf.h"
@@ -75,6 +76,7 @@ private:
};
struct PgfPGF;
struct PgfAbsFun;
struct PgfConcr;
#include "db.h"
@@ -82,6 +84,7 @@ struct PgfConcr;
#include "vector.h"
#include "namespace.h"
#include "phrasetable.h"
#include "probspace.h"
#include "expr.h"
struct PGF_INTERNAL_DECL PgfFlag {
@@ -114,6 +117,7 @@ typedef struct {
Namespace<PgfFlag> aflags;
Namespace<PgfAbsFun> funs;
Namespace<PgfAbsCat> cats;
PgfProbspace funs_by_cat;
} PgfAbstr;
struct PGF_INTERNAL_DECL PgfLParam {
@@ -289,12 +293,6 @@ struct PGF_INTERNAL_DECL PgfConcr {
PgfPhrasetable phrasetable;
Namespace<PgfConcrPrintname> printnames;
// If there are references from the host language to this concrete,
// then it is included in a double-linked list. If a process
// dies without releasing the reference, it will be released by
// the first process who have an exclusive access to the database.
ref<PgfConcr> prev, next;
PgfText name;
static void release(ref<PgfConcr> pgf);

135
src/runtime/c/pgf/namespace.h
View File

@@ -18,6 +18,9 @@ using Namespace = ref<Node<ref<V>>>;
template <class V>
class PGF_INTERNAL_DECL Node
{
const static size_t DELTA = 3;
const static size_t RATIO = 2;
public:
txn_t txn_id;
@@ -89,7 +92,7 @@ public:
left->left,
right);
} else {
if (node->left->right->sz < 2 * node->left->left->sz) {
if (node->left->right->sz < RATIO * node->left->left->sz) {
ref<Node<V>> left = node->left;
ref<Node<V>> right =
upd_node(node,
@@ -119,8 +122,8 @@ public:
if (node->left == 0) {
return node;
} else {
if (node->left->sz > 3*node->right->sz) {
if (node->left->right->sz < 2*node->left->left->sz) {
if (node->left->sz > DELTA*node->right->sz) {
if (node->left->right->sz < RATIO*node->left->left->sz) {
ref<Node<V>> left = node->left;
ref<Node<V>> right =
upd_node(node,
@@ -181,7 +184,7 @@ public:
left,
right);
} else {
if (node->right->left->sz < 2 * node->right->right->sz) {
if (node->right->left->sz < RATIO * node->right->right->sz) {
ref<Node<V>> right = node->right;
ref<Node<V>> left =
upd_node(node,
@@ -211,8 +214,8 @@ public:
if (node->right == 0) {
return node;
} else {
if (node->right->sz > 3*node->left->sz) {
if (node->right->left->sz < 2*node->right->right->sz) {
if (node->right->sz > DELTA*node->left->sz) {
if (node->right->left->sz < RATIO*node->right->right->sz) {
ref<Node<V>> right = node->right;
ref<Node<V>> left =
upd_node(node,
@@ -280,6 +283,82 @@ public:
}
}
static
ref<Node> link(ref<Node> node, ref<Node> left, ref<Node> right)
{
if (left == 0)
return insert_min(node,right);
if (right == 0)
return insert_max(node,left);
if (DELTA*left->sz < right->sz) {
left = link(node,left,right->left);
ref<Node> node = upd_node(node,left,right->right);
return balanceL(node);
}
if (left->sz > DELTA*right->sz) {
right = link(node,left->right,right);
ref<Node> node = upd_node(node,left->left,right);
return balanceR(node);
}
return upd_node(node,left,right);
}
static
ref<Node> insert_max(ref<Node> node, ref<Node> t)
{
if (t == 0)
return upd_node(node,0,0);
ref<Node> right = insert_max(node,t->right);
node = upd_node(node,t->left,right);
return balanceR(node);
}
static
ref<Node> insert_min(ref<Node> node, ref<Node> t)
{
if (t == 0)
return upd_node(node,0,0);
ref<Node> left = insert_min(node,t->left);
node = upd_node(node,left,t->right);
return balanceL(node);
}
static
ref<Node> link(ref<Node> left, ref<Node> right)
{
if (left == 0)
return right;
if (right == 0)
return left;
if (DELTA*left->sz < right->sz) {
left = link(left,right->left);
ref<Node> node = upd_node(right,left,right->right);
return balanceL(node);
}
if (left->sz > DELTA*right->sz) {
right = link(left->right,right);
ref<Node> node = upd_node(left,left->left,right);
return balanceR(node);
}
if (left->sz > right->sz) {
ref<Node> node;
left = pop_last(left, &node);
node = upd_node(node, left, right);
return balanceR(node);
} else {
ref<Node> node;
right = pop_first(right, &node);
node = upd_node(node, left, right);
return balanceL(node);
}
}
static
void release(ref<Node> node)
{
@@ -311,10 +390,34 @@ Namespace<V> namespace_insert(Namespace<V> map, ref<V> value)
int cmp = textcmp(&value->name,&map->value->name);
if (cmp < 0) {
Namespace<V> left = namespace_insert(map->left, value);
if (left != 0) {
map = Node<ref<V>>::upd_node(map,left,map->right);
return Node<ref<V>>::balanceL(map);
}
} else if (cmp > 0) {
Namespace<V> right = namespace_insert(map->right, value);
if (right != 0) {
map = Node<ref<V>>::upd_node(map,map->left,right);
return Node<ref<V>>::balanceR(map);
}
}
return 0;
}
template <class V>
Namespace<V> namespace_update(Namespace<V> map, ref<V> value)
{
if (map == 0)
return Node<ref<V>>::new_node(value);
int cmp = textcmp(&value->name,&map->value->name);
if (cmp < 0) {
Namespace<V> left = namespace_update(map->left, value);
map = Node<ref<V>>::upd_node(map,left,map->right);
return Node<ref<V>>::balanceL(map);
} else if (cmp > 0) {
Namespace<V> right = namespace_insert(map->right, value);
Namespace<V> right = namespace_update(map->right, value);
map = Node<ref<V>>::upd_node(map,map->left,right);
return Node<ref<V>>::balanceR(map);
} else {
@@ -416,6 +519,9 @@ public:
if (new_map != 0)
return new_map;
if (base == 0)
return 0;
if (name->size >= available) {
size_t new_size = name->size + 10;
PgfText *new_name = (PgfText *)
@@ -521,6 +627,21 @@ void namespace_iter(Namespace<V> map, PgfItor* itor, PgfExn *err)
return;
}
template <class V>
Namespace<V> namespace_map(Namespace<V> map, std::function<ref<V>(ref<V>)> f)
{
if (map != 0) {
auto left = namespace_map(map->left, f);
auto value = f(map->value);
auto right = namespace_map(map->right, f);
map = Node<ref<V>>::upd_node(map,left,right);
map->value = value;
}
return map;
}
template <class V,class A>
void namespace_vec_fill_names(Namespace<V> node, size_t offs, Vector<A> *vec)
{

247
src/runtime/c/pgf/pgf.cxx
View File

@@ -144,8 +144,8 @@ PgfDB *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
PGF_API
PgfDB *pgf_read_ngf(const char *fpath,
PgfRevision *revision,
PgfExn* err)
PgfRevision *revision,
PgfExn* err)
{
PgfDB *db = NULL;
@@ -487,21 +487,6 @@ void pgf_iter_functions(PgfDB *db, PgfRevision revision,
} PGF_API_END
}
struct PgfItorCatHelper : PgfItor
{
PgfText *cat;
PgfItor *itor;
};
static
void iter_by_cat_helper(PgfItor *itor, PgfText *key, object value, PgfExn *err)
{
PgfItorCatHelper* helper = (PgfItorCatHelper*) itor;
ref<PgfAbsFun> absfun = value;
if (textcmp(helper->cat, &absfun->type->name) == 0)
helper->itor->fn(helper->itor, key, value, err);
}
PGF_API
void pgf_iter_functions_by_cat(PgfDB *db, PgfRevision revision,
PgfText *cat, PgfItor *itor, PgfExn *err)
@@ -510,12 +495,7 @@ void pgf_iter_functions_by_cat(PgfDB *db, PgfRevision revision,
DB_scope scope(db, READER_SCOPE);
ref<PgfPGF> pgf = db->revision2pgf(revision);
PgfItorCatHelper helper;
helper.fn = iter_by_cat_helper;
helper.cat = cat;
helper.itor = itor;
namespace_iter(pgf->abstract.funs, &helper, err);
probspace_iter(pgf->abstract.funs_by_cat, cat, itor, false, err);
} PGF_API_END
}
@@ -1217,6 +1197,7 @@ PgfRevision pgf_start_transaction(PgfDB *db, PgfExn *err)
new_pgf->abstract.aflags = pgf->abstract.aflags;
new_pgf->abstract.funs = pgf->abstract.funs;
new_pgf->abstract.cats = pgf->abstract.cats;
new_pgf->abstract.funs_by_cat = pgf->abstract.funs_by_cat;
new_pgf->concretes = pgf->concretes;
db->set_transaction_object(new_pgf.as_object());
@@ -1279,6 +1260,8 @@ PgfText *pgf_create_function(PgfDB *db, PgfRevision revision,
PgfNameAllocator<PgfAbsFun> nalloc(name_pattern);
Namespace<PgfAbsFun> funs =
nalloc.allocate(pgf->abstract.funs);
if (funs == 0)
throw pgf_error("A function with that name already exists");
PgfText *name; ref<PgfAbsFun> absfun;
nalloc.fetch_name_value(&name, &absfun);
@@ -1290,12 +1273,57 @@ PgfText *pgf_create_function(PgfDB *db, PgfRevision revision,
pgf->abstract.funs = funs;
PgfProbspace funs_by_cat =
probspace_insert(pgf->abstract.funs_by_cat, absfun);
pgf->abstract.funs_by_cat = funs_by_cat;
return name;
} PGF_API_END
return NULL;
}
static
ref<PgfConcr> clone_concrete(ref<PgfPGF> pgf, ref<PgfConcr> concr)
{
ref<PgfConcr> clone = concr;
if (!current_db->is_transient_object(clone.as_object())) {
clone = PgfDB::malloc<PgfConcr>(concr->name.size+1);
clone->cflags = concr->cflags;
clone->lins = concr->lins;
clone->lincats = concr->lincats;
clone->phrasetable = concr->phrasetable;
clone->printnames = concr->printnames;
memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1);
Namespace<PgfConcr> concrs =
namespace_update(pgf->concretes, clone);
pgf->concretes = concrs;
PgfDB::free(concr, concr->name.size+1);
}
return clone;
}
static
void drop_lin(ref<PgfConcr> concr, PgfText *name)
{
ref<PgfConcrLin> lin;
Namespace<PgfConcrLin> lins =
namespace_delete(concr->lins, name, &lin);
if (lin != 0) {
object container = lin.tagged();
for (size_t i = 0; i < lin->seqs->len; i++) {
ref<PgfSequence> seq = *vector_elem(lin->seqs, i);
PgfPhrasetable phrasetable =
phrasetable_delete(concr->phrasetable,container,i,seq);
concr->phrasetable = phrasetable;
}
PgfConcrLin::release(lin);
}
concr->lins = lins;
}
PGF_API
void pgf_drop_function(PgfDB *db, PgfRevision revision,
PgfText *name,
@@ -1309,8 +1337,21 @@ void pgf_drop_function(PgfDB *db, PgfRevision revision,
ref<PgfAbsFun> fun;
Namespace<PgfAbsFun> funs =
namespace_delete(pgf->abstract.funs, name, &fun);
if (fun != 0)
if (fun != 0) {
PgfProbspace funs_by_cat =
probspace_delete(pgf->abstract.funs_by_cat, fun);
pgf->abstract.funs_by_cat = funs_by_cat;
std::function<ref<PgfConcr>(ref<PgfConcr>)> f =
[name,pgf](ref<PgfConcr> concr){
concr = clone_concrete(pgf, concr);
drop_lin(concr,name);
return concr;
};
namespace_map(pgf->concretes, f);
PgfAbsFun::release(fun);
}
pgf->abstract.funs = funs;
} PGF_API_END
}
@@ -1341,10 +1382,49 @@ void pgf_create_category(PgfDB *db, PgfRevision revision,
Namespace<PgfAbsCat> cats =
namespace_insert(pgf->abstract.cats, abscat);
if (cats == 0) {
throw pgf_error("A category with that name already exists");
}
pgf->abstract.cats = cats;
} PGF_API_END
}
struct PGF_INTERNAL_DECL PgfDropItor : PgfItor
{
ref<PgfPGF> pgf;
ref<PgfConcr> concrete;
PgfText *name;
};
static
void iter_drop_cat_helper2(PgfItor *itor, PgfText *key, object value, PgfExn *err)
{
ref<PgfConcr> concr = value;
PgfText* name = ((PgfDropItor*) itor)->name;
drop_lin(concr, name);
}
static
void iter_drop_cat_helper(PgfItor *itor, PgfText *key, object value, PgfExn *err)
{
ref<PgfPGF> pgf = ((PgfDropItor*) itor)->pgf;
PgfDropItor itor2;
itor2.fn = iter_drop_cat_helper2;
itor2.pgf = 0;
itor2.concrete = 0;
itor2.name = key;
namespace_iter(pgf->concretes, &itor2, err);
ref<PgfAbsFun> fun;
Namespace<PgfAbsFun> funs =
namespace_delete(pgf->abstract.funs, key, &fun);
fun = value;
PgfAbsFun::release(fun);
pgf->abstract.funs = funs;
}
PGF_API
void pgf_drop_category(PgfDB *db, PgfRevision revision,
PgfText *name,
@@ -1358,8 +1438,31 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
ref<PgfAbsCat> cat;
Namespace<PgfAbsCat> cats =
namespace_delete(pgf->abstract.cats, name, &cat);
if (cat != 0)
if (cat != 0) {
std::function<ref<PgfConcr>(ref<PgfConcr>)> f =
[name,pgf](ref<PgfConcr> concr){
concr = clone_concrete(pgf, concr);
ref<PgfConcrLincat> lincat;
Namespace<PgfConcrLincat> lincats =
namespace_delete(concr->lincats, name, &lincat);
concr->lincats = lincats;
return concr;
};
namespace_map(pgf->concretes, f);
PgfDropItor itor;
itor.fn = iter_drop_cat_helper;
itor.pgf = pgf;
itor.concrete = 0;
itor.name = name;
PgfProbspace funs_by_cat =
probspace_delete_by_cat(pgf->abstract.funs_by_cat, &cat->name,
&itor, err);
pgf->abstract.funs_by_cat = funs_by_cat;
PgfAbsCat::release(cat);
}
pgf->abstract.cats = cats;
} PGF_API_END
}
@@ -1385,14 +1488,15 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
concr->lincats = 0;
concr->phrasetable = 0;
concr->printnames = 0;
concr->prev = 0;
concr->next = 0;
memcpy(&concr->name, name, sizeof(PgfText)+name->size+1);
object rev = db->register_revision(concr.tagged(), PgfDB::get_txn_id());
Namespace<PgfConcr> concrs =
namespace_insert(pgf->concretes, concr);
if (concrs == 0) {
throw pgf_error("A concrete language with that name already exists");
}
pgf->concretes = concrs;
db->ref_count++;
@@ -1416,26 +1520,9 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
if (concr == 0)
throw pgf_error("Unknown concrete syntax");
ref<PgfConcr> clone = concr;
if (!current_db->is_transient_object(clone.as_object())) {
clone = PgfDB::malloc<PgfConcr>(name->size+1);
clone->cflags = concr->cflags;
clone->lins = concr->lins;
clone->lincats = concr->lincats;
clone->phrasetable = concr->phrasetable;
clone->printnames = concr->printnames;
clone->prev = 0;
clone->next = 0;
memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
concr = clone_concrete(pgf, concr);
Namespace<PgfConcr> concrs =
namespace_insert(pgf->concretes, clone);
pgf->concretes = concrs;
PgfDB::free(concr, concr->name.size+1);
}
object rev = db->register_revision(clone.tagged(), PgfDB::get_txn_id());
object rev = db->register_revision(concr.tagged(), PgfDB::get_txn_id());
db->ref_count++;
return rev;
} PGF_API_END
@@ -2052,32 +2139,59 @@ void pgf_create_lincat(PgfDB *db,
if (lincat != 0) {
Namespace<PgfConcrLincat> lincats =
namespace_insert(concr->lincats, lincat);
if (lincats == 0) {
throw pgf_error("A linearization category with that name already exists");
}
concr->lincats = lincats;
}
} PGF_API_END
}
static
void iter_drop_lincat_helper(PgfItor *itor, PgfText *key, object value, PgfExn *err)
{
ref<PgfConcr> concr = ((PgfDropItor*) itor)->concrete;
drop_lin(concr, key);
}
PGF_API
void pgf_drop_lincat(PgfDB *db,
PgfConcrRevision revision,
PgfRevision revision,PgfConcrRevision cnc_revision,
PgfText *name, PgfExn *err)
{
PGF_API_BEGIN {
DB_scope scope(db, WRITER_SCOPE);
ref<PgfConcr> concr = db->revision2concr(revision);
ref<PgfPGF> pgf = db->revision2pgf(revision);
ref<PgfConcr> concr = db->revision2concr(cnc_revision);
ref<PgfConcrLincat> lincat;
Namespace<PgfConcrLincat> lincats =
namespace_delete(concr->lincats, name, &lincat);
if (lincat != 0) {
// The lincat was indeed in the concrete syntax.
// Remove the linearizations of all functions that
// depend on it.
PgfDropItor itor;
itor.fn = iter_drop_lincat_helper;
itor.pgf = pgf;
itor.concrete = concr;
itor.name = name;
probspace_iter(pgf->abstract.funs_by_cat, name,
&itor, true, err);
// Remove the sequences comprizing the lindef and linref
object container = lincat.tagged();
PgfPhrasetable phrasetable = concr->phrasetable;
for (size_t i = 0; i < lincat->seqs->len; i++) {
ref<PgfSequence> seq = *vector_elem(lincat->seqs, i);
PgfPhrasetable phrasetable =
phrasetable_delete(concr->phrasetable,container,i,seq);
concr->phrasetable = phrasetable;
phrasetable =
phrasetable_delete(phrasetable,container,i,seq);
}
concr->phrasetable = phrasetable;
// Finaly remove the lincat object itself.
PgfConcrLincat::release(lincat);
}
concr->lincats = lincats;
@@ -2111,6 +2225,9 @@ void pgf_create_lin(PgfDB *db,
if (lin != 0) {
Namespace<PgfConcrLin> lins =
namespace_insert(concr->lins, lin);
if (lins == 0) {
throw pgf_error("A linearization function with that name already exists");
}
concr->lins = lins;
}
} PGF_API_END
@@ -2118,28 +2235,16 @@ void pgf_create_lin(PgfDB *db,
PGF_API
void pgf_drop_lin(PgfDB *db,
PgfConcrRevision revision,
PgfRevision revision, PgfConcrRevision cnc_revision,
PgfText *name, PgfExn *err)
{
PGF_API_BEGIN {
DB_scope scope(db, WRITER_SCOPE);
ref<PgfConcr> concr = db->revision2concr(revision);
ref<PgfPGF> pgf = db->revision2pgf(revision);
ref<PgfConcr> concr = db->revision2concr(cnc_revision);
ref<PgfConcrLin> lin;
Namespace<PgfConcrLin> lins =
namespace_delete(concr->lins, name, &lin);
if (lin != 0) {
object container = lin.tagged();
for (size_t i = 0; i < lin->seqs->len; i++) {
ref<PgfSequence> seq = *vector_elem(lin->seqs, i);
PgfPhrasetable phrasetable =
phrasetable_delete(concr->phrasetable,container,i,seq);
concr->phrasetable = phrasetable;
}
PgfConcrLin::release(lin);
}
concr->lins = lins;
drop_lin(concr, name);
} PGF_API_END
}
@@ -2463,7 +2568,7 @@ void pgf_set_printname(PgfDB *db, PgfConcrRevision revision,
printname->printname = textdup_db(name);
Namespace<PgfConcrPrintname> printnames =
namespace_insert(concr->printnames, printname);
namespace_update(concr->printnames, printname);
concr->printnames = printnames;
} PGF_API_END
}
@@ -2508,7 +2613,7 @@ void pgf_set_global_flag(PgfDB *db, PgfRevision revision,
PgfLiteral lit = m->match_lit(&u, value);
flag->value = lit;
Namespace<PgfFlag> gflags =
namespace_insert(pgf->gflags, flag);
namespace_update(pgf->gflags, flag);
pgf->gflags = gflags;
} PGF_API_END
}
@@ -2553,7 +2658,7 @@ void pgf_set_abstract_flag(PgfDB *db, PgfRevision revision,
PgfLiteral lit = m->match_lit(&u, value);
flag->value = lit;
Namespace<PgfFlag> aflags =
namespace_insert(pgf->abstract.aflags, flag);
namespace_update(pgf->abstract.aflags, flag);
pgf->abstract.aflags = aflags;
} PGF_API_END
}
@@ -2598,7 +2703,7 @@ void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision,
PgfLiteral lit = m->match_lit(&u, value);
flag->value = lit;
Namespace<PgfFlag> cflags =
namespace_insert(concr->cflags, flag);
namespace_update(concr->cflags, flag);
concr->cflags = cflags;
} PGF_API_END
}

6
src/runtime/c/pgf/pgf.h
View File

@@ -635,7 +635,8 @@ void pgf_create_lincat(PgfDB *db,
PgfExn *err);
PGF_API_DECL
void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision,
void pgf_drop_lincat(PgfDB *db,
PgfRevision revision, PgfConcrRevision cnc_revision,
PgfText *name, PgfExn *err);
PGF_API_DECL
@@ -646,7 +647,8 @@ void pgf_create_lin(PgfDB *db,
PgfExn *err);
PGF_API_DECL
void pgf_drop_lin(PgfDB *db, PgfConcrRevision revision,
void pgf_drop_lin(PgfDB *db,
PgfRevision revision, PgfConcrRevision cnc_revision,
PgfText *name, PgfExn *err);
PGF_API_DECL

11
src/runtime/c/pgf/reader.cxx
View File

@@ -329,6 +329,11 @@ ref<PgfAbsFun> PgfReader::read_absfun()
throw pgf_error("Unknown tag, 0 or 1 expected");
}
absfun->prob = read_prob(&absfun->name);
PgfProbspace funs_by_cat =
probspace_insert(abstract->funs_by_cat, absfun);
abstract->funs_by_cat = funs_by_cat;
return absfun;
}
@@ -410,6 +415,7 @@ void pad_probs(PgfItor *itor, PgfText *key, object value, PgfExn *err)
void PgfReader::read_abstract(ref<PgfAbstr> abstract)
{
this->abstract = abstract;
abstract->funs_by_cat = 0;
auto name = read_name();
auto aflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
@@ -842,9 +848,6 @@ ref<PgfConcr> PgfReader::read_concrete()
auto printnames = read_namespace<PgfConcrPrintname>(&PgfReader::read_printname);
concrete->printnames = printnames;
concrete->prev = 0;
concrete->next = 0;
return concrete;
}
@@ -889,6 +892,6 @@ void PgfReader::merge_pgf(ref<PgfPGF> pgf)
for (size_t i = 0; i < len; i++) {
ref<PgfConcr> concr = PgfReader::read_concrete();
pgf->concretes =
namespace_insert(pgf->concretes, concr);
namespace_update(pgf->concretes, concr);
}
}

2
src/runtime/haskell/PGF2.hsc
View File

@@ -340,7 +340,7 @@ abstractName :: PGF -> AbsName
abstractName p =
unsafePerformIO $
withForeignPtr (a_revision p) $ \c_revision ->
bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text ->
bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text -> do
peekText c_text
-- | The start category is defined in the grammar with

6
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -233,11 +233,11 @@ foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIfac
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 ()
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_drop_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
foreign import ccall pgf_has_linearization :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO CInt
@@ -371,7 +371,7 @@ utf8Length s = count 0 s
-- Exceptions
data PGFError = PGFError String String
deriving Typeable
deriving (Eq,Typeable)
instance Show PGFError where
show (PGFError loc msg) = loc++": "++msg

10
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -150,6 +150,8 @@ checkoutPGF p = do
contains %d, %x or %a then the pattern is replaced with a random
number in base 10, 16, or 36, which guarantees that the name is
unique. The returned name is the final name after the substitution.
If there is no substitution pattern in the name, and there is
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 ->
@@ -284,9 +286,9 @@ createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_
withTexts p (i+1) ss f
dropLincat :: Cat -> Transaction Concr ()
dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
dropLincat name = Transaction $ \c_db c_abstr c_revision c_exn ->
withText name $ \c_name ->
pgf_drop_lincat c_db c_revision c_name c_exn
pgf_drop_lincat c_db c_abstr c_revision c_name c_exn
createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
@@ -406,9 +408,9 @@ withBuildLinIface prods seqtbl f = do
pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
dropLin :: Fun -> Transaction Concr ()
dropLin name = Transaction $ \c_db _ 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_revision c_name c_exn
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 ->

29
src/runtime/haskell/tests/transactions.hs
View File

@@ -4,34 +4,54 @@ import PGF2.Transactions
import System.Mem
import System.Exit (exitSuccess, exitFailure)
import qualified Data.Map as Map
import Control.Exception (try)
main = do
gr1 <- readPGF "tests/basic.pgf"
let Just ty = readType "(N -> N) -> P (s z)"
excpt1 <- try (modifyPGF gr1 (createFunction "c" ty 0 [] pi) >> return ())
excpt2 <- try (modifyPGF gr1 (createCategory "N" [] pi) >> return ())
gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >>
createCategory "Q" [(Explicit,"x",ty)] pi)
gr4 <- checkoutPGF gr1
gr6 <- modifyPGF gr1 (dropFunction "ind" >> dropCategory "S")
let Just cnc6 = Map.lookup "basic_cnc" (languages gr6)
gr7 <- modifyPGF gr1 $
createConcrete "basic_eng" $ do
setConcreteFlag "test_flag" (LStr "test")
let Just cnc7 = Map.lookup "basic_eng" (languages gr7)
gr8 <- modifyPGF gr1 $
alterConcrete "basic_cnc" $ do
dropLin "z"
let Just cnc8 = Map.lookup "basic_cnc" (languages gr8)
gr9 <- modifyPGF gr1 $
alterConcrete "basic_cnc" $ do
dropLincat "N"
let Just cnc9 = Map.lookup "basic_cnc" (languages gr9)
excpt3 <- try (modifyPGF gr1 (alterConcrete "basic_foo" (return ())) >> return ())
let Just cnc = Map.lookup "basic_eng" (languages gr7)
c <- runTestTT $
TestList $
[TestCase (assertEqual "original functions" ["c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr1))
,TestCase (assertEqual "existing function" (Left (PGFError "modifyPGF" "A function with that name already exists")) excpt1)
,TestCase (assertEqual "existing category" (Left (PGFError "modifyPGF" "A category with that name already exists")) excpt2)
,TestCase (assertEqual "extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr2))
,TestCase (assertEqual "checked-out extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr4))
,TestCase (assertEqual "original categories" ["Float","Int","N","P","S","String"] (categories gr1))
,TestCase (assertEqual "extended categories" ["Float","Int","N","P","Q","S","String"] (categories gr2))
,TestCase (assertEqual "Q context" (Just [(Explicit,"x",ty)]) (categoryContext gr2 "Q"))
,TestCase (assertEqual "reduced functions" ["c","floatLit","foo","intLit","nat","s","stringLit","z"] (functions gr6))
,TestCase (assertEqual "reduced functions" ["foo","nat","s","z"] (functions gr6))
,TestCase (assertEqual "reduced categories" ["Float","Int","N","P","Q","String"] (categories gr6))
,TestCase (assertEqual "reduced lins" [False,False,False,False,True,True,False,True] (map (hasLinearization cnc6) ["c","floatLit","foo","intLit","nat","s","stringLit","z"]))
,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) (functionProbability gr1 "foo"))
@@ -40,7 +60,10 @@ main = do
,TestCase (assertEqual "new category prob" pi (categoryProbability gr2 "Q"))
,TestCase (assertEqual "empty concretes" ["basic_cnc"] (Map.keys (languages gr1)))
,TestCase (assertEqual "extended concretes" ["basic_cnc","basic_eng"] (Map.keys (languages gr7)))
,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc "test_flag"))
,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc7 "test_flag"))
,TestCase (assertEqual "alter missing concrete" (Left (PGFError "modifyPGF" "Unknown concrete syntax")) excpt3)
,TestCase (assertEqual "drop lin" (True,False) (hasLinearization cnc8 "s",hasLinearization cnc8 "z"))
,TestCase (assertEqual "drop lincat" (False,False) (hasLinearization cnc9 "s",hasLinearization cnc9 "z"))
]
performMajorGC