diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 3788ccd0f..742db1614 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -19,6 +19,8 @@ libpgf_la_SOURCES = \ pgf/writer.h \ pgf/printer.cxx \ pgf/printer.h \ + pgf/typechecker.cxx \ + pgf/typechecker.h \ pgf/data.cxx \ pgf/data.h \ pgf/expr.cxx \ diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 9dd0c24ad..65e4e7fe9 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -9,6 +9,7 @@ #include "reader.h" #include "writer.h" #include "printer.h" +#include "typechecker.h" static void pgf_exn_clear(PgfExn* err) @@ -861,6 +862,60 @@ PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j) return printer.get_text(); } +PGF_API +void pgf_check_expr(PgfDB *db, PgfRevision revision, + PgfExpr* pe, PgfType ty, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + + ref pgf = PgfDB::revision2pgf(revision); + + PgfTypechecker checker(pgf,u); + *pe = m->match_expr(&checker, *pe); + } PGF_API_END +} + +PGF_API +PgfType pgf_infer_expr(PgfDB *db, PgfRevision revision, + PgfExpr* pe, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + + ref pgf = PgfDB::revision2pgf(revision); + + PgfTypechecker checker(pgf,u); + *pe = m->match_expr(&checker, *pe); + } PGF_API_END + + PgfText *cat = (PgfText *) alloca(sizeof(PgfText)+2); + cat->size = 1; + cat->text[0] = 'S'; + cat->text[1] = 0; + return u->dtyp(0,NULL,cat,0,NULL); +} + +PGF_API +void pgf_check_type(PgfDB *db, PgfRevision revision, + PgfType* pty, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + + ref pgf = PgfDB::revision2pgf(revision); + + PgfTypechecker checker(pgf,u); + *pty = m->match_type(&checker, *pty); + } PGF_API_END +} + PGF_API PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 2983e2328..fd8bd5b46 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -403,6 +403,24 @@ PgfText *pgf_print_lin_sig_internal(object o, size_t i); PGF_API_DECL PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j); +PGF_API_DECL +void pgf_check_expr(PgfDB *db, PgfRevision revision, + PgfExpr* pe, PgfType ty, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err); + +PGF_API_DECL +PgfType pgf_infer_expr(PgfDB *db, PgfRevision revision, + PgfExpr* pe, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err); + +PGF_API_DECL +void pgf_check_type(PgfDB *db, PgfRevision revision, + PgfType* pty, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err); + PGF_API_DECL PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/typechecker.cxx b/src/runtime/c/pgf/typechecker.cxx new file mode 100644 index 000000000..979e2c33a --- /dev/null +++ b/src/runtime/c/pgf/typechecker.cxx @@ -0,0 +1,69 @@ +#include "data.h" +#include "typechecker.h" + +PgfExpr PgfTypechecker::eabs(PgfBindType btype, PgfText *name, PgfExpr body) +{ + return u->eabs(btype,name,body); +} + +PgfExpr PgfTypechecker::eapp(PgfExpr fun, PgfExpr arg) +{ + return u->eapp(fun, arg); +} + +PgfExpr PgfTypechecker::elit(PgfLiteral lit) +{ + return u->elit(lit); +} + +PgfExpr PgfTypechecker::emeta(PgfMetaId meta) +{ + return u->emeta(meta); +} + +PgfExpr PgfTypechecker::efun(PgfText *name) +{ + return u->efun(name); +} + +PgfExpr PgfTypechecker::evar(int index) +{ + return u->evar(index); +} + +PgfExpr PgfTypechecker::etyped(PgfExpr expr, PgfType ty) +{ + return u->etyped(expr,ty); +} + +PgfExpr PgfTypechecker::eimplarg(PgfExpr expr) +{ + return u->eimplarg(expr); +} + +PgfLiteral PgfTypechecker::lint(size_t size, uintmax_t *v) +{ + return u->lint(size,v); +} + +PgfLiteral PgfTypechecker::lflt(double v) +{ + return u->lflt(v); +} + +PgfLiteral PgfTypechecker::lstr(PgfText *v) +{ + return u->lstr(v); +} + +PgfType PgfTypechecker::dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *cat, + size_t n_exprs, PgfExpr *exprs) +{ + return u->dtyp(n_hypos, hypos, cat, n_exprs, exprs); +} + +void PgfTypechecker::free_ref(object x) +{ + u->free_ref(x); +} diff --git a/src/runtime/c/pgf/typechecker.h b/src/runtime/c/pgf/typechecker.h new file mode 100644 index 000000000..9316067cc --- /dev/null +++ b/src/runtime/c/pgf/typechecker.h @@ -0,0 +1,31 @@ +#ifndef TYPECHECKER_H +#define TYPECHECKER_H + +class PGF_INTERNAL_DECL PgfTypechecker : public PgfUnmarshaller { + ref gr; + PgfUnmarshaller *u; + +public: + PgfTypechecker(ref gr, PgfUnmarshaller *u) { + this->gr = gr; + this->u = u; + }; + + virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body); + virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg); + virtual PgfExpr elit(PgfLiteral lit); + virtual PgfExpr emeta(PgfMetaId meta); + virtual PgfExpr efun(PgfText *name); + virtual PgfExpr evar(int index); + virtual PgfExpr etyped(PgfExpr expr, PgfType typ); + virtual PgfExpr eimplarg(PgfExpr expr); + virtual PgfLiteral lint(size_t size, uintmax_t *v); + virtual PgfLiteral lflt(double v); + virtual PgfLiteral lstr(PgfText *v); + virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *cat, + size_t n_exprs, PgfExpr *exprs); + virtual void free_ref(object x); +}; + +#endif diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 69b4818c9..8300bb66e 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -94,7 +94,7 @@ import PGF2.FFI import Foreign import Foreign.C import Control.Monad(forM,forM_) -import Control.Exception(mask_,bracket) +import Control.Exception(bracket,mask_,throwIO) import System.IO.Unsafe(unsafePerformIO) import System.Random import qualified Data.Map as Map @@ -345,7 +345,36 @@ checkExpr = error "TODO: checkExpr" -- possible to infer its type in the GF type system. -- In this case the function returns an error. inferExpr :: PGF -> Expr -> Either String (Expr, Type) -inferExpr = error "TODO: inferExpr" +inferExpr p e = + unsafePerformIO $ + withForeignPtr marshaller $ \m -> + withForeignPtr unmarshaller $ \u -> + withForeignPtr (a_revision p) $ \c_revision -> + bracket (newStablePtr e) freeStablePtr $ \c_e -> + alloca $ \p_e -> + allocaBytes (#size PgfExn) $ \c_exn -> do + poke p_e c_e + c_ty <- pgf_infer_expr (a_db p) c_revision p_e m u c_exn + ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType) + case ex_type of + (#const PGF_EXN_NONE) -> do + c_e <- peek p_e + e <- deRefStablePtr c_e + ty <- deRefStablePtr c_ty + return (Right (e,ty)) + (#const PGF_EXN_SYSTEM_ERROR) -> do + errno <- (#peek PgfExn, code) c_exn + c_msg <- (#peek PgfExn, msg) c_exn + mb_fpath <- if c_msg == nullPtr + then return Nothing + else fmap Just (peekCString c_msg) + ioError (errnoToIOError "inferExpr" (Errno errno) Nothing mb_fpath) + (#const PGF_EXN_PGF_ERROR) -> do + c_msg <- (#peek PgfExn, msg) c_exn + msg <- peekCString c_msg + free c_msg + return (Left msg) + _ -> throwIO (PGFError "inferExpr" "An unidentified error occurred") -- | Check whether a type is consistent with the abstract -- syntax of the grammar. diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index be2c1b20f..139e9ff23 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -145,6 +145,12 @@ foreign import ccall pgf_concrete_language_code :: Ptr PgfDB -> Ptr Concr -> Ptr foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t) +foreign import ccall pgf_check_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Expr) -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO () + +foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Expr) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) + +foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Type) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO () + foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF) foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()