added the "alter lin" command

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

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 <file path>`."
+       ],
+     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",

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)

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

src/runtime/c/pgf/namespace.h

@@ -406,22 +406,26 @@ Namespace<V> namespace_insert(Namespace<V> map, ref<V> value)
 }
 
 template <class V>
-Namespace<V> namespace_update(Namespace<V> map, ref<V> value)
+Namespace<V> namespace_replace(Namespace<V> map,
+                               ref<V> value, ref<V> *old_value)
 {
-    if (map == 0)
+    if (map == 0) {
+        *old_value = 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);
+        Namespace<V> left = namespace_replace(map->left, value, old_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_update(map->right, value);
+        Namespace<V> right = namespace_replace(map->right, value, old_value);
         map = Node<ref<V>>::upd_node(map,map->left,right);
         return Node<ref<V>>::balanceR(map);
     } else {
         map = Node<ref<V>>::upd_node(map,map->left,map->right);
+        *old_value = map->value;
         map->value = value;
         return map;
     }

src/runtime/c/pgf/pgf.cxx

@@ -1364,8 +1364,9 @@ ref<PgfConcr> clone_concrete(ref<PgfPGF> pgf, ref<PgfConcr> concr)
         clone->printnames = concr->printnames;
         memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1);
 
+        ref<PgfConcr> old_concr;
         Namespace<PgfConcr> 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<PgfPGF> pgf = db->revision2pgf(revision);
+        ref<PgfConcr> concr = db->revision2concr(cnc_revision);
+
+        ref<PgfAbsFun> absfun =
+            namespace_lookup(pgf->abstract.funs, name);
+        if (absfun == 0) {
+            throw pgf_error("There is no corresponding function in the abstract syntax");
+        }
+
+        ref<PgfConcrLin> lin =
+            PgfLinBuilder(concr).build(absfun, n_prods, build, err);
+        if (lin != 0) {
+            ref<PgfConcrLin> old_lin;
+            Namespace<PgfConcrLin> 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<PgfSequence> 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<PgfConcrPrintname> old_printname;
         Namespace<PgfConcrPrintname> 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<PgfFlag> old_flag;
         Namespace<PgfFlag> 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<PgfFlag> old_flag;
         Namespace<PgfFlag> 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<PgfFlag> old_flag;
         Namespace<PgfFlag> 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
 }

src/runtime/c/pgf/reader.cxx

@@ -891,7 +891,10 @@ void PgfReader::merge_pgf(ref<PgfPGF> pgf)
     size_t len = read_len();
     for (size_t i = 0; i < len; i++) {
         ref<PgfConcr> concr = PgfReader::read_concrete();
-        pgf->concretes =
+        Namespace<PgfConcr> concretes =
-            namespace_update(pgf->concretes, concr);
+            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;
     }
 }

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

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 ->