diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 563e443ce..4bd31e47b 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -106,6 +106,9 @@ typedef struct { struct PGF_INTERNAL_DECL PgfConcrLincat { size_t ref_count; + + ref abscat; + ref>> fields; PgfText name; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index c8310ba2b..dccd8c394 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -955,6 +955,56 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, } PGF_API_END } +PGF_API +void pgf_create_lincat(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + PgfText *name, size_t n_fields, PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, WRITER_SCOPE); + + ref pgf = PgfDB::revision2pgf(revision); + ref concr = PgfDB::revision2concr(cnc_revision); + + ref abscat = + namespace_lookup(pgf->abstract.cats, name); + if (abscat == 0) { + throw pgf_error("There is no corresponding category in the abstract syntax"); + } + + ref lincat = PgfDB::malloc(name->size+1); + memcpy(&lincat->name, name, sizeof(PgfText)+name->size+1); + lincat->ref_count = 1; + lincat->abscat = abscat; + lincat->fields = vector_new>(n_fields); + + for (size_t i = 0; i < n_fields; i++) { + } + + Namespace lincats = + namespace_insert(concr->lincats, lincat); + namespace_release(concr->lincats); + concr->lincats = lincats; + } PGF_API_END +} + +PGF_API +void pgf_drop_lincat(PgfDB *db, + PgfConcrRevision revision, + PgfText *name, PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, WRITER_SCOPE); + + ref concr = PgfDB::revision2concr(revision); + + Namespace lincats = + namespace_delete(concr->lincats, name); + namespace_release(concr->lincats); + concr->lincats = lincats; + } PGF_API_END +} + PGF_API void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, @@ -996,6 +1046,41 @@ void pgf_create_lin(PgfDB *db, } PGF_API_END } +PGF_API +void pgf_drop_lin(PgfDB *db, + PgfConcrRevision revision, + PgfText *name, PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, WRITER_SCOPE); + + ref concr = PgfDB::revision2concr(revision); + + Namespace lins = + namespace_delete(concr->lins, name); + namespace_release(concr->lins); + concr->lins = lins; + } PGF_API_END +} + +PGF_API +int pgf_has_linearization(PgfDB *db, PgfConcrRevision revision, + PgfText *name, PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + + ref concr = PgfDB::revision2concr(revision); + + ref lin = + namespace_lookup(concr->lins, name); + + return (lin != 0); + } PGF_API_END + + return 0; +} + PGF_API PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index f93ed5768..b4f02aaf7 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -418,11 +418,28 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfText *name, PgfExn *err); +PGF_API_DECL +void pgf_create_lincat(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + PgfText *name, size_t n_fields, PgfExn *err); + +PGF_API_DECL +void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision, + PgfText *name, PgfExn *err); + PGF_API_DECL void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, PgfText *name, size_t n_prods, PgfExn *err); +PGF_API_DECL +void pgf_drop_lin(PgfDB *db, PgfConcrRevision revision, + PgfText *name, PgfExn *err); + +PGF_API_DECL +int pgf_has_linearization(PgfDB *db, PgfConcrRevision revision, + PgfText *name, PgfExn *err); + PGF_API_DECL PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 62582b413..21ac4d020 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -544,6 +544,7 @@ ref PgfReader::read_lincat() { ref lincat = read_name(&PgfConcrLincat::name); lincat->ref_count = 1; + lincat->abscat = namespace_lookup(abstract->cats, &lincat->name); lincat->fields = read_vector(&PgfReader::read_text2); return lincat; } diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index afe05fc9e..dbd2a0fff 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -433,7 +433,12 @@ complete = error "TODO: complete" -- | Returns True if there is a linearization defined for that function in that language hasLinearization :: Concr -> Fun -> Bool -hasLinearization = error "TODO: linearize" +hasLinearization c name = + unsafePerformIO $ + withText name $ \c_name -> + withForeignPtr (c_revision c) $ \c_revision -> do + c_res <- withPgfExn "hasLinearization" (pgf_has_linearization (c_db c) c_revision c_name) + return (c_res /= 0) -- | Linearizes an expression as a string in the language linearize :: Concr -> Expr -> String diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 583f6b53e..9202a3d00 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -139,8 +139,16 @@ foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText - foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () +foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO () + +foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () + foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO () +foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () + +foreign import ccall pgf_has_linearization :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO CInt + foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal) foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 34af825d0..7adbea58b 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -20,7 +20,10 @@ module PGF2.Transactions , alterConcrete , dropConcrete , setConcreteFlag + , createLincat + , dropLincat , createLin + , dropLin ) where import PGF2.FFI @@ -210,7 +213,22 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam data Production = Production [PArg] LParam [[Symbol]] deriving (Eq,Show) +createLincat :: Cat -> [String] -> Transaction Concr () +createLincat name fields = Transaction $ \c_db c_abstr c_revision c_exn -> + withText name $ \c_name -> + pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral (length fields)) c_exn + +dropLincat :: Cat -> Transaction Concr () +dropLincat name = Transaction $ \c_db _ c_revision c_exn -> + withText name $ \c_name -> + pgf_drop_lincat c_db c_revision c_name c_exn + createLin :: Fun -> [Production] -> Transaction Concr () createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_exn + +dropLin :: Fun -> Transaction Concr () +dropLin name = Transaction $ \c_db _ c_revision c_exn -> + withText name $ \c_name -> + pgf_drop_lin c_db c_revision c_name c_exn