From d274f4856ef2f976cf3786e7d6cf6fa8defc731c Mon Sep 17 00:00:00 2001 From: krangelov Date: Mon, 6 Dec 2021 15:47:57 +0100 Subject: [PATCH] compile lindef & linref rules --- src/compiler/GF/Compile/Compute/Concrete.hs | 2 + src/compiler/GF/Compile/GeneratePMCFG.hs | 64 ++++ src/compiler/GF/Compile/GrammarToPGF.hs | 7 +- src/compiler/GF/Grammar/Grammar.hs | 2 +- src/compiler/GF/Grammar/Printer.hs | 6 +- src/runtime/c/pgf/data.h | 28 +- src/runtime/c/pgf/pgf.cxx | 309 ++++++++++++++------ src/runtime/c/pgf/pgf.h | 33 ++- src/runtime/c/pgf/reader.cxx | 4 + src/runtime/c/pgf/writer.cxx | 16 +- src/runtime/haskell/PGF2.hsc | 28 +- src/runtime/haskell/PGF2/FFI.hsc | 10 +- src/runtime/haskell/PGF2/Transactions.hsc | 16 +- src/runtime/haskell/tests/basic.pgf | Bin 349 -> 416 bytes src/runtime/haskell/tests/basic.pmcfg | 17 ++ 15 files changed, 420 insertions(+), 122 deletions(-) diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index d02d90203..4dce08580 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -154,6 +154,8 @@ eval env (Table t1 t2) [] = do v1 <- eval env t1 [] return (VTable v1 v2) eval env (T (TTyped ty) cs)[]=do vty <- eval env ty [] return (VT vty env cs) +eval env (T (TWild ty) cs) []=do vty <- eval env ty [] + return (VT vty env cs) eval env (V ty ts) [] = do vty <- eval env ty [] tnks <- mapM (newThunk env) ts return (VV vty tnks) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 1422d6176..467e191f7 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -25,6 +25,7 @@ import PGF2.Transactions import qualified Data.Map.Strict as Map import Control.Monad import Data.List(mapAccumL,sortBy) +import Data.Maybe(fromMaybe) generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG opts cwd gr cmo@(cm,cmi) = do @@ -32,6 +33,25 @@ generatePMCFG opts cwd gr cmo@(cm,cmi) = do js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi)) return (cm,cmi{jments = (Map.fromAscList js)}) +addPMCFG opts cwd gr cmi (id,CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do + defs <- case mdef of + Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do + term <- mkLinDefault gr ty + pmcfgForm gr term [(Explicit,identW,typeStr)] ty + Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do + pmcfgForm gr term [(Explicit,identW,typeStr)] ty + refs <- case mref of + Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do + term <- mkLinReference gr ty + pmcfgForm gr term [(Explicit,identW,ty)] typeStr + Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do + pmcfgForm gr term [(Explicit,identW,ty)] typeStr + mprn <- case mprn of + Nothing -> return Nothing + Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do + prn <- normalForm gr prn + return (Just (L loc prn)) + return (id,CncCat mty mdef mref mprn (Just (defs,refs))) addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do rules <- checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ pmcfgForm gr term ctxt val @@ -200,3 +220,47 @@ type2fields gr = type2fields empty let Ok ts = allParamValues gr p in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts type2fields d _ = [] + +mkLinDefault :: SourceGrammar -> Type -> Check Term +mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ + where + mkDefField ty = + case ty of + Table p t -> do t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort s | s == cStr -> return (Vr varStr) + QC p -> case lookupParamValues gr p of + Ok [] -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) + Ok (v:_) -> return v + Bad msg -> fail msg + RecType r -> do + let (ls,ts) = unzip r + ts <- mapM mkDefField ts + return $ R (zipWith assign ls ts) + _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val + _ -> checkError ("linearization type field cannot be" <+> ty) + +mkLinReference :: SourceGrammar -> Type -> Check Term +mkLinReference gr typ = do + mb_term <- mkRefField typ (Vr varStr) + return (Abs Explicit varStr (fromMaybe Empty mb_term)) + where + mkRefField ty trm = + case ty of + Table pty ty -> case allParamValues gr pty of + Ok [] -> checkError ("no parameter values given to type" <+> pty) + Ok (p:ps) -> mkRefField ty (S trm p) + Bad msg -> fail msg + Sort s | s == cStr -> return (Just trm) + QC p -> return Nothing + RecType [] -> return Nothing + RecType rs -> traverse rs trm + _ | Just _ <- isTypeInts typ -> return Nothing + _ -> checkError ("linearization type field cannot be" <+> typ) + + traverse [] trm = return Nothing + traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l) + case res of + Just trm -> return (Just trm) + Nothing -> traverse rs trm diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 5dc7172d1..e3cf1630e 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -86,8 +86,11 @@ grammar2PGF opts gr am probs = do 0 -> 0 n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n) - createCncCats ((m,c),CncCat (Just (L _ ty)) _ _ _ _) = do - createLincat (i2i c) (type2fields gr ty) + createCncCats ((m,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do + createLincat (i2i c) (type2fields gr ty) lindefs linrefs + case mprn of + Nothing -> return () + Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn)) createCncCats _ = return () createCncFuns ((m,f),CncFun _ _ mprn (Just prods)) = do diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index b7011d53c..57a513178 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -329,7 +329,7 @@ data Info = | ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited -- judgements in concrete syntax - | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) lindef ini'zed, + | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, | CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC' -- indirection to module Ident diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index aa9b109a5..0d90968b1 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -28,6 +28,7 @@ import PGF2(Literal(..)) import GF.Infra.Ident import GF.Infra.Option import GF.Grammar.Values +import GF.Grammar.Predef import GF.Grammar.Grammar import GF.Text.Pretty @@ -134,9 +135,10 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) = Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' Nothing -> empty) $$ (case (mtyp,mpmcfg,q) of - (Just (L _ typ),Just rules,Internal) + (Just (L _ typ),Just (lindefs,linrefs),Internal) -> "pmcfg" <+> '{' $$ - nest 2 (vcat (map (ppPmcfgRule id [] id) rules)) $$ + nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs) $$ + vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$ '}' _ -> empty) ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) = diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 441f6cb4d..33fd7a8f9 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -103,17 +103,6 @@ typedef struct { Namespace cats; } PgfAbstr; -struct PGF_INTERNAL_DECL PgfConcrLincat { - size_t ref_count; - - ref abscat; - - ref>> fields; - PgfText name; - - static void release(ref lincat); -}; - struct PGF_INTERNAL_DECL PgfLParam { size_t i0; size_t n_terms; @@ -206,6 +195,23 @@ void pgf_symbol_free(PgfSymbol sym); PGF_INTERNAL_DECL void pgf_symbols_free(ref> syms); +struct PGF_INTERNAL_DECL PgfConcrLincat { + size_t ref_count; + + ref abscat; + + ref>> fields; + + size_t n_lindefs; + ref> args; + ref>> res; + ref>>> seqs; + + PgfText name; + + static void release(ref lincat); +}; + struct PGF_INTERNAL_DECL PgfConcrLin { size_t ref_count; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 3abb69374..a5c4ebb17 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -794,6 +794,8 @@ void pgf_get_lincat_counts_internal(object o, size_t *counts) { ref lincat = o; counts[0] = lincat->fields->len; + counts[1] = lincat->n_lindefs; + counts[2] = lincat->res->len - lincat->n_lindefs; } PGF_API @@ -811,6 +813,92 @@ void pgf_get_lin_counts_internal(object o, size_t *counts) counts[1] = lin->seqs->len / lin->res->len; } +PGF_API +PgfText *pgf_print_lindef_sig_internal(object o, size_t i) +{ + ref lincat = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + printer.efun(&lincat->name); + printer.puts(" : "); + + ref res = *vector_elem(lincat->res, i); + + if (res->vars != 0) { + printer.lvar_ranges(res->vars); + printer.puts(" . "); + } + + printer.puts(" String(0) -> "); + + printer.efun(&lincat->name); + printer.puts("("); + printer.lparam(ref::from_ptr(&res->param)); + printer.puts(")"); + + return printer.get_text(); +} + +PGF_API +PgfText *pgf_print_lindef_seq_internal(object o, size_t i, size_t j) +{ + ref lincat = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + size_t n_seqs = lincat->fields->len; + ref> syms = *vector_elem(lincat->seqs, i*n_seqs + j); + + printer.symbols(syms); + + return printer.get_text(); +} + +PGF_API +PgfText *pgf_print_linref_sig_internal(object o, size_t i) +{ + ref lincat = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + printer.efun(&lincat->name); + printer.puts(" : "); + + ref res = *vector_elem(lincat->res, lincat->n_lindefs+i); + + if (res->vars != 0) { + printer.lvar_ranges(res->vars); + printer.puts(" . "); + } + + printer.efun(&lincat->name); + printer.puts("("); + printer.lparam(vector_elem(lincat->args, lincat->n_lindefs+i)->param); + printer.puts(") -> String(0)"); + + return printer.get_text(); +} + +PGF_API +PgfText *pgf_print_linref_seq_internal(object o, size_t i) +{ + ref lincat = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + size_t n_seqs = lincat->fields->len; + ref> syms = *vector_elem(lincat->seqs, lincat->n_lindefs*n_seqs+i); + + printer.symbols(syms); + + return printer.get_text(); +} + PGF_API PgfText *pgf_print_lin_sig_internal(object o, size_t i) { @@ -1206,7 +1294,10 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface { - ref lin; + ref> args; + ref>> res; + ref>>> seqs; + size_t var_index; size_t arg_index; size_t res_index; @@ -1214,6 +1305,9 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface size_t sym_index; size_t alt_index; + size_t n_lindefs; + size_t n_linrefs; + ref> syms; size_t pre_sym_index; @@ -1222,7 +1316,72 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface "Detected incorrect use of the linearization builder"; public: - PgfLinBuilder(ref absfun, PgfConcr *concr, size_t n_prods) + PgfLinBuilder() + { + this->args = 0; + this->res = 0; + this->seqs = 0; + this->var_index = 0; + this->arg_index = 0; + this->res_index = 0; + this->seq_index = 0; + this->sym_index = (size_t) -1; + this->alt_index = (size_t) -1; + this->n_lindefs = 0; + this->n_linrefs = 0; + this->syms = 0; + this->pre_sym_index = (size_t) -1; + } + + ref build(ref abscat, PgfConcr *concr, + size_t n_fields, PgfText **fields, + size_t n_lindefs, size_t n_linrefs, + PgfBuildLinIface *build, PgfExn *err) + { + size_t n_prods = n_lindefs+n_linrefs; + this->args = vector_new(n_prods); + this->res = vector_new>(n_prods); + this->seqs = vector_new>>(n_lindefs*n_fields+n_linrefs); + this->n_lindefs = n_lindefs; + this->n_linrefs = n_linrefs; + + ref>> db_fields = vector_new>(n_fields); + for (size_t i = 0; i < n_fields; i++) { + ref field = textdup_db(fields[i]); + *vector_elem(db_fields, i) = field; + } + + ref lincat = PgfDB::malloc(abscat->name.size+1); + memcpy(&lincat->name, &abscat->name, sizeof(PgfText)+abscat->name.size+1); + lincat->ref_count = 1; + lincat->abscat = abscat; + lincat->args = args; + lincat->res = res; + lincat->seqs = seqs; + lincat->fields = db_fields; + lincat->n_lindefs = n_lindefs; + + build->build(this, err); + if (err->type == PGF_EXN_NONE && res_index != res->len) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = builder_error_msg; + } + + if (err->type != PGF_EXN_NONE) { + failed(); + for (size_t i = 0; i < n_fields; i++) { + PgfDB::free(*vector_elem(db_fields, i)); + } + PgfDB::free(db_fields); + PgfDB::free(lincat); + return 0; + } + + return lincat; + } + + ref build(ref absfun, PgfConcr *concr, size_t n_prods, + PgfBuildLinIface *build, PgfExn *err) { ref lincat = namespace_lookup(concr->lincats, &absfun->type->name); @@ -1230,14 +1389,12 @@ public: throw pgf_error("Missing linearization category"); } - ref> args = - vector_new(n_prods*absfun->type->hypos->len); - ref>> res = - vector_new>(n_prods); - ref>>> seqs = - vector_new>>(n_prods*lincat->fields->len); + this->args = vector_new(n_prods*absfun->type->hypos->len); + this->res = vector_new>(n_prods); + this->seqs = vector_new>>(n_prods*lincat->fields->len); + this->n_lindefs = n_prods; - lin = PgfDB::malloc(absfun->name.size+1); + ref lin = PgfDB::malloc(absfun->name.size+1); memcpy(&lin->name, &absfun->name, sizeof(PgfText)+absfun->name.size+1); lin->ref_count = 1; lin->absfun = absfun; @@ -1245,16 +1402,19 @@ public: lin->res = res; lin->seqs = seqs; - this->var_index = 0; - this->arg_index = 0; - this->res_index = 0; - this->seq_index = 0; - this->sym_index = (size_t) -1; - this->alt_index = (size_t) -1; + build->build(this, err); + if (err->type == PGF_EXN_NONE && res_index != res->len) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = builder_error_msg; + } - this->syms = 0; + if (err->type != PGF_EXN_NONE) { + failed(); + PgfDB::free(lin); + return 0; + } - this->pre_sym_index = (size_t) -1; + return lin; } void start_production(PgfExn *err) @@ -1263,10 +1423,10 @@ public: return; PGF_API_BEGIN { - if (res_index >= lin->res->len) + if (res_index >= res->len) throw pgf_error(builder_error_msg); var_index = 0; - *vector_elem(lin->res, res_index) = 0; + *vector_elem(res, res_index) = 0; } PGF_API_END } @@ -1276,7 +1436,7 @@ public: return; PGF_API_BEGIN { - if (arg_index >= lin->args->len) + if (arg_index >= args->len) throw pgf_error(builder_error_msg); ref param = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -1288,7 +1448,7 @@ public: param->terms[i].var = terms[2*i+1]; } - ref parg = vector_elem(lin->args, arg_index); + ref parg = vector_elem(args, arg_index); parg->param = param; arg_index++; @@ -1301,24 +1461,24 @@ public: return; PGF_API_BEGIN { - if (res_index >= lin->res->len) + if (res_index >= res->len) throw pgf_error(builder_error_msg); ref> vars = (n_vars > 0) ? vector_new(n_vars) : 0; - ref res = PgfDB::malloc(n_terms*2*sizeof(size_t)); - res->vars = vars; - res->param.i0 = i0; - res->param.n_terms = n_terms; + ref res_elem = PgfDB::malloc(n_terms*2*sizeof(size_t)); + res_elem->vars = vars; + res_elem->param.i0 = i0; + res_elem->param.n_terms = n_terms; for (size_t i = 0; i < n_terms; i++) { - res->param.terms[i].factor = terms[2*i]; - res->param.terms[i].var = terms[2*i+1]; + res_elem->param.terms[i].factor = terms[2*i]; + res_elem->param.terms[i].var = terms[2*i+1]; } - *vector_elem(lin->res, res_index) = res; + *vector_elem(res, res_index) = res_elem; } PGF_API_END } @@ -1328,17 +1488,17 @@ public: return; PGF_API_BEGIN { - if (res_index >= lin->res->len) + if (res_index >= res->len) throw pgf_error(builder_error_msg); - ref res = - *vector_elem(lin->res, res_index); + ref res_elem = + *vector_elem(res, res_index); - if (res->vars == 0 || var_index >= res->vars->len) + if (res_elem->vars == 0 || var_index >= res_elem->vars->len) throw pgf_error(builder_error_msg); ref var_range = - vector_elem(res->vars, var_index); + vector_elem(res_elem->vars, var_index); var_range->var = var; var_range->range = range; @@ -1352,11 +1512,11 @@ public: return; PGF_API_BEGIN { - if (seq_index >= lin->seqs->len) + if (seq_index >= seqs->len) throw pgf_error(builder_error_msg); syms = vector_new(n_syms); - *vector_elem(lin->seqs, seq_index) = syms; + *vector_elem(seqs, seq_index) = syms; sym_index = 0; } PGF_API_END } @@ -1485,7 +1645,7 @@ public: *vector_elem(prefixes, i) = pref; } - syms = *vector_elem(lin->seqs, seq_index); + syms = *vector_elem(seqs, seq_index); ref symkp = ref::untagged(*vector_elem(syms, pre_sym_index)); ref alt = ref::from_ptr(&symkp->alts.data[alt_index]); @@ -1506,7 +1666,7 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - syms = *vector_elem(lin->seqs, seq_index); + syms = *vector_elem(seqs, seq_index); ref symkp = ref::untagged(*vector_elem(syms, pre_sym_index)); if (alt_index >= symkp->alts.len) throw pgf_error(builder_error_msg); @@ -1524,7 +1684,7 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - syms = *vector_elem(lin->seqs, seq_index); + syms = *vector_elem(seqs, seq_index); sym_index = pre_sym_index+1; alt_index = 0; pre_sym_index = (size_t) -1; @@ -1635,49 +1795,45 @@ public: return; PGF_API_BEGIN { - size_t n_args = (lin->args->len/lin->res->len); + size_t n_args = (args->len/res->len); if (arg_index != (res_index+1)*n_args) throw pgf_error(builder_error_msg); - if (*vector_elem(lin->res, res_index) == 0) + if (*vector_elem(res, res_index) == 0) throw pgf_error(builder_error_msg); - size_t n_seqs = (lin->seqs->len/lin->res->len); - if (seq_index != (res_index+1)*n_seqs) + size_t n_seqs = ((seqs->len-n_linrefs)/(res->len-n_linrefs)); + size_t exp_index = + (res_index < n_lindefs) ? (res_index+1)*n_seqs + : n_seqs * n_lindefs + (res_index-n_lindefs+1) ; + if (seq_index != exp_index) throw pgf_error(builder_error_msg); res_index++; } PGF_API_END } - - ref done() - { - if (res_index != lin->res->len) - throw pgf_error(builder_error_msg); - return lin; - } void failed() { for (size_t i = 0; i < arg_index; i++) { - PgfDB::free(vector_elem(lin->args, i)->param); + PgfDB::free(vector_elem(args, i)->param); } - PgfDB::free(lin->args); + PgfDB::free(args); for (size_t i = 0; i < res_index; i++) { - ref res = *vector_elem(lin->res, i); - PgfDB::free(res->vars); - PgfDB::free(res); + ref res_elem = *vector_elem(res, i); + PgfDB::free(res_elem->vars); + PgfDB::free(res_elem); } - PgfDB::free(lin->res); + PgfDB::free(res); for (size_t i = 0; i < seq_index; i++) { - ref> syms = *vector_elem(lin->seqs, i); + ref> syms = *vector_elem(seqs, i); pgf_symbols_free(syms); } if (sym_index != (size_t) -1) { - ref> syms = *vector_elem(lin->seqs, seq_index); + ref> syms = *vector_elem(seqs, seq_index); if (pre_sym_index != (size_t) -1) { auto sym_kp = ref::untagged(*vector_elem(syms, pre_sym_index)); @@ -1719,10 +1875,7 @@ public: PgfDB::free(syms); } - PgfDB::free(lin->seqs); - - PgfDB::free(lin); - lin = 0; + PgfDB::free(seqs); } }; @@ -1731,6 +1884,7 @@ PGF_API void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, PgfText *name, size_t n_fields, PgfText **fields, + size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err) { PGF_API_BEGIN { @@ -1745,22 +1899,14 @@ void pgf_create_lincat(PgfDB *db, throw pgf_error("There is no corresponding category in the abstract syntax"); } - ref>> db_fields = vector_new>(n_fields); - for (size_t i = 0; i < n_fields; i++) { - ref field = textdup_db(fields[i]); - *vector_elem(db_fields, i) = field; + ref lincat = + PgfLinBuilder().build(abscat, concr, n_fields, fields, n_lindefs, n_linrefs, build, err); + if (lincat != 0) { + Namespace lincats = + namespace_insert(concr->lincats, lincat); + namespace_release(concr->lincats); + concr->lincats = lincats; } - - 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 = db_fields; - - Namespace lincats = - namespace_insert(concr->lincats, lincat); - namespace_release(concr->lincats); - concr->lincats = lincats; } PGF_API_END } @@ -1800,16 +1946,13 @@ void pgf_create_lin(PgfDB *db, throw pgf_error("There is no corresponding function in the abstract syntax"); } - PgfLinBuilder builder(absfun, concr, n_prods); - build->build(&builder, err); - if (err->type == PGF_EXN_NONE) { - ref lin = builder.done(); + ref lin = + PgfLinBuilder().build(absfun, concr, n_prods, build, err); + if (lin != 0) { Namespace lins = namespace_insert(concr->lins, lin); namespace_release(concr->lins); concr->lins = lins; - } else { - builder.failed(); } } PGF_API_END } diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 8959fd25e..fa3cfb6b5 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -397,6 +397,18 @@ PgfText *pgf_get_lincat_field_internal(object o, size_t i); PGF_API_DECL void pgf_get_lin_counts_internal(object o, size_t *counts); +PGF_API_DECL +PgfText *pgf_print_lindef_sig_internal(object o, size_t i); + +PGF_API_DECL +PgfText *pgf_print_lindef_seq_internal(object o, size_t i, size_t j); + +PGF_API_DECL +PgfText *pgf_print_linref_sig_internal(object o, size_t i); + +PGF_API_DECL +PgfText *pgf_print_linref_seq_internal(object o, size_t i); + PGF_API_DECL PgfText *pgf_print_lin_sig_internal(object o, size_t i); @@ -474,16 +486,6 @@ 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, PgfText **fields, - PgfExn *err); - -PGF_API_DECL -void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision, - PgfText *name, PgfExn *err); - #ifdef __cplusplus struct PgfLinBuilderIface { virtual void start_production(PgfExn *err)=0; @@ -554,6 +556,17 @@ struct PgfBuildLinIface { }; #endif +PGF_API_DECL +void pgf_create_lincat(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + PgfText *name, size_t n_fields, PgfText **fields, + size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, + 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, diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index c3938f589..95a6f64e2 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -530,6 +530,10 @@ ref PgfReader::read_lincat() lincat->ref_count = 1; lincat->abscat = namespace_lookup(abstract->cats, &lincat->name); lincat->fields = read_vector(&PgfReader::read_text2); + lincat->n_lindefs = read_len(); + lincat->args = read_vector(&PgfReader::read_parg); + lincat->res = read_vector(&PgfReader::read_presult2); + lincat->seqs = read_vector(&PgfReader::read_seq2); return lincat; } diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx index 55e86fb40..17939a62b 100644 --- a/src/runtime/c/pgf/writer.cxx +++ b/src/runtime/c/pgf/writer.cxx @@ -330,12 +330,6 @@ void PgfWriter::write_abstract(ref abstract) this->abstract = 0; } -void PgfWriter::write_lincat(ref lincat) -{ - write_name(&lincat->name); - write_vector(lincat->fields, &PgfWriter::write_text); -} - void PgfWriter::write_variable_range(ref var) { write_int(var->var); @@ -422,6 +416,16 @@ void PgfWriter::write_seq(ref> seq) write_vector(seq, &PgfWriter::write_symbol); } +void PgfWriter::write_lincat(ref lincat) +{ + write_name(&lincat->name); + write_vector(lincat->fields, &PgfWriter::write_text); + write_len(lincat->n_lindefs); + write_vector(lincat->args, &PgfWriter::write_parg); + write_vector(lincat->res, &PgfWriter::write_presult); + write_vector(lincat->seqs, &PgfWriter::write_seq); +} + void PgfWriter::write_lin(ref lin) { write_name(&lin->name); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 031075eef..92438b3a5 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -240,15 +240,39 @@ showPGF p = getLincats ref itor key val exn = do name <- bracket (pgf_print_ident key) free $ \c_text -> do peekText c_text - fields <- allocaBytes (1*(#size size_t)) $ \pcounts -> do + (n_fields,n_lindefs,n_linrefs) <- + allocaBytes (3*(#size size_t)) $ \pcounts -> do pgf_get_lincat_counts_internal val pcounts - n_fields <- peekElemOff pcounts 0 + n_fields <- peekElemOff pcounts 0 + n_lindefs <- peekElemOff pcounts 1 + n_linrefs <- peekElemOff pcounts 2 + return (n_fields,n_lindefs,n_linrefs) + fields <- allocaBytes (3*(#size size_t)) $ \pcounts -> do forM (init [0..n_fields]) $ \i -> do pgf_get_lincat_field_internal val i >>= peekText let def = text "lincat" <+> (text name <+> char '=' <+> char '[' $$ nest 2 (vcat (map (text.show) fields)) $$ char ']') modifyIORef ref $ (\doc -> doc $$ def) + forM_ (init [0..n_lindefs]) $ \i -> do + sig <- bracket (pgf_print_lindef_sig_internal val i) free $ \c_text -> do + fmap text (peekText c_text) + seqs <- forM (init [0..n_fields]) $ \j -> + bracket (pgf_print_lindef_seq_internal val i j) free $ \c_text -> do + fmap text (peekText c_text) + let def = text "lindef" <+> (sig <+> char '=' <+> char '[' $$ + nest 2 (vcat seqs) $$ + char ']') + modifyIORef ref $ (\doc -> doc $$ def) + forM_ (init [0..n_linrefs]) $ \i -> do + sig <- bracket (pgf_print_linref_sig_internal val i) free $ \c_text -> do + fmap text (peekText c_text) + seq <- bracket (pgf_print_linref_seq_internal val i) free $ \c_text -> do + fmap text (peekText c_text) + let def = text "linref" <+> (sig <+> char '=' <+> char '[' $$ + nest 2 seq $$ + char ']') + modifyIORef ref $ (\doc -> doc $$ def) ppLins c = unsafePerformIO $ do ref <- newIORef empty diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 44bf8ba80..8017616ac 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -111,6 +111,14 @@ foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_lindef_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) + +foreign import ccall pgf_print_lindef_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText) + +foreign import ccall pgf_print_linref_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) + +foreign import ccall pgf_print_linref_seq_internal :: Ptr () -> CSize -> IO (Ptr PgfText) + foreign import ccall pgf_get_lin_counts_internal :: Ptr () -> Ptr CSize -> IO () foreign import ccall pgf_print_lin_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText) @@ -189,7 +197,7 @@ foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIfac foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ()) -foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO () +foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 8781be269..efe9dea9d 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -216,13 +216,17 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam data Production = Production [(LVar,LIndex)] [PArg] LParam [[Symbol]] deriving (Eq,Show) -createLincat :: Cat -> [String] -> Transaction Concr () -createLincat name fields = Transaction $ \c_db c_abstr c_revision c_exn -> +createLincat :: Cat -> [String] -> [Production] -> [Production] -> Transaction Concr () +createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn -> let n_fields = length fields in withText name $ \c_name -> allocaBytes (n_fields*(#size PgfText*)) $ \c_fields -> withTexts c_fields 0 fields $ - pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral n_fields) c_fields c_exn + withBuildLinIface (lindefs++linrefs) $ \c_build -> + pgf_create_lincat c_db c_abstr c_revision c_name + (fromIntegral n_fields) c_fields + (fromIntegral (length lindefs)) (fromIntegral (length linrefs)) + c_build c_exn where withTexts p i [] f = f withTexts p i (s:ss) f = @@ -238,12 +242,16 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn -> createLin :: Fun -> [Production] -> Transaction Concr () createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn -> withText name $ \c_name -> + withBuildLinIface prods $ \c_build -> + pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + +withBuildLinIface prods f = allocaBytes (#size PgfBuildLinIface) $ \c_build -> allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl -> bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do (#poke PgfBuildLinIface, vtbl) c_build vtbl (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback - pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + f c_build where forM_ [] c_exn f = return () forM_ (x:xs) c_exn f = do diff --git a/src/runtime/haskell/tests/basic.pgf b/src/runtime/haskell/tests/basic.pgf index cdb429166faf04340fd32c4f0e92bf0019fc1a43..88c7627cc1749d1184a02b58fad45a5f0e40d891 100644 GIT binary patch delta 83 zcmcc1w19cS9}gx51_nk(1~3I8nHU*BB48qbfe|DQ5(e`b7=sy6g%GMIGcv{i04wbU A3IG5A delta 16 XcmZ3$e3xm$AJzZ{#$d+DE{rh%Fn0v) diff --git a/src/runtime/haskell/tests/basic.pmcfg b/src/runtime/haskell/tests/basic.pmcfg index 325eb08f1..c0077b8a0 100644 --- a/src/runtime/haskell/tests/basic.pmcfg +++ b/src/runtime/haskell/tests/basic.pmcfg @@ -14,11 +14,28 @@ concrete basic_cnc { lincat N = [ "s" ] + lindef N : String(0) -> N(0) = [ + <0,0> + ] + linref N : ∀{i<2} . N(i) -> String(0) = [ + <0,0> + ] lincat P = [ + ] + lindef P : String(0) -> P(0) = [ + ] + linref P : P(0) -> String(0) = [ + ] lincat S = [ "" ] + lindef S : String(0) -> S(0) = [ + <0,0> + ] + linref S : S(0) -> String(0) = [ + <0,0> + ] lin c : ∀{i<2} . N(i) -> S(0) = [ <0,0> ]