GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

added createCategory, dropCategory

Browse Source
This commit is contained in:
krangelov
2021-09-09 17:33:25 +02:00
parent a44787fc4e
commit f7aad0c0e0
12 changed files with 141 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/runtime/c/pgf/db.cxx
View File

@@ -988,7 +988,7 @@ PGF_INTERNAL
void PgfDB::link_transient_revision(ref<PgfPGF> pgf)
{
pgf->next = current_db->ms->transient_revisions;
if (current_db->ms->transient_revisions == 0)
if (current_db->ms->transient_revisions != 0)
current_db->ms->transient_revisions->prev = pgf;
current_db->ms->transient_revisions = pgf;
}

7
src/runtime/c/pgf/expr.cxx
View File

@@ -194,9 +194,9 @@ PgfLiteral PgfDBUnmarshaller::lstr(PgfText *val)
return ref<PgfLiteralStr>::tagged(lit_str);
}
PgfType PgfDBUnmarshaller::dtyp(int n_hypos, PgfTypeHypo *hypos,
PgfType PgfDBUnmarshaller::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
PgfText *cat,
int n_exprs, PgfExpr *exprs)
size_t n_exprs, PgfExpr *exprs)
{
ref<PgfDTyp> ty =
PgfDB::malloc<PgfDTyp>(cat->size+1);
@@ -205,8 +205,7 @@ PgfType PgfDBUnmarshaller::dtyp(int n_hypos, PgfTypeHypo *hypos,
for (size_t i = 0; i < n_hypos; i++) {
ref<PgfHypo> hypo = vector_elem(ty->hypos,i);
hypo->bind_type = hypos[i].bind_type;
hypo->cid = PgfDB::malloc<PgfText>(hypos[i].cid->size+1);
memcpy(hypo->cid, hypos[i].cid, sizeof(PgfText)+hypos[i].cid->size+1);
hypo->cid = textdup_db(hypos[i].cid);
hypo->type = m->match_type(this, hypos[i].type);
}
ty->exprs = vector_new<PgfExpr>(n_exprs);

4
src/runtime/c/pgf/expr.h
View File

@@ -116,9 +116,9 @@ struct PGF_INTERNAL_DECL PgfDBUnmarshaller : public PgfUnmarshaller {
virtual PgfLiteral lint(size_t size, uintmax_t *val);
virtual PgfLiteral lflt(double val);
virtual PgfLiteral lstr(PgfText *val);
virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
PgfText *cat,
int n_exprs, PgfExpr *exprs);
size_t n_exprs, PgfExpr *exprs);
virtual void free_ref(object x);
};

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

@@ -453,9 +453,7 @@ PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
if (pgf->gflags != 0)
pgf->gflags->ref_count++;
new_pgf->abstract.name =
PgfDB::malloc<PgfText>(pgf->abstract.name->size+1);
memcpy(new_pgf->abstract.name, pgf->abstract.name, sizeof(PgfText)+pgf->abstract.name->size+1);
new_pgf->abstract.name = textdup_db(&(*pgf->abstract.name));
new_pgf->abstract.aflags = pgf->abstract.aflags;
if (pgf->abstract.aflags != 0)
@@ -495,7 +493,8 @@ void pgf_commit_revision(PgfDB *db, PgfRevision revision,
PgfDB::unlink_transient_revision(new_pgf);
PgfDB::set_revision(new_pgf);
PgfDB::link_transient_revision(old_pgf);
if (old_pgf != 0)
PgfDB::link_transient_revision(old_pgf);
} PGF_API_END
}
@@ -557,3 +556,51 @@ void pgf_drop_function(PgfDB *db, PgfRevision revision,
pgf->abstract.funs = funs;
} PGF_API_END
}
PGF_API
void pgf_create_category(PgfDB *db, PgfRevision revision,
PgfText *name,
size_t n_hypos, PgfTypeHypo *context, prob_t prob,
PgfMarshaller *m,
PgfExn *err)
{
PGF_API_BEGIN {
DB_scope scope(db, WRITER_SCOPE);
PgfDBUnmarshaller u(m);
ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
ref<PgfAbsCat> abscat = PgfDB::malloc<PgfAbsCat>(name->size+1);
abscat->context = vector_new<PgfHypo>(n_hypos);
abscat->prob = prob;
memcpy(&abscat->name, name, sizeof(PgfText)+name->size+1);
for (size_t i = 0; i < n_hypos; i++) {
vector_elem(abscat->context, i)->bind_type = context[i].bind_type;
vector_elem(abscat->context, i)->cid = textdup_db(context[i].cid);
vector_elem(abscat->context, i)->type = m->match_type(&u, context[i].type);
}
Namespace<PgfAbsCat> cats =
namespace_insert(pgf->abstract.cats, abscat);
namespace_release(pgf->abstract.cats);
pgf->abstract.cats = cats;
} PGF_API_END
}
PGF_API
void pgf_drop_category(PgfDB *db, PgfRevision revision,
PgfText *name,
PgfExn *err)
{
PGF_API_BEGIN {
DB_scope scope(db, WRITER_SCOPE);
ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
Namespace<PgfAbsCat> cats =
namespace_delete(pgf->abstract.cats, name);
namespace_release(pgf->abstract.cats);
pgf->abstract.cats = cats;
} PGF_API_END
}

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

@@ -164,9 +164,9 @@ struct PgfUnmarshaller {
virtual PgfLiteral lint(size_t size, uintmax_t *v)=0;
virtual PgfLiteral lflt(double v)=0;
virtual PgfLiteral lstr(PgfText *v)=0;
virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
PgfText *cat,
int n_exprs, PgfExpr *exprs)=0;
size_t n_exprs, PgfExpr *exprs)=0;
virtual void free_ref(object x)=0;
};
@@ -347,4 +347,16 @@ void pgf_drop_function(PgfDB *db, PgfRevision revision,
PgfText *name,
PgfExn *err);
PGF_API_DECL
void pgf_create_category(PgfDB *db, PgfRevision revision,
PgfText *name,
size_t n_hypos, PgfTypeHypo *context, prob_t prob,
PgfMarshaller *m,
PgfExn *err);
PGF_API_DECL
void pgf_drop_category(PgfDB *db, PgfRevision revision,
PgfText *name,
PgfExn *err);
#endif // PGF_H_

4
src/runtime/c/pgf/printer.cxx
View File

@@ -380,9 +380,9 @@ PgfLiteral PgfPrinter::lstr(PgfText *v)
return 0;
}
PgfType PgfPrinter::dtyp(int n_hypos, PgfTypeHypo *hypos,
PgfType PgfPrinter::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
PgfText *cat,
int n_exprs, PgfExpr *exprs)
size_t n_exprs, PgfExpr *exprs)
{
bool p = (prio > 0 && n_hypos > 0) ||
(prio > 3 && n_exprs > 0);

4
src/runtime/c/pgf/printer.h
View File

@@ -61,9 +61,9 @@ public:
virtual PgfLiteral lint(size_t size, uintmax_t *v);
virtual PgfLiteral lflt(double v);
virtual PgfLiteral lstr(PgfText *v);
virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
PgfText *cat,
int n_exprs, PgfExpr *exprs);
size_t n_exprs, PgfExpr *exprs);
virtual void free_ref(object x);
};

8
src/runtime/c/pgf/text.cxx
View File

@@ -26,6 +26,14 @@ PgfText* textdup(PgfText *t1)
return t2;
}
PGF_INTERNAL
ref<PgfText> textdup_db(PgfText *t1)
{
ref<PgfText> t2 = PgfDB::malloc<PgfText>(t1->size+1);
memcpy(&(*t2), t1, sizeof(PgfText)+t1->size+1);
return t2;
}
PGF_API uint32_t
pgf_utf8_decode(const uint8_t** src_inout)
{

3
src/runtime/c/pgf/text.h
View File

@@ -7,6 +7,9 @@ int textcmp(PgfText *t1, PgfText *t2);
PGF_INTERNAL_DECL
PgfText* textdup(PgfText *t1);
PGF_INTERNAL_DECL
ref<PgfText> textdup_db(PgfText *t1);
PGF_API uint32_t
pgf_utf8_decode(const uint8_t** src_inout);

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

@@ -118,6 +118,10 @@ foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr
foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
-----------------------------------------------------------------------
-- Texts
@@ -310,7 +314,7 @@ foreign import ccall "dynamic"
foreign import ccall "wrapper"
wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun)
type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
foreign import ccall "dynamic"
callDTypFun :: FunPtr DTypFun -> DTypFun
@@ -397,21 +401,19 @@ marshaller = unsafePerformIO $ do
ty <- deRefStablePtr c_ty
case ty of
DTyp hypos cat es -> let n_hypos = length hypos
in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
in withHypos hypos $ \n_hypos c_hypos ->
withText cat $ \c_cat ->
mask_ $ do
marshalHypos c_hypos hypos
c_es <- mapM newStablePtr es
res <- withArray c_es $ \c_exprs -> do
fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
callDTypFun fun u
(fromIntegral n_hypos)
n_hypos
c_hypos
c_cat
(fromIntegral (length es))
c_exprs
mapM_ freeStablePtr c_es
freeHypos c_hypos n_hypos
return res
where
marshalHypos _ [] = return ()
@@ -533,3 +535,26 @@ marshalBindType Implicit = (#const PGF_BIND_TYPE_IMPLICIT)
unmarshalBindType :: (#type PgfBindType) -> BindType
unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
withHypos hypos f =
let n_hypos = length hypos
in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
mask_ $ do
marshalHypos c_hypos hypos
res <- f (fromIntegral n_hypos :: CSize) c_hypos
freeHypos n_hypos c_hypos
return res
where
marshalHypos _ [] = return ()
marshalHypos ptr ((bt,var,ty):hs) = do
(#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
newText var >>= (#poke PgfTypeHypo, cid) ptr
newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
freeHypos 0 ptr = return ()
freeHypos n ptr = do
(#peek PgfTypeHypo, cid) ptr >>= free
(#peek PgfTypeHypo, type) ptr >>= freeStablePtr
freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))

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

@@ -5,6 +5,8 @@ module PGF2.Transactions
, checkoutPGF
, createFunction
, dropFunction
, createCategory
, dropCategory
) where
import PGF2.FFI
@@ -116,3 +118,15 @@ 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
createCategory :: Fun -> [Hypo] -> Float -> Transaction ()
createCategory name hypos prob = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name ->
withHypos hypos $ \n_hypos c_hypos ->
withForeignPtr marshaller $ \m -> do
pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn
dropCategory :: Cat -> Transaction ()
dropCategory name = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name -> do
pgf_drop_category c_db c_revision c_name c_exn

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

@@ -6,13 +6,15 @@ main = do
gr1 <- readPGF "tests/basic.pgf"
let Just ty = readType "(N -> N) -> P (s z)"
gr2 <- modifyPGF gr1 (createFunction "foo" ty pi)
gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty pi)
gr2 <- modifyPGF gr1 (createFunction "foo" ty pi >>
createCategory "Q" [(Explicit,"x",ty)] pi)
gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty pi >>
createCategory "R" [(Explicit,"x",ty)] pi)
Just gr4 <- checkoutPGF gr1 "master"
Just gr5 <- checkoutPGF gr1 "bar_branch"
gr6 <- modifyPGF gr1 (dropFunction "ind")
gr6 <- modifyPGF gr1 (dropFunction "ind" >> dropCategory "S")
runTestTTAndExit $
TestList $
@@ -21,7 +23,13 @@ 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 "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 "branched categories" ["Float","Int","N","P","R","S","String"] (categories gr3))
,TestCase (assertEqual "Q context" [(Explicit,"x",ty)] (categoryContext gr2 "Q"))
,TestCase (assertEqual "R context" [(Explicit,"x",ty)] (categoryContext gr3 "R"))
,TestCase (assertEqual "reduced functions" ["c","s","z"] (functions gr6))
,TestCase (assertEqual "reduced categories" ["Float","Int","N","P","String"] (categories 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"))