Reduction

[hcoop/domtool2.git] / src / tycheck.sml

diff --git a/src/tycheck.sml b/src/tycheck.sml
index 5ce94c8..fa006df 100644 (file)
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -20,21 +20,10 @@
 
 structure Tycheck :> TYCHECK = struct
 
 
 structure Tycheck :> TYCHECK = struct
 

-open Ast Print
+open Ast Print Env

 
 

-structure SS = StringSet

 structure SM = StringMap
 
 structure SM = StringMap
 

-type env = SS.set * typ SM.map
-val empty : env = (SS.add (SS.singleton "int", "string"),
-                  SM.empty)
-
-fun lookupType (ts, _) name = SS.member (ts, name)
-fun lookupVal (_, vs) name = SM.find (vs, name)
-
-fun bindType (ts, vs) name = (SS.add (ts, name), vs)
-fun bindVal (ts, vs) (name, t) = (ts, SM.insert (vs, name, t))
-

 local
     val unifCount = ref 0
 in
 local
     val unifCount = ref 0
 in


@@ -349,7 +338,7 @@ fun checkExp G (eAll as (e, loc)) =
                        NONE => (newUnif (), loc)
                      | SOME t => checkTyp G t
 
                        NONE => (newUnif (), loc)
                      | SOME t => checkTyp G t
 

-               val G' = bindVal G (x, t)
+               val G' = bindVal G (x, t, NONE)

                val t' = checkExp G' e
            in
                (TArrow (t, t'), loc)
                val t' = checkExp G' e
            in
                (TArrow (t, t'), loc)


@@ -397,7 +386,7 @@ fun checkExp G (eAll as (e, loc)) =
          | EGet (x, evar, rest) =>
            let
                val xt = (newUnif (), loc)
          | EGet (x, evar, rest) =>
            let
                val xt = (newUnif (), loc)

-               val G' = bindVal G (x, xt)
+               val G' = bindVal G (x, xt, NONE)

 
                val rt = whnorm (checkExp G' rest)
            in
 
                val rt = whnorm (checkExp G' rest)
            in


@@ -638,7 +627,26 @@ fun checkUnit G (eAll as (_, loc)) =
 fun checkDecl G (d, _, loc) =
     case d of
        DExternType name => bindType G name
 fun checkDecl G (d, _, loc) =
     case d of
        DExternType name => bindType G name

-      | DExternVal (name, t) => bindVal G (name, checkTyp G t)
+      | DExternVal (name, t) => bindVal G (name, checkTyp G t, NONE)
+      | DVal (name, to, e) =>
+       let
+           val to =
+               case to of
+                   NONE => (newUnif (), loc)
+                 | SOME to => checkTyp G to
+
+           val t = checkExp G e
+       in
+           subTyp (t, to)
+           handle Unify ue =>
+                  describe_type_error loc
+                                      (WrongType ("Bound value",
+                                                  e,
+                                                  t,
+                                                  to,
+                                                  SOME ue));
+           bindVal G (name, to, SOME e)
+       end

 
 fun checkFile G tInit (ds, eo) =
     let
 
 fun checkFile G tInit (ds, eo) =
     let