From a4ad17a47843068255774c2aabde2c9d9e6d04fd Mon Sep 17 00:00:00 2001 From: krangelov Date: Tue, 9 Nov 2021 08:50:54 +0100 Subject: [PATCH] pgf_create_lin now has access to the abstract function --- src/runtime/c/pgf/data.h | 2 ++ src/runtime/c/pgf/pgf.cxx | 23 ++++++++++-- src/runtime/c/pgf/pgf.h | 5 +-- src/runtime/c/pgf/reader.cxx | 4 +-- src/runtime/c/pgf/reader.h | 1 - src/runtime/haskell/PGF2/FFI.hsc | 29 ++++++--------- src/runtime/haskell/PGF2/Transactions.hsc | 44 +++++++++++------------ 7 files changed, 58 insertions(+), 50 deletions(-) diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index bb9a4e483..563e443ce 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -180,6 +180,8 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT { struct PGF_INTERNAL_DECL PgfConcrLin { size_t ref_count; + ref absfun; + ref> args; ref>> res; ref>>> seqs; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 7d2471c02..c8310ba2b 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -956,18 +956,35 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, } PGF_API -void pgf_create_lin(PgfDB *db, PgfConcrRevision revision, +void pgf_create_lin(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, PgfText *name, size_t n_prods, PgfExn *err) { PGF_API_BEGIN { DB_scope scope(db, WRITER_SCOPE); - ref concr = PgfDB::revision2concr(revision); + ref pgf = PgfDB::revision2pgf(revision); + ref concr = PgfDB::revision2concr(cnc_revision); + + ref absfun = + namespace_lookup(pgf->abstract.funs, name); + if (absfun == 0) { + throw pgf_error("There is no corresponding function in the abstract syntax"); + } + + ref lincat = + namespace_lookup(concr->lincats, &absfun->type->name); + if (lincat == 0) { + throw pgf_error("Missing linearization category"); + } ref lin = PgfDB::malloc(name->size+1); memcpy(&lin->name, name, sizeof(PgfText)+name->size+1); lin->ref_count = 1; - lin->res = vector_new>(n_prods); + lin->absfun = absfun; + lin->args = vector_new(n_prods*absfun->type->hypos->len); + lin->res = vector_new>(n_prods); + lin->seqs = vector_new>>(n_prods*lincat->fields->len); for (size_t i = 0; i < n_prods; i++) { } diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index e321d01e2..f93ed5768 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -419,8 +419,9 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfExn *err); PGF_API_DECL -void pgf_create_lin(PgfDB *db, PgfConcrRevision revision, - PgfText *name, size_t n_prods, PgfExn *exn); +void pgf_create_lin(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + PgfText *name, size_t n_prods, PgfExn *err); PGF_API_DECL PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision, diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 763738099..62582b413 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -7,7 +7,6 @@ PgfReader::PgfReader(FILE *in) { this->in = in; this->abstract = 0; - this->concrete = 0; } uint8_t PgfReader::read_uint8() @@ -553,6 +552,7 @@ ref PgfReader::read_lin() { ref lin = read_name(&PgfConcrLin::name); lin->ref_count = 1; + lin->absfun = namespace_lookup(abstract->funs, &lin->name); lin->args = read_vector(&PgfReader::read_parg); lin->res = read_vector(&PgfReader::read_lparam); lin->seqs = read_vector(&PgfReader::read_seq2); @@ -570,8 +570,6 @@ ref PgfReader::read_printname() ref PgfReader::read_concrete() { ref concr = read_name(&PgfConcr::name); - this->concrete = concr; - concr->ref_count = 1; concr->ref_count_ex = 0; concr->cflags = read_namespace(&PgfReader::read_flag); diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index f2ebc926f..e7ae6a959 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -80,7 +80,6 @@ public: private: FILE *in; ref abstract; - ref concrete; object read_name_internal(size_t struct_size); object read_text_internal(size_t struct_size); diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index e3303cb09..583f6b53e 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -93,34 +93,25 @@ type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO () foreign import ccall "wrapper" wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback) -foreign import ccall "pgf_iter_categories" - pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () +foreign import ccall pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () foreign import ccall pgf_iter_concretes :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () -foreign import ccall "pgf_start_cat" - pgf_start_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) +foreign import ccall pgf_start_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) -foreign import ccall "pgf/pgf.h pgf_category_context" - pgf_category_context :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo) +foreign import ccall pgf_category_context :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo) -foreign import ccall "pgf/pgf.h pgf_category_prob" - pgf_category_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t) +foreign import ccall pgf_category_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t) -foreign import ccall "pgf_iter_functions" - pgf_iter_functions :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () +foreign import ccall pgf_iter_functions :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () -foreign import ccall "pgf_iter_functions_by_cat" - pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO () +foreign import ccall pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO () -foreign import ccall "pgf_function_type" - pgf_function_type :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) +foreign import ccall pgf_function_type :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) -foreign import ccall "pgf_function_is_constructor" - pgf_function_is_constructor :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type int) +foreign import ccall pgf_function_is_constructor :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type int) -foreign import ccall "pgf_function_prob" - pgf_function_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t) +foreign import ccall pgf_function_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t) foreign import ccall pgf_concrete_name :: Ptr PgfDB -> Ptr Concr -> Ptr PgfExn -> IO (Ptr PgfText) @@ -148,7 +139,7 @@ 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_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> CSize -> 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_get_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 084a3cd55..34af825d0 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -33,27 +33,27 @@ import Control.Exception #include newtype Transaction k a = - Transaction (Ptr PgfDB -> Ptr k -> Ptr PgfExn -> IO a) + Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a) instance Functor (Transaction k) where - fmap f (Transaction g) = Transaction $ \c_db c_revision c_exn -> do - res <- g c_db c_revision c_exn + fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do + res <- g c_db c_abstr c_revision 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_revision 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_revision c_exn -> do - res <- f c_db c_revision c_exn + (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do + res <- f c_db c_abstr c_revision 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_revision c_exn + Transaction g -> g c_db c_abstr c_revision c_exn else return undefined {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the @@ -90,7 +90,7 @@ branchPGF_ c_name p (Transaction f) = c_revision <- pgf_clone_revision (a_db p) c_revision c_name 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_exn)) + then do ((restore (f (a_db p) c_revision c_revision c_exn)) `catch` (\e -> do pgf_free_revision_ (a_db p) c_revision @@ -121,63 +121,63 @@ checkoutPGF p name = return (Just (PGF (a_db p) fptr langs)) createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF () -createFunction name ty arity prob = Transaction $ \c_db c_revision c_exn -> +createFunction name ty arity prob = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> bracket (newStablePtr ty) freeStablePtr $ \c_ty -> withForeignPtr marshaller $ \m -> do pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn dropFunction :: Fun -> Transaction PGF () -dropFunction name = Transaction $ \c_db c_revision c_exn -> +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 PGF () -createCategory name hypos prob = Transaction $ \c_db c_revision c_exn -> +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 PGF () -dropCategory name = Transaction $ \c_db c_revision c_exn -> +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 createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF () -createConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn -> +createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> do bracket (pgf_create_concrete c_db c_revision c_name c_exn) (pgf_free_concr_revision_ c_db) $ \c_concr_revision -> - f c_db c_concr_revision c_exn + f c_db c_abstr c_concr_revision c_exn alterConcrete :: ConcName -> Transaction Concr () -> Transaction PGF () -alterConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn -> +alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> do c_concr_revision <- pgf_clone_concrete c_db c_revision c_name c_exn - f c_db c_concr_revision c_exn + f c_db c_abstr c_concr_revision c_exn dropConcrete :: ConcName -> Transaction PGF () -dropConcrete name = Transaction $ \c_db c_revision c_exn -> +dropConcrete name = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> do pgf_drop_concrete c_db c_revision c_name c_exn setGlobalFlag :: String -> Literal -> Transaction PGF () -setGlobalFlag name value = Transaction $ \c_db c_revision c_exn -> +setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> withForeignPtr marshaller $ \m -> pgf_set_global_flag c_db c_revision c_name c_value m c_exn setAbstractFlag :: String -> Literal -> Transaction PGF () -setAbstractFlag name value = Transaction $ \c_db c_revision c_exn -> +setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> withForeignPtr marshaller $ \m -> pgf_set_abstract_flag c_db c_revision c_name c_value m 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 -> withForeignPtr marshaller $ \m -> @@ -211,6 +211,6 @@ data Production = Production [PArg] LParam [[Symbol]] deriving (Eq,Show) createLin :: Fun -> [Production] -> Transaction Concr () -createLin name rules = Transaction $ \c_db c_revision c_exn -> +createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> - pgf_create_lin c_db c_revision c_name (fromIntegral (length rules)) c_exn + pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_exn