(* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
structure SM = StringMap
+val externFlag = ref false
+fun allowExterns () = externFlag := true
+fun disallowExterns () = externFlag := false
+
local
val unifCount = ref 0
in
end
end
-exception UnequalDomains
-
-fun eqRecord f (r1, r2) =
- (SM.appi (fn (k, v1) =>
- case SM.find (r2, k) of
- NONE => raise UnequalDomains
- | SOME v2 =>
- if f (v1, v2) then
- ()
- else
- raise UnequalDomains) r1;
- SM.appi (fn (k, v2) =>
- case SM.find (r1, k) of
- NONE => raise UnequalDomains
- | SOME v1 =>
- if f (v1, v2) then
- ()
- else
- raise UnequalDomains) r2;
- true)
- handle UnequalDomains => false
-
-fun eqPred ((p1, _), (p2, _)) =
- case (p1, p2) of
- (CRoot, CRoot) => true
- | (CConst s1, CConst s2) => s1 = s2
- | (CPrefix p1, CPrefix p2) => eqPred (p1, p2)
- | (CNot p1, CNot p2) => eqPred (p1, p2)
- | (CAnd (p1, q1), CAnd (p2, q2)) =>
- eqPred (p1, p2) andalso eqPred (q1, q2)
-
- | _ => false
-
-fun eqTy (t1All as (t1, _), t2All as (t2, _)) =
- case (t1, t2) of
- (TBase s1, TBase s2) => s1 = s2
- | (TList t1, TList t2) => eqTy (t1, t2)
- | (TArrow (d1, r1), TArrow (d2, r2)) =>
- eqTy (d1, d2) andalso eqTy (r1, r2)
-
- | (TAction (p1, d1, r1), TAction (p2, d2, r2)) =>
- eqPred (p1, p2) andalso eqRecord eqTy (d1, d2)
- andalso eqRecord eqTy (r1, r2)
-
- | (TNested (p1, q1), TNested (p2, q2)) =>
- eqPred (p1, p2) andalso eqTy (q1, q2)
-
- | (TUnif (_, ref (SOME t1)), _) => eqTy (t1, t2All)
- | (_, TUnif (_, ref (SOME t2))) => eqTy (t1All, t2)
-
- | (TUnif (_, r1), TUnif (_, r2)) => r1 = r2
-
- | (TError, TError) => true
-
- | _ => false
-
-datatype unification_error =
- UnifyPred of pred * pred
- | UnifyTyp of typ * typ
- | UnifyOccurs of string * typ
-
-exception Unify of unification_error
-
-datatype type_error =
- WrongType of string * exp * typ * typ * unification_error option
- | WrongForm of string * string * exp * typ * unification_error option
- | UnboundVariable of string
- | WrongPred of string * pred * pred
-
-fun describe_unification_error t ue =
- case ue of
- UnifyPred (p1, p2) =>
- (print "Reason: Incompatible contexts.\n";
- preface ("Have:", p_pred p1);
- preface ("Need:", p_pred p2))
- | UnifyTyp (t1, t2) =>
- if eqTy (t, t1) then
- ()
- else
- (print "Reason: Incompatible types.\n";
- preface ("Have:", p_typ t1);
- preface ("Need:", p_typ t2))
- | UnifyOccurs (name, t') =>
- if eqTy (t, t') then
- ()
- else
- (print "Reason: Occurs check failed for ";
- print name;
- print " in:\n";
- printd (p_typ t))
-
-fun describe_type_error loc te =
- case te of
- WrongType (place, e, t1, t2, ueo) =>
- (ErrorMsg.error (SOME loc) (place ^ " has wrong type.");
- preface (" Expression:", p_exp e);
- preface ("Actual type:", p_typ t1);
- preface ("Needed type:", p_typ t2);
- Option.app (describe_unification_error t1) ueo)
- | WrongForm (place, form, e, t, ueo) =>
- (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type.");
- preface ("Expression:", p_exp e);
- preface (" Type:", p_typ t);
- Option.app (describe_unification_error t) ueo)
- | UnboundVariable name =>
- ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n")
- | WrongPred (place, p1, p2) =>
- (ErrorMsg.error (SOME loc) ("Context incompatibility for " ^ place ^ ".");
- preface ("Have:", p_pred p1);
- preface ("Need:", p_pred p2))
fun predImplies (p1All as (p1, _), p2All as (p2, _)) =
case (p1, p2) of
| (_, CPrefix p2) => predImplies (p1All, p2)
| (CNot p1, CNot p2) => predImplies (p2, p1)
+ | (CRoot, CNot (CConst _, _)) => true
+ | (CConst s1, CNot (CConst s2, _)) => s1 <> s2
| _ => false
fun subRecord f (r1, r2) =
SM.appi (fn (k, v2) =>
case SM.find (r1, k) of
- NONE => raise UnequalDomains
+ NONE => raise Describe.UnequalDomains
| SOME v1 => f (v1, v2)) r2
fun occurs u (t, _) =
| _ => false))
| _ => NONE
+fun simplifyKindOf e =
+ case e of
+ (EApp ((EVar s, _), e'), _) =>
+ (case Env.function s of
+ NONE => e
+ | SOME f =>
+ case f [e'] of
+ NONE => e
+ | SOME e => e)
+ | _ => e
+
fun hasTyp (e, t1, t2) =
if (case baseCondition t2 of
NONE => false
- | SOME rule => rule e) then
+ | SOME rule => rule (simplifyKindOf e)) then
()
else
subTyp (t1, t2)
| TUnif _ => raise Fail "TUnif in parser-generated type"
end
+fun envVarSetFrom v (e, _) =
+ case e of
+ ESet (v', e) =>
+ if v = v' then
+ SOME e
+ else
+ NONE
+ | EGet (_, _, e) => envVarSetFrom v e
+ | ESeq es => foldr (fn (e, found) =>
+ case found of
+ SOME _ => found
+ | NONE => envVarSetFrom v e)
+ NONE es
+ | ELocal (_, e) => envVarSetFrom v e
+
+ | _ => NONE
+
fun checkExp G (eAll as (e, loc)) =
let
- val dte = describe_type_error loc
+ val dte = Describe.describe_type_error loc
in
case e of
EInt _ => (TBase "int", loc)
(TError, loc))
end
+ | EALam (x, p, e) =>
+ let
+ val p' = checkPred G p
+
+ val G' = bindVal G (x, (TAction (p, SM.empty, SM.empty), loc), NONE)
+ val t' = whnorm (checkExp G' e)
+ in
+ case t' of
+ (TAction _, _) => (TNested (p, t'), loc)
+ | _ => (dte (WrongForm ("Body of nested configuration 'fn'",
+ "action",
+ e,
+ t',
+ NONE));
+ (TError, loc))
+ end
+
| ESet (evar, e) =>
let
val t = checkExp G e
(case SM.find (d', name) of
NONE => SM.insert (d', name, t)
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t, t')
+ | SOME e => hasTyp (e, t, t'))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t, t')
+ | SOME e => hasTyp (e, t, t'))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
d1 d2
(case SM.find (d', name) of
NONE => SM.insert (d', name, t)
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t', t)
+ | SOME e => hasTyp (e, t', t))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t', t)
+ | SOME e => hasTyp (e, t', t))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
d1 d2
ununif t
handle Ununif =>
(ErrorMsg.error (SOME loc) "Unification variables remain in type:";
- printd (p_typ t);
+ output (p_typ t);
t)
end
fun checkDecl G (d, _, loc) =
case d of
- DExternType name => bindType G name
- | DExternVal (name, t) => bindVal G (name, checkTyp G t, NONE)
+ DExternType name =>
+ if !externFlag then
+ bindType G name
+ else
+ (ErrorMsg.error (SOME loc) "'extern type' not allowed in untrusted code";
+ G)
+ | DExternVal (name, t) =>
+ if !externFlag then
+ bindVal G (name, checkTyp G t, NONE)
+ else
+ (ErrorMsg.error (SOME loc) "'extern val' not allowed in untrusted code";
+ G)
| DVal (name, to, e) =>
let
val to =
in
hasTyp (e, t, to)
handle Unify ue =>
- describe_type_error loc
- (WrongType ("Bound value",
- e,
- t,
- to,
- SOME ue));
+ Describe.describe_type_error loc
+ (WrongType ("Bound value",
+ e,
+ t,
+ to,
+ SOME ue));
bindVal G (name, to, SOME e)
end
| DContext name => bindContext G name
HCoop / hcoop / domtool2.git / blobdiff