diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 07dbe5f42..cf004efa3 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -16,6 +16,7 @@ libpgf_la_SOURCES = \ pgf/reader.cxx \ pgf/reader.h \ pgf/data.h \ + pgf/expr.cxx \ pgf/expr.h \ pgf/namespace.h diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index db7394bd8..658f74d88 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -1,9 +1,7 @@ #ifndef PGF_DATA_H_ #define PGF_DATA_H_ -#include #include -#include #include #include #include @@ -121,9 +119,15 @@ struct PGF_INTERNAL_DECL PgfPGFRoot { #pragma GCC diagnostic ignored "-Wattributes" struct PgfPGF : DB { - PGF_INTERNAL_DECL PgfPGF(const char* fpath, int flags, int mode) - : DB(fpath, flags, mode) {}; - PGF_INTERNAL_DECL ~PgfPGF() {}; + PGF_INTERNAL_DECL PgfPGF(const char* fpath, int flags, int mode, + PgfUnmarshaller *unmarshaller) + : DB(fpath, flags, mode) + { u = unmarshaller; }; + + PGF_INTERNAL_DECL ~PgfPGF() + { u->free_me(u); }; + + PgfUnmarshaller *u; }; #pragma GCC diagnostic pop diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index 1bdc5d802..203ee473a 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -7,13 +7,6 @@ typedef variant PgfExpr; struct PgfHypo; struct PgfType; -typedef int PgfMetaId; - -typedef enum { - PGF_BIND_TYPE_EXPLICIT, - PGF_BIND_TYPE_IMPLICIT -} PgfBindType; - /// A literal for an abstract syntax tree typedef variant PgfLiteral; @@ -106,4 +99,13 @@ typedef struct { PgfExpr expr; } PgfExprProb; +PGF_INTERNAL_DECL +uintptr_t pgf_unmarshall_literal(PgfUnmarshaller *u, PgfLiteral l); + +PGF_INTERNAL_DECL +uintptr_t pgf_unmarshall_expr(PgfUnmarshaller *u, PgfExpr e); + +PGF_INTERNAL_DECL +uintptr_t pgf_unmarshall_type(PgfUnmarshaller *u, PgfType *tp); + #endif /* EXPR_H_ */ diff --git a/src/runtime/c/pgf/namespace.h b/src/runtime/c/pgf/namespace.h index f89008fd0..f8d3f7635 100644 --- a/src/runtime/c/pgf/namespace.h +++ b/src/runtime/c/pgf/namespace.h @@ -216,10 +216,10 @@ Namespace namespace_insert(Namespace map, ref value) } template -ref namespace_lookup(Namespace map, const char *name) +ref namespace_lookup(Namespace map, PgfText *name) { while (map != 0) { - int cmp = strcmp(name,map->value->name); + int cmp = textcmp(name,&map->value->name); if (cmp < 0) map = map->left; else if (cmp > 0) @@ -227,7 +227,7 @@ ref namespace_lookup(Namespace map, const char *name) else return map->value; } - return NULL; + return 0; } template diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 9c3f34eeb..f00a1c4f6 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -11,14 +11,16 @@ pgf_exn_clear(PgfExn* err) } PGF_API -PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err) +PgfPGF *pgf_read_pgf(const char* fpath, + PgfUnmarshaller *unmarshaller, + PgfExn* err) { PgfPGF *pgf = NULL; pgf_exn_clear(err); try { - pgf = new PgfPGF(NULL, 0, 0); + pgf = new PgfPGF(NULL, 0, 0, unmarshaller); std::ifstream in(fpath, std::ios::binary); if (in.fail()) { @@ -50,14 +52,16 @@ PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err) } PGF_API -PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err) +PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, + PgfUnmarshaller *unmarshaller, + PgfExn* err) { PgfPGF *pgf = NULL; pgf_exn_clear(err); try { - pgf = new PgfPGF(ngf_path, O_CREAT | O_EXCL | O_RDWR, S_IRUSR | S_IWUSR); + pgf = new PgfPGF(ngf_path, O_CREAT | O_EXCL | O_RDWR, S_IRUSR | S_IWUSR, unmarshaller); std::ifstream in(pgf_path, std::ios::binary); if (in.fail()) { @@ -93,7 +97,9 @@ PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err) } PGF_API -PgfPGF *pgf_read_ngf(const char *fpath, PgfExn* err) +PgfPGF *pgf_read_ngf(const char *fpath, + PgfUnmarshaller *unmarshaller, + PgfExn* err) { PgfPGF *pgf = NULL; @@ -101,7 +107,7 @@ PgfPGF *pgf_read_ngf(const char *fpath, PgfExn* err) bool is_new = false; try { - pgf = new PgfPGF(fpath, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR); + pgf = new PgfPGF(fpath, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR, unmarshaller); { DB_scope scope(pgf, WRITER_SCOPE); @@ -195,3 +201,16 @@ void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor) helper.itor = itor; namespace_iter(pgf->get_root()->abstract.funs, &helper); } + +PGF_API uintptr_t +pgf_function_type(PgfPGF* pgf, PgfText *funname) +{ + DB_scope scope(pgf, READER_SCOPE); + + ref absfun = + namespace_lookup(pgf->get_root()->abstract.funs, funname); + if (absfun == 0) + return 0; + + return pgf_unmarshall_type(pgf->u, absfun->type); +} diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 7e62fb28b..654053991 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -37,6 +37,9 @@ #endif +#include +#include + /* A generic structure to store text. The last field is variable length */ typedef struct { size_t size; @@ -50,6 +53,49 @@ struct PgfItor { void (*fn)(PgfItor* self, PgfText* key, void *value); }; +typedef enum { + PGF_BIND_TYPE_EXPLICIT, + PGF_BIND_TYPE_IMPLICIT +} PgfBindType; + +typedef int PgfMetaId; + +typedef struct { + PgfBindType bind_type; + PgfText *cid; + uintptr_t type; +} PgfTypeHypo; + +/* This structure tells the runtime how to create abstract syntax + * expressions in the heap of the host language. For instance, + * when used from Haskell the runtime will create values of + * an algebraic data type which can be garbage collected + * when not needed. Similarly in Python the expressions are + * normal Python objects. From the point of view of the runtime, + * each node is a value of type uintptr_t. For Haskell that would + * actually be a stable pointer, while for Python that would be + * a PyObject pointer. + */ +typedef struct PgfUnmarshaller PgfUnmarshaller; +struct PgfUnmarshaller { + uintptr_t (*eabs)(PgfBindType btype, PgfText *name, uintptr_t body); + uintptr_t (*eapp)(uintptr_t fun, uintptr_t arg); + uintptr_t (*elit)(uintptr_t lit); + uintptr_t (*emeta)(PgfMetaId meta); + uintptr_t (*efun)(PgfText *name); + uintptr_t (*evar)(int index); + uintptr_t (*etyped)(uintptr_t expr, uintptr_t typ); + uintptr_t (*eimplarg)(uintptr_t expr); + uintptr_t (*lint)(int v); + uintptr_t (*lflt)(double v); + uintptr_t (*lstr)(PgfText *v); + uintptr_t (*dtyp)(int n_hypos, PgfTypeHypo *hypos, + PgfText *cat, + int n_exprs, uintptr_t *exprs); + void (*free_ref)(uintptr_t x); + void (*free_me)(PgfUnmarshaller *unmarshaller); +}; + typedef struct PgfPGF PgfPGF; /* All functions that may fail take a reference to a PgfExn structure. @@ -82,21 +128,27 @@ typedef struct { /* Reads a PGF file and keeps it in memory. */ PGF_API_DECL -PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err); +PgfPGF *pgf_read_pgf(const char* fpath, + PgfUnmarshaller *unmarshaller, + PgfExn* err); /* Reads a PGF file and stores the unpacked data in an NGF file * ready to be shared with other process, or used for quick startup. * The NGF file is platform dependent and should not be copied * between machines. */ PGF_API_DECL -PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err); +PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, + PgfUnmarshaller *unmarshaller, + PgfExn* err); /* Tries to read the grammar from an already booted NGF file. * If the file does not exist then a new one is created, and the * grammar is set to be empty. It can later be populated with * rules dynamically. */ PGF_API_DECL -PgfPGF *pgf_read_ngf(const char* fpath, PgfExn* err); +PgfPGF *pgf_read_ngf(const char* fpath, + PgfUnmarshaller *unmarshaller, + PgfExn* err); /* Release the grammar when it is no longer needed. */ PGF_API_DECL diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index fd97dc2bd..5ad1eca04 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -22,6 +22,7 @@ module PGF2 (-- * PGF Cat,categories, -- ** Functions Fun, functions, functionsByCat, + functionType, -- ** Expressions Expr(..), Literal(..), -- ** Types @@ -52,15 +53,18 @@ readPGF fpath = withCString fpath $ \c_fpath -> allocaBytes (#size PgfExn) $ \c_exn -> mask_ $ do - c_pgf <- pgf_read_pgf c_fpath c_exn + u <- mkUnmarshaller + c_pgf <- pgf_read_pgf c_fpath u c_exn ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType) if ex_type == (#const PGF_EXN_NONE) then do fptr <- newForeignPtr pgf_free_fptr c_pgf return (PGF fptr Map.empty) else if ex_type == (#const PGF_EXN_SYSTEM_ERROR) - then do errno <- (#peek PgfExn, code) c_exn + then do freeUnmarshaller u + errno <- (#peek PgfExn, code) c_exn ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath)) - else do c_msg <- (#peek PgfExn, msg) c_exn + else do freeUnmarshaller u + c_msg <- (#peek PgfExn, msg) c_exn msg <- peekCString c_msg free c_msg throwIO (PGFError msg) @@ -75,15 +79,18 @@ bootNGF pgf_path ngf_path = withCString ngf_path $ \c_ngf_path -> allocaBytes (#size PgfExn) $ \c_exn -> mask_ $ do - c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path c_exn + u <- mkUnmarshaller + c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path u c_exn ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType) if ex_type == (#const PGF_EXN_NONE) then do fptr <- newForeignPtr pgf_free_fptr c_pgf return (PGF fptr Map.empty) else if ex_type == (#const PGF_EXN_SYSTEM_ERROR) - then do errno <- (#peek PgfExn, code) c_exn + then do freeUnmarshaller u + errno <- (#peek PgfExn, code) c_exn ioError (errnoToIOError "bootNGF" (Errno errno) Nothing (Just pgf_path)) - else do c_msg <- (#peek PgfExn, msg) c_exn + else do freeUnmarshaller u + c_msg <- (#peek PgfExn, msg) c_exn msg <- peekCString c_msg free c_msg throwIO (PGFError msg) @@ -97,15 +104,18 @@ readNGF fpath = withCString fpath $ \c_fpath -> allocaBytes (#size PgfExn) $ \c_exn -> mask_ $ do - c_pgf <- pgf_read_ngf c_fpath c_exn + u <- mkUnmarshaller + c_pgf <- pgf_read_ngf c_fpath u c_exn ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType) if ex_type == (#const PGF_EXN_NONE) then do fptr <- newForeignPtr pgf_free_fptr c_pgf return (PGF fptr Map.empty) else if ex_type == (#const PGF_EXN_SYSTEM_ERROR) - then do errno <- (#peek PgfExn, code) c_exn + then do freeUnmarshaller u + errno <- (#peek PgfExn, code) c_exn ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath)) - else do c_msg <- (#peek PgfExn, msg) c_exn + else do freeUnmarshaller u + c_msg <- (#peek PgfExn, msg) c_exn msg <- peekCString c_msg free c_msg throwIO (PGFError msg) @@ -119,6 +129,19 @@ abstractName p = bracket (pgf_abstract_name p_pgf) free $ \c_text -> peekText c_text +-- | The type of a function +functionType :: PGF -> Fun -> Maybe Type +functionType p fn = + unsafePerformIO $ + withForeignPtr (a_pgf p) $ \p_pgf -> + withText fn $ \c_fn -> do + c_typ <- pgf_function_type p_pgf c_fn + if c_typ == castPtrToStablePtr nullPtr + then return Nothing + else do typ <- deRefStablePtr c_typ + freeStablePtr c_typ + return (Just typ) + -- | List of all functions defined in the abstract syntax categories :: PGF -> [Fun] categories p = diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index f451cb25f..3bb061a82 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -6,9 +6,10 @@ import Data.Word import Foreign import Foreign.C import Foreign.Ptr -import Foreign.ForeignPtr import qualified Data.Map as Map +import PGF2.Expr + #include -- | An abstract data type representing multilingual grammar @@ -24,6 +25,8 @@ data PgfText data PgfItor data PgfPGF data PgfConcr +data PgfTypeHypo +data PgfUnmarshaller foreign import ccall unsafe "pgf_utf8_decode" pgf_utf8_decode :: Ptr CString -> IO Word32 @@ -32,13 +35,13 @@ foreign import ccall unsafe "pgf_utf8_encode" pgf_utf8_encode :: Word32 -> Ptr CString -> IO () foreign import ccall "pgf_read_pgf" - pgf_read_pgf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF) + pgf_read_pgf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF) foreign import ccall "pgf_boot_ngf" - pgf_boot_ngf :: CString -> CString -> Ptr PgfExn -> IO (Ptr PgfPGF) + pgf_boot_ngf :: CString -> CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF) foreign import ccall "pgf_read_ngf" - pgf_read_ngf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF) + pgf_read_ngf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF) foreign import ccall "&pgf_free" pgf_free_fptr :: FinalizerPtr PgfPGF @@ -60,6 +63,10 @@ foreign import ccall "pgf_iter_functions" foreign import ccall "pgf_iter_functions_by_cat" pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO () +foreign import ccall "pgf/pgf.h pgf_function_type" + pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> IO (StablePtr Type) + + peekText :: Ptr PgfText -> IO String peekText ptr = alloca $ \pptr -> do @@ -107,3 +114,171 @@ withText s fn = | otherwise = count (c+6) xs where ucs = fromEnum x + + +type CBindType = (#type PgfBindType) + +type EAbsUnmarshaller = (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEAbsUnmarshaller :: EAbsUnmarshaller -> IO (FunPtr EAbsUnmarshaller) + +type EAppUnmarshaller = StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEAppUnmarshaller :: EAppUnmarshaller -> IO (FunPtr EAppUnmarshaller) + +type ELitUnmarshaller = StablePtr Literal -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapELitUnmarshaller :: ELitUnmarshaller -> IO (FunPtr ELitUnmarshaller) + +type EMetaUnmarshaller = (#type PgfMetaId) -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEMetaUnmarshaller :: EMetaUnmarshaller -> IO (FunPtr EMetaUnmarshaller) + +type EFunUnmarshaller = Ptr PgfText -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEFunUnmarshaller :: EFunUnmarshaller -> IO (FunPtr EFunUnmarshaller) + +type EVarUnmarshaller = CInt -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEVarUnmarshaller :: EVarUnmarshaller -> IO (FunPtr EVarUnmarshaller) + +type ETypedUnmarshaller = StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapETypedUnmarshaller :: ETypedUnmarshaller -> IO (FunPtr ETypedUnmarshaller) + +type EImplArgUnmarshaller = StablePtr Expr -> IO (StablePtr Expr) + +foreign import ccall "wrapper" + wrapEImplArgUnmarshaller :: EImplArgUnmarshaller -> IO (FunPtr EImplArgUnmarshaller) + +type LIntUnmarshaller = CInt -> IO (StablePtr Literal) + +foreign import ccall "wrapper" + wrapLIntUnmarshaller :: LIntUnmarshaller -> IO (FunPtr LIntUnmarshaller) + +type LFltUnmarshaller = CDouble -> IO (StablePtr Literal) + +foreign import ccall "wrapper" + wrapLFltUnmarshaller :: LFltUnmarshaller -> IO (FunPtr LFltUnmarshaller) + +type LStrUnmarshaller = Ptr PgfText -> IO (StablePtr Literal) + +foreign import ccall "wrapper" + wrapLStrUnmarshaller :: LStrUnmarshaller -> IO (FunPtr LStrUnmarshaller) + +type TypeUnmarshaller = CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type) + +foreign import ccall "wrapper" + wrapTypeUnmarshaller :: TypeUnmarshaller -> IO (FunPtr TypeUnmarshaller) + +foreign import ccall "&hs_free_stable_ptr" hs_free_stable_ptr :: FunPtr (StablePtr a -> IO ()) + +foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FunPtr (Ptr PgfUnmarshaller -> IO ()) + +foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO () + +mkUnmarshaller = do + eabs <- wrapEAbsUnmarshaller unmarshalEAbs + eapp <- wrapEAppUnmarshaller unmarshalEApp + elit <- wrapELitUnmarshaller unmarshalELit + emeta <- wrapEMetaUnmarshaller unmarshalEMeta + efun <- wrapEFunUnmarshaller unmarshalEFun + evar <- wrapEVarUnmarshaller unmarshalEVar + etyped <- wrapETypedUnmarshaller unmarshalETyped + eimplarg<- wrapEImplArgUnmarshaller unmarshalEImplArg + lint <- wrapLIntUnmarshaller unmarshalLInt + lflt <- wrapLFltUnmarshaller unmarshalLFlt + lstr <- wrapLStrUnmarshaller unmarshalLStr + dtyp <- wrapTypeUnmarshaller unmarshalType + ptr <- mallocBytes (#size PgfUnmarshaller) + (#poke PgfUnmarshaller, eabs) ptr eabs + (#poke PgfUnmarshaller, eapp) ptr eapp + (#poke PgfUnmarshaller, elit) ptr elit + (#poke PgfUnmarshaller, emeta) ptr emeta + (#poke PgfUnmarshaller, efun) ptr efun + (#poke PgfUnmarshaller, evar) ptr evar + (#poke PgfUnmarshaller, etyped) ptr etyped + (#poke PgfUnmarshaller, eimplarg) ptr eimplarg + (#poke PgfUnmarshaller, lint) ptr lint + (#poke PgfUnmarshaller, lflt) ptr lflt + (#poke PgfUnmarshaller, lstr) ptr lstr + (#poke PgfUnmarshaller, dtyp) ptr dtyp + (#poke PgfUnmarshaller, free_ref) ptr hs_free_stable_ptr + (#poke PgfUnmarshaller, free_me) ptr hs_free_unmarshaller + return ptr + where + unmarshalEAbs c_btype c_var c_body = do + let btype = unmarshalBindType c_btype + var <- peekText c_var + body <- deRefStablePtr c_body + newStablePtr (EAbs btype var body) + + unmarshalEApp c_fun c_arg = do + fun <- deRefStablePtr c_fun + arg <- deRefStablePtr c_arg + newStablePtr (EApp fun arg) + + unmarshalELit c_lit = do + lit <- deRefStablePtr c_lit + newStablePtr (ELit lit) + + unmarshalEMeta c_metaid = do + newStablePtr (EMeta (fromIntegral c_metaid)) + + unmarshalEFun c_name = do + name <- peekText c_name + newStablePtr (EFun name) + + unmarshalEVar c_var = do + newStablePtr (EVar (fromIntegral c_var)) + + unmarshalETyped c_expr c_typ = do + expr <- deRefStablePtr c_expr + typ <- deRefStablePtr c_typ + newStablePtr (ETyped expr typ) + + unmarshalEImplArg c_expr = do + expr <- deRefStablePtr c_expr + newStablePtr (EImplArg expr) + + unmarshalLInt c_v = do + newStablePtr (LInt (fromIntegral c_v)) + + unmarshalLFlt c_v = do + newStablePtr (LFlt (realToFrac c_v)) + + unmarshalLStr c_v = do + s <- peekText c_v + newStablePtr (LStr s) + + unmarshalType n_hypos hypos c_cat n_exprs exprs = do + hypos <- peekHypos n_hypos hypos + cat <- peekText c_cat + exprs <- peekExprs n_exprs exprs + newStablePtr (DTyp hypos cat exprs) + where + peekHypos 0 p_hypo = return [] + peekHypos n_hypos p_hypo = do + bt <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) p_hypo) + cid <- (#peek PgfTypeHypo, cid) p_hypo >>= peekText + ty <- (#peek PgfTypeHypo, type) p_hypo >>= deRefStablePtr + hs <- peekExprs (n_hypos-1) (p_hypo `plusPtr` (#size PgfTypeHypo)) + return ((bt,cid,ty):hs) + + peekExprs 0 p_expr = return [] + peekExprs n_exprs p_expr = do + e <- peek p_expr >>= deRefStablePtr + es <- peekExprs (n_exprs-1) (p_expr `plusPtr` (#size uintptr_t)) + return (e:es) + + +unmarshalBindType :: (#type PgfBindType) -> BindType +unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit +unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit diff --git a/src/runtime/haskell/pgf2.cabal b/src/runtime/haskell/pgf2.cabal index b16b383b7..2b1eaef4f 100644 --- a/src/runtime/haskell/pgf2.cabal +++ b/src/runtime/haskell/pgf2.cabal @@ -25,6 +25,7 @@ library extra-libraries: pgf cc-options: -std=c99 + c-sources: utils.c test-suite basic type: exitcode-stdio-1.0 diff --git a/src/runtime/haskell/utils.c b/src/runtime/haskell/utils.c index bee94083e..6779c3af2 100644 --- a/src/runtime/haskell/utils.c +++ b/src/runtime/haskell/utils.c @@ -1,160 +1,19 @@ #include #include -#include -typedef struct { - PgfLiteralCallback callback; - PgfExprProb* (*match)(GuString ann, size_t* poffset, - GuPool *out_pool); - GuFinalizer fin; -} HSPgfLiteralCallback; - -static size_t -hspgf_offset2hs(GuString sentence, size_t offset) +void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller) { - const uint8_t *start = sentence; - const uint8_t *end = sentence + offset; - size_t hs_offset = 0; - while (start < end) { - gu_utf8_decode(&start); - hs_offset++; - } - return hs_offset; -} - -static size_t -hspgf_hs2offset(GuString sentence, size_t hs_offset) -{ - const uint8_t *start = sentence; - const uint8_t *end = start; - while (hs_offset > 0) { - gu_utf8_decode(&end); - hs_offset--; - } - - return (end - start); -} - -static PgfExprProb* -hspgf_match_callback(PgfLiteralCallback* self, PgfConcr* concr, - GuString ann, - GuString sentence, size_t* poffset, - GuPool *out_pool) -{ - HSPgfLiteralCallback* callback = (HSPgfLiteralCallback*) self; - - size_t hs_offset = - hspgf_offset2hs(sentence, *poffset); - PgfExprProb* ep = - callback->match(ann, &hs_offset, out_pool); - *poffset = hspgf_hs2offset(sentence, hs_offset); - - return ep; -} - -static void -hspgf_literal_callback_fin(GuFinalizer* self) -{ - HSPgfLiteralCallback* callback = gu_container(self, HSPgfLiteralCallback, fin); - - if (callback->callback.match != NULL) - hs_free_fun_ptr((HsFunPtr) callback->match); - if (callback->callback.predict != NULL) - hs_free_fun_ptr((HsFunPtr) callback->callback.predict); -} - -void -hspgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks, - PgfCId cat, HsFunPtr match, HsFunPtr predict, - GuPool* pool) -{ - HSPgfLiteralCallback* callback = gu_new(HSPgfLiteralCallback, pool); - callback->callback.match = hspgf_match_callback; - callback->callback.predict = (void*) predict; - callback->match = (void*) match; - callback->fin.fn = hspgf_literal_callback_fin; - gu_pool_finally(pool, &callback->fin); - pgf_callbacks_map_add_literal(concr, callbacks, cat, &callback->callback); -} - -typedef struct { - PgfOracleCallback oracle; - GuString sentence; - bool (*predict) (PgfCId cat, - GuString label, - size_t offset); - bool (*complete)(PgfCId cat, - GuString label, - size_t offset); - PgfExprProb* (*literal)(PgfCId cat, - GuString label, - size_t* poffset, - GuPool *out_pool); - GuFinalizer fin; -} HSPgfOracleCallback; - -static bool -hspgf_predict_callback(PgfOracleCallback* self, - PgfCId cat, - GuString label, - size_t offset) -{ - HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle); - return oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset)); -} - -static bool -hspgf_complete_callback(PgfOracleCallback* self, - PgfCId cat, - GuString label, - size_t offset) -{ - HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle); - return oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset)); -} - -static PgfExprProb* -hspgf_literal_callback(PgfOracleCallback* self, - PgfCId cat, - GuString label, - size_t* poffset, - GuPool *out_pool) -{ - HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle); - size_t hs_offset = hspgf_offset2hs(oracle->sentence, *poffset); - PgfExprProb* ep = - oracle->literal(cat,label,&hs_offset,out_pool); - *poffset = hspgf_hs2offset(oracle->sentence, hs_offset); - return ep; -} - -static void -hspgf_oracle_callback_fin(GuFinalizer* self) -{ - HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, fin); - - if (oracle->predict != NULL) - hs_free_fun_ptr((HsFunPtr) oracle->predict); - if (oracle->complete != NULL) - hs_free_fun_ptr((HsFunPtr) oracle->complete); - if (oracle->literal != NULL) - hs_free_fun_ptr((HsFunPtr) oracle->literal); -} - -PgfOracleCallback* -hspgf_new_oracle_callback(GuString sentence, - HsFunPtr predict, HsFunPtr complete, HsFunPtr literal, - GuPool* pool) -{ - HSPgfOracleCallback* oracle = gu_new(HSPgfOracleCallback, pool); - oracle->oracle.predict = predict ? hspgf_predict_callback : NULL; - oracle->oracle.complete = complete ? hspgf_complete_callback : NULL; - oracle->oracle.literal = literal ? hspgf_literal_callback : NULL; - oracle->sentence = sentence; - oracle->predict = (void*) predict; - oracle->complete = (void*) complete; - oracle->literal = (void*) literal; - oracle->fin.fn = hspgf_oracle_callback_fin; - gu_pool_finally(pool, &oracle->fin); - return &oracle->oracle; + hs_free_fun_ptr(unmarshaller->eabs); + hs_free_fun_ptr(unmarshaller->eapp); + hs_free_fun_ptr(unmarshaller->elit); + hs_free_fun_ptr(unmarshaller->emeta); + hs_free_fun_ptr(unmarshaller->efun); + hs_free_fun_ptr(unmarshaller->evar); + hs_free_fun_ptr(unmarshaller->etyped); + hs_free_fun_ptr(unmarshaller->eimplarg); + hs_free_fun_ptr(unmarshaller->lint); + hs_free_fun_ptr(unmarshaller->lflt); + hs_free_fun_ptr(unmarshaller->lstr); + hs_free_fun_ptr(unmarshaller->dtyp); + free(unmarshaller); } diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 6c145b3be..33eded02f 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -3513,7 +3513,7 @@ pgf_readPGF(PyObject *self, PyObject *args) // Read the PGF grammar. PgfExn err; - py_pgf->pgf = pgf_read_pgf(fpath, &err); + py_pgf->pgf = pgf_read_pgf(fpath, NULL/*TO BE FIXED*/, &err); if (err.type == PGF_EXN_SYSTEM_ERROR) { errno = err.code; PyErr_SetFromErrnoWithFilename(PyExc_IOError, fpath);