started on the typechecker

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 \

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

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,

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);
+}

src/runtime/c/pgf/typechecker.h

@@ -0,0 +1,31 @@
+#ifndef TYPECHECKER_H
+#define TYPECHECKER_H
+
+class PGF_INTERNAL_DECL PgfTypechecker : public PgfUnmarshaller {
+    ref<PgfPGF> gr;
+    PgfUnmarshaller *u;
+
+public:
+    PgfTypechecker(ref<PgfPGF> 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

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.

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