From 9dc36a0f5ff3a9c428c948c728d967a69945a9f2 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 7 Mar 2023 15:29:58 +0100 Subject: [PATCH] added the "alter lin" command --- src/compiler/GF/Command/Abstract.hs | 2 +- src/compiler/GF/Command/Commands.hs | 14 +++++ src/compiler/GF/Command/Parse.hs | 4 +- src/compiler/GF/Interactive.hs | 6 +- src/runtime/c/pgf/namespace.h | 12 ++-- src/runtime/c/pgf/pgf.cxx | 71 +++++++++++++++++++++-- src/runtime/c/pgf/reader.cxx | 7 ++- src/runtime/haskell/PGF2/FFI.hsc | 2 + src/runtime/haskell/PGF2/Transactions.hsc | 8 ++- 9 files changed, 108 insertions(+), 18 deletions(-) diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index e1b4c5871..d828d4bef 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/src/compiler/GF/Command/Abstract.hs @@ -17,7 +17,7 @@ data TransactionCommand = CreateFun [Option] Fun Type | CreateCat [Option] Cat [Hypo] | CreateConcrete [Option] ConcName - | CreateLin [Option] Fun Term + | CreateLin [Option] Fun Term Bool | CreateLincat [Option] Cat Term | DropFun [Option] Fun | DropCat [Option] Cat diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index f16375da9..e1ae51bea 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -716,6 +716,20 @@ pgfCommands = Map.fromList [ ], needsTypeCheck = False }), + ("a", emptyCommandInfo { + longname = "alter", + syntax = "alter lin f = ..", + synopsis = "Dynamically updates the linearization of a function in the current grammar.", + explanation = unlines [ + "The syntax is the same as if the definition was in a module. If you want to use", + "any operations inside the lin definition, you should import them", + "by using the command `i -resource `." + ], + flags = [ + ("lang","the language in which to alter the lin") + ], + needsTypeCheck = False + }), ("d", emptyCommandInfo { longname = "drop", syntax = "drop fun f; drop cat c; drop concrete l; drop lin c; or drop lincat c", diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index bd5920890..b90814f35 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/src/compiler/GF/Command/Parse.hs @@ -82,7 +82,7 @@ pTransactionCommand = do | take 1 cmd == "d" -> do name <- pIdent return (DropConcrete opts name) - "lin" | take 1 cmd == "c" -> do + "lin" | elem (take 1 cmd) ["c","a"] -> do f <- pIdent skipSpaces args <- sepBy pIdent skipSpaces @@ -92,7 +92,7 @@ pTransactionCommand = do t <- readS_to_P (\s -> case runPartial pTerm s of Right (s,t) -> [(t,s)] _ -> []) - return (CreateLin opts f (foldr (Abs Explicit . identS) t args)) + return (CreateLin opts f (foldr (Abs Explicit . identS) t args) (take 1 cmd == "a")) | take 1 cmd == "d" -> do f <- pIdent return (DropLin opts f) diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index dd11f6f48..ca781972f 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -138,7 +138,7 @@ execute1 readNGF s0 = continue _ -> do putStrLnE $ "no import in history" continue - (w :ws) | w == "c" || w == "d" -> do + (w :ws) | elem w ["c","a","d"] -> do case readTransactionCommand s0 of Just cmd -> do checkout env <- gets pgfenv @@ -282,7 +282,7 @@ transactionCommand (CreateCat opts c ctxt) pgf mb_txnid = do transactionCommand (CreateConcrete opts name) pgf mb_txnid = do lift $ updatePGF pgf mb_txnid (createConcrete name (return ())) return () -transactionCommand (CreateLin opts f t) pgf mb_txnid = do +transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do sgr <- getGrammar lang <- optLang pgf opts mo <- maybe (fail "no source grammar in scope") return $ @@ -297,7 +297,7 @@ transactionCommand (CreateLin opts f t) pgf mb_txnid = do Just fields -> case runCheck (compileLinTerm sgr mo t (type2term mo ty)) of Ok ((prods,seqtbl,fields'),_) | fields == fields' -> do - createLin f prods seqtbl + (if is_alter then alterLin else createLin) f prods seqtbl return () | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match" Bad msg -> fail msg diff --git a/src/runtime/c/pgf/namespace.h b/src/runtime/c/pgf/namespace.h index 92b72b82e..dfbd999b4 100644 --- a/src/runtime/c/pgf/namespace.h +++ b/src/runtime/c/pgf/namespace.h @@ -406,22 +406,26 @@ Namespace namespace_insert(Namespace map, ref value) } template -Namespace namespace_update(Namespace map, ref value) +Namespace namespace_replace(Namespace map, + ref value, ref *old_value) { - if (map == 0) + if (map == 0) { + *old_value = 0; return Node>::new_node(value); + } int cmp = textcmp(&value->name,&map->value->name); if (cmp < 0) { - Namespace left = namespace_update(map->left, value); + Namespace left = namespace_replace(map->left, value, old_value); map = Node>::upd_node(map,left,map->right); return Node>::balanceL(map); } else if (cmp > 0) { - Namespace right = namespace_update(map->right, value); + Namespace right = namespace_replace(map->right, value, old_value); map = Node>::upd_node(map,map->left,right); return Node>::balanceR(map); } else { map = Node>::upd_node(map,map->left,map->right); + *old_value = map->value; map->value = value; return map; } diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index ea970d9fc..f59aa6973 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -1364,8 +1364,9 @@ ref clone_concrete(ref pgf, ref concr) clone->printnames = concr->printnames; memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1); + ref old_concr; Namespace concrs = - namespace_update(pgf->concretes, clone); + namespace_replace(pgf->concretes, clone, &old_concr); pgf->concretes = concrs; PgfDB::free(concr, concr->name.size+1); @@ -2301,6 +2302,47 @@ void pgf_create_lin(PgfDB *db, } PGF_API_END } +PGF_API +void pgf_alter_lin(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + PgfText *name, size_t n_prods, + PgfBuildLinIface *build, + PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, WRITER_SCOPE); + + ref pgf = db->revision2pgf(revision); + ref concr = db->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 lin = + PgfLinBuilder(concr).build(absfun, n_prods, build, err); + if (lin != 0) { + ref old_lin; + Namespace lins = + namespace_replace(concr->lins, lin, &old_lin); + concr->lins = lins; + if (old_lin != 0) { + object container = old_lin.tagged(); + PgfPhrasetable phrasetable = concr->phrasetable; + for (size_t i = 0; i < old_lin->seqs->len; i++) { + ref seq = *vector_elem(old_lin->seqs, i); + phrasetable = + phrasetable_delete(phrasetable,container,i,seq); + } + concr->phrasetable = phrasetable; + PgfConcrLin::release(old_lin); + } + } + } PGF_API_END +} + PGF_API void pgf_drop_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, @@ -2635,8 +2677,12 @@ void pgf_set_printname(PgfDB *db, PgfConcrRevision revision, memcpy(&printname->name, fun, sizeof(PgfText)+fun->size+1); printname->printname = textdup_db(name); + ref old_printname; Namespace printnames = - namespace_update(concr->printnames, printname); + namespace_replace(concr->printnames, printname, &old_printname); + if (old_printname != 0) { + PgfConcrPrintname::release(old_printname); + } concr->printnames = printnames; } PGF_API_END } @@ -2680,8 +2726,13 @@ void pgf_set_global_flag(PgfDB *db, PgfRevision revision, memcpy(&flag->name, name, sizeof(PgfText)+name->size+1); PgfLiteral lit = m->match_lit(&u, value); flag->value = lit; + + ref old_flag; Namespace gflags = - namespace_update(pgf->gflags, flag); + namespace_replace(pgf->gflags, flag, &old_flag); + if (old_flag != 0) { + PgfFlag::release(old_flag); + } pgf->gflags = gflags; } PGF_API_END } @@ -2725,8 +2776,13 @@ void pgf_set_abstract_flag(PgfDB *db, PgfRevision revision, memcpy(&flag->name, name, sizeof(PgfText)+name->size+1); PgfLiteral lit = m->match_lit(&u, value); flag->value = lit; + + ref old_flag; Namespace aflags = - namespace_update(pgf->abstract.aflags, flag); + namespace_replace(pgf->abstract.aflags, flag, &old_flag); + if (old_flag != 0) { + PgfFlag::release(old_flag); + } pgf->abstract.aflags = aflags; } PGF_API_END } @@ -2770,8 +2826,13 @@ void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision, memcpy(&flag->name, name, sizeof(PgfText)+name->size+1); PgfLiteral lit = m->match_lit(&u, value); flag->value = lit; + + ref old_flag; Namespace cflags = - namespace_update(concr->cflags, flag); + namespace_replace(concr->cflags, flag, &old_flag); + if (old_flag != 0) { + PgfFlag::release(old_flag); + } concr->cflags = cflags; } PGF_API_END } diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 1459525c5..26355bb8a 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -891,7 +891,10 @@ void PgfReader::merge_pgf(ref pgf) size_t len = read_len(); for (size_t i = 0; i < len; i++) { ref concr = PgfReader::read_concrete(); - pgf->concretes = - namespace_update(pgf->concretes, concr); + Namespace concretes = + namespace_insert(pgf->concretes, concr); + if (concretes != 0) + throw pgf_error("One and the same concrete syntax is included in several PGF files"); + pgf->concretes = concretes; } } diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index f3c55efb0..d3b2b2959 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -243,6 +243,8 @@ foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () +foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> 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 diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 0a848b5b0..6d99bfe94 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -29,7 +29,7 @@ module PGF2.Transactions , SeqTable , createLincat , dropLincat - , createLin + , createLin, alterLin , dropLin , setPrintName , getFunctionType @@ -296,6 +296,12 @@ createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> withBuildLinIface prods seqtbl $ \c_build -> pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn +alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable +alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> + withText name $ \c_name -> + withBuildLinIface prods seqtbl $ \c_build -> + pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + withBuildLinIface prods seqtbl f = do ref <- newIORef seqtbl (allocaBytes (#size PgfBuildLinIface) $ \c_build ->