pgf_create_lin now has access to the abstract function

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<PgfAbsFun> absfun;
+
     ref<Vector<PgfPArg>> args;
     ref<Vector<ref<PgfLParam>>> res;
     ref<Vector<ref<Vector<PgfSymbol>>>> seqs;

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<PgfConcr> concr = PgfDB::revision2concr(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+        ref<PgfConcr> concr = PgfDB::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<PgfConcrLincat> lincat =
+            namespace_lookup(concr->lincats, &absfun->type->name);
+        if (lincat == 0) {
+            throw pgf_error("Missing linearization category");
+        }
 
         ref<PgfConcrLin> lin = PgfDB::malloc<PgfConcrLin>(name->size+1);
         memcpy(&lin->name, name, sizeof(PgfText)+name->size+1);
         lin->ref_count = 1;
+        lin->absfun = absfun;
+        lin->args = vector_new<PgfPArg>(n_prods*absfun->type->hypos->len);
         lin->res  = vector_new<ref<PgfLParam>>(n_prods);
+        lin->seqs = vector_new<ref<Vector<PgfSymbol>>>(n_prods*lincat->fields->len);
 
         for (size_t i = 0; i < n_prods; i++) {
         }

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,
+void pgf_create_lin(PgfDB *db,
-                    PgfText *name, size_t n_prods, PgfExn *exn);
+                    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,

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<PgfConcrLin> PgfReader::read_lin()
 {
     ref<PgfConcrLin> 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<PgfConcrPrintname> PgfReader::read_printname()
 ref<PgfConcr> PgfReader::read_concrete()
 {
     ref<PgfConcr> concr = read_name(&PgfConcr::name);
-    this->concrete = concr;
-
     concr->ref_count    = 1;
     concr->ref_count_ex = 0;
 	concr->cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);

src/runtime/c/pgf/reader.h

@@ -80,7 +80,6 @@ public:
 private:
     FILE *in;
     ref<PgfAbstr> abstract;
-    ref<PgfConcr> concrete;
 
     object read_name_internal(size_t struct_size);
     object read_text_internal(size_t struct_size);

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"
+foreign import ccall pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
-  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"
+foreign import ccall pgf_start_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
-  pgf_start_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
-foreign import ccall "pgf/pgf.h pgf_category_context"
+foreign import ccall pgf_category_context :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)
-  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"
+foreign import ccall pgf_category_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
-  pgf_category_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
 
-foreign import ccall "pgf_iter_functions"
+foreign import ccall pgf_iter_functions :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
-  pgf_iter_functions :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
-foreign import ccall "pgf_iter_functions_by_cat"
+foreign import ccall pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
-  pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
-foreign import ccall "pgf_function_type"
+foreign import ccall pgf_function_type :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
-   pgf_function_type :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
-foreign import ccall "pgf_function_is_constructor"
+foreign import ccall pgf_function_is_constructor :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
-   pgf_function_is_constructor :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
 
-foreign import ccall "pgf_function_prob"
+foreign import ccall pgf_function_prob :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
-   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)
 

src/runtime/haskell/PGF2/Transactions.hsc

@@ -33,27 +33,27 @@ import Control.Exception
 #include <pgf/pgf.h>
 
 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
+  fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do
-    res <- g c_db c_revision c_exn
+    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
+  (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do
-    res <- f c_db c_revision c_exn
+    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