Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

minor bug fixes

  • Loading branch information...
commit 0e466aa41b783c0502dc67823698c0a2baf70c91 1 parent 92b2338
@pikatchu authored
View
126 compiler/eval.ml
@@ -32,7 +32,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
open Utils
open Ist
-type value =
+type value =
| Unit
| Bool of bool
| Char of char
@@ -52,7 +52,7 @@ module Print = struct
| Unit -> o "()"
| Bool true -> o "true"
| Bool false -> o "false"
- | Char c ->
+ | Char c ->
let s = "'.'" in
s.[1] <- c;
o s
@@ -61,12 +61,12 @@ module Print = struct
| String s -> o ("\""^String.escaped s^"\"")
| Array a -> o "[|" ; array o a 0 (Array.length a - 1); o "|]"
| Variant (x, []) -> o (Ident.to_string x)
- | Variant (x, vl) ->
- o (Ident.to_string x);
+ | Variant (x, vl) ->
+ o (Ident.to_string x);
o "(";
value_list o vl;
o ")"
- | Record r ->
+ | Record r ->
o "{";
IMap.iter (field o) r;
o "}"
@@ -74,7 +74,7 @@ module Print = struct
| Prim1 _
| Prim2 _ -> o "fun"
- and array o a i iend =
+ and array o a i iend =
if i = iend
then value o a.(i)
else begin
@@ -92,19 +92,19 @@ module Print = struct
and field o s vl =
o (Ident.to_string s); o " = "; value_list o vl;
o "; "
-
+
end
module Genv = struct
- let make_prims env =
+ let make_prims env =
let env = ref env in
- let register x v =
- env := IMap.add x v !env
+ let register x v =
+ env := IMap.add x v !env
in
register Naming.bnot (Prim1
- (function
- | Bool b -> Bool (not b)
+ (function
+ | Bool b -> Bool (not b)
| _ -> assert false
));
register Naming.alength (Prim1
@@ -126,149 +126,149 @@ module Genv = struct
));
!env
- let rec program mdl =
+ let rec program mdl =
let env = IMap.empty in
List.fold_left module_ env mdl
- and module_ env md =
+ and module_ env md =
List.fold_left def env md.md_defs
- and def env (_, x, p, t) =
+ and def env (_, x, p, t) =
IMap.add x (Fun (p, t)) env
end
-let rec program root_id mdl =
+let rec program root_id mdl =
let env = Genv.program mdl in
(match root_id with
| None -> failwith "main not found"
- | Some (_, id) ->
+ | Some (_, id) ->
match IMap.find id env with
- | Fun (_, e) ->
+ | Fun (_, e) ->
let v = tuple env e in
let o = output_string stdout in
Print.value_list o v
| _ -> assert false)
-and pat env ptl vl =
+and pat env ptl vl =
match ptl with
- | [] ->
+ | [] ->
if vl = []
then env
else raise Exit
- | pt :: rl ->
- (try pat_tuple env pt vl
+ | pt :: rl ->
+ (try pat_tuple env pt vl
with Exit -> pat env rl vl)
-and pat_tuple env pel vl =
+and pat_tuple env pel vl =
List.fold_left2 pat_el env pel vl
-and pat_el env (_, p) v =
+and pat_el env (_, p) v =
pat_ env p v
-and pat_ env p v =
+and pat_ env p v =
match p with
| Pany -> env
| Pid x -> IMap.add x v env
- | Pvalue _ -> assert false
+ | Pvalue _ -> env
| Pvariant (x, p) ->
(match v with
| Variant (y, vl) when x = y ->
pat env p vl
| _ -> raise Exit)
- | Precord pfl ->
+ | Precord pfl ->
(match v with
| Record fds ->
List.fold_left (pat_field fds) env pfl
| _ -> raise Exit)
- | Pas (x, p) ->
+ | Pas (x, p) ->
let env = pat env p [v] in
IMap.add x v env
and pat_field fds env = function
| PFany -> env
- | PFid x -> IMap.add x (Record fds) env
- | PField (x, p) ->
+ | PFid x -> IMap.add x (Record fds) env
+ | PField (x, p) ->
let fd = IMap.find x fds in
pat env p fd
-and tuple env el =
+and tuple env el =
List.flatten (List.map (expr env) el)
and expr env (_, e) = expr_ env e
and expr_ env = function
- | Eid x ->
+ | Eid x ->
(try [IMap.find x env]
- with Not_found ->
+ with Not_found ->
let x = Ident.to_string x in
Printf.fprintf stderr "Not an interpreted value: %s" x;
exit 2)
| Evalue v -> [value v]
- | Evariant (x, e) ->
+ | Evariant (x, e) ->
let e = tuple env e in
[Variant (x, e)]
- | Ebinop (bop, e1, e2) ->
+ | Ebinop (bop, e1, e2) ->
let e1 = List.hd (expr env e1) in
let e2 = List.hd (expr env e2) in
[binop bop e1 e2]
- | Euop (uop, e) ->
+ | Euop (uop, e) ->
let e = List.hd (expr env e) in
[unop uop e]
- | Erecord fdl ->
+ | Erecord fdl ->
let fields = List.fold_left (field env) IMap.empty fdl in
[Record fields]
- | Ewith (e, fdl) ->
+ | Ewith (e, fdl) ->
let e = expr env e in
(match e with
| [Record fds] ->
let fields = List.fold_left (field env) fds fdl in
[Record fields]
| _ -> assert false)
- | Efield (e, v) ->
+ | Efield (e, v) ->
(match expr env e with
| [Record fds] -> IMap.find v fds
| _ -> assert false)
- | Ematch (e, al) ->
+ | Ematch (e, al) ->
actions env (tuple env e) al
- | Elet (p, e1, e2) ->
+ | Elet (p, e1, e2) ->
let env = pat env p (tuple env e1) in
tuple env e2
- | Eif (c, e1, e2) ->
+ | Eif (c, e1, e2) ->
(match expr env c with
| [Bool true] -> tuple env e1
| [Bool false] -> tuple env e2
| _ -> assert false)
- | Eapply (_, _, f, e) ->
+ | Eapply (_, _, f, e) ->
(match IMap.find f env with
- | Fun (p, b) ->
+ | Fun (p, b) ->
let env = pat env p (tuple env e) in
tuple env b
| _ -> assert false)
- | Eseq (e1, e2) ->
+ | Eseq (e1, e2) ->
let _ = expr env e1 in
tuple env e2
| Efree _ -> [Unit]
- | Eset (e1, e2, e3) ->
+ | Eset (e1, e2, e3) ->
[match expr env e1, expr env e2 with
- | [Array a], [Int i] ->
+ | [Array a], [Int i] ->
let v = List.hd (expr env e3) in
- a.(i) <- v ;
+ a.(i) <- v ;
Unit
| _ -> assert false]
- | Eget (e1, e2) ->
+ | Eget (e1, e2) ->
[match expr env e1, expr env e2 with
| [Array a], [Int i] -> a.(i)
| _ -> assert false]
- | Eswap (e1, e2, e3) ->
+ | Eswap (e1, e2, e3) ->
[match expr env e1, expr env e2 with
- | [Array a], [Int i] ->
+ | [Array a], [Int i] ->
let res = a.(i) in
- a.(i) <- List.hd (expr env e3) ;
+ a.(i) <- List.hd (expr env e3) ;
res
| _ -> assert false]
| Epartial _ -> failwith "TODO partial"
| Efun (_, pel, e) -> failwith "TODO fun"
-and field env acc (x, e) =
+and field env acc (x, e) =
let e = tuple env e in
IMap.add x e acc
@@ -280,7 +280,7 @@ and value = function
| Echar c -> Char (c.[0])
| Estring s -> String s
-and binop bop e1 e2 =
+and binop bop e1 e2 =
match bop with
| Ast.Eeq -> Bool (e1 = e2)
| Ast.Ediff -> Bool (e1 <> e2)
@@ -289,27 +289,27 @@ and binop bop e1 e2 =
| Ast.Egt -> Bool (e1 > e2)
| Ast.Egte -> Bool (e1 >= e2)
| Ast.Eor
- | Ast.Eand as op ->
+ | Ast.Eand as op ->
Bool (bool_op op e1 e2)
| Ast.Eplus
| Ast.Eminus
| Ast.Estar
| Ast.Emod
- | Ast.Ediv as op ->
+ | Ast.Ediv as op ->
Int (int_op op e1 e2)
| Ast.Eband -> failwith "TODO"
-and bool_op op e1 e2 =
+and bool_op op e1 e2 =
match e1, e2 with
- | Bool b1, Bool b2 ->
+ | Bool b1, Bool b2 ->
(match op with
| Ast.Eor -> b1 || b2
| Ast.Eand -> b1 && b2
| _ -> assert false
)
| _ -> assert false
-
-and int_op op e1 e2 =
+
+and int_op op e1 e2 =
match e1, e2 with
| Int n1, Int n2 ->
(match op with
@@ -330,9 +330,9 @@ and unop op e =
and actions env e al =
match al with
| [] -> failwith "pattern-match failed"
- | (p, a) :: rl ->
- (try
+ | (p, a) :: rl ->
+ (try
let env = pat env p e in
tuple env a
with Exit -> actions env e rl)
-
+
View
208 compiler/linearCheck.ml
@@ -55,18 +55,18 @@ module Type = struct
| As _ -> o "As"
| As_root _ -> o "As_root"
| As_child _ -> o "As_child"
- | Obs s -> o "Obs " ; ISet.iter (fun x -> o (Ident.to_string x) ; o " ") s
-
+ | Obs s -> o "Obs " ; ISet.iter (fun x -> o (Ident.to_string x) ; o " ") s
+
let rec fresh_ty (p, ty) = fresh_ty_ p ty
and fresh_ty_ p = function
| Tprim _ -> Safe
| Tapply ((_, x), _) when x = Naming.tobs -> Safe
| _ -> Fresh
-
+
and fresh tyl = List.map fresh_ty tyl
let rec unify ty1 ty2 = List.map2 unify_ ty1 ty2
- and unify_ ty1 ty2 =
+ and unify_ ty1 ty2 =
match ty1, ty2 with
| Obs x1, Obs x2 -> Obs (ISet.union x1 x2)
| ty, _ -> ty
@@ -75,28 +75,28 @@ module Type = struct
let hd, tl = hdtl l in
List.fold_left unify hd tl
- let pany_table = Hashtbl.create 23
- let make_pany p =
+ let pany_table = Hashtbl.create 23
+ let make_pany p =
try Hashtbl.find pany_table p
- with Not_found ->
+ with Not_found ->
let id = (p, Ident.tmp()) in
Hashtbl.add pany_table p id ;
id
-
+
end
module PatVars = struct
type t = Pos.t IMap.t
- let rec pat (_, p) acc =
+ let rec pat (_, p) acc =
List.fold_right pat_tuple p acc
- and pat_tuple (_, pel) acc =
+ and pat_tuple (_, pel) acc =
List.fold_right pat_el pel acc
and pat_el (ty, p) acc = pat_ (fst ty) p acc
- and pat_ pos p acc =
+ and pat_ pos p acc =
match p with
| Pany -> pat_ pos (Pid (Type.make_pany pos)) acc
| Pid (p, x) -> IMap.add x p acc
@@ -106,7 +106,7 @@ module PatVars = struct
| Pas ((p, x), _) -> IMap.add x p acc
and pat_field pos (_, pf) acc = pat_field_ pos pf acc
- and pat_field_ pos pf acc =
+ and pat_field_ pos pf acc =
match pf with
| PFany -> pat_field_ pos (PFid (Type.make_pany pos)) acc
| PFid (p, x) -> IMap.add x p acc
@@ -136,18 +136,18 @@ end = struct
type t = Type.t IMap.t list
- let print t =
+ let print t =
IMap.iter (
- fun x ty ->
+ fun x ty ->
Ident.print x; Type.print ty ; o "\n" ;
) (List.hd t)
-
+
let empty = [IMap.empty]
let add x ty = function
| env :: rl ->
IMap.add x ty env :: rl
- | _ -> assert false
+ | _ -> assert false
let rec get x = function
| [] -> Safe
@@ -159,18 +159,18 @@ end = struct
| env :: rl ->
IMap.mem x env || mem x rl
- let bind (p, x) ty t =
+ let bind (p, x) ty t =
match ty with
| Fresh
| Used _ -> add x (Var (p, x)) t
| ty -> add x ty t
- let rec obs (p, x) ty t =
+ let rec obs (p, x) ty t =
match ty with
| Used p' -> Error.already_used p p'
- | Var (p, y) ->
+ | Var (p, y) ->
t, [Obs (ISet.singleton y)]
- | Obs y ->
+ | Obs y ->
t, [Obs (ISet.add x y)]
| As (ptr, (left, right, _)) ->
(match left with
@@ -182,26 +182,26 @@ end = struct
| As_child ptr -> obs (p, x) (get ptr t) t
| x -> t, [x]
- let rec use (p, x) t =
+ let rec use (p, x) t =
let ty = get x t in
match ty with
| Safe
- | Fresh -> t, [ty]
- | Var (_, x) ->
+ | Fresh -> t, [ty]
+ | Var (_, x) ->
let t = add x (Used p) t in
t, [Used p]
| Used p' -> Error.already_used p p'
| As_root ptr -> use_root p x ptr t
| As_child ptr -> use_child p x ptr t
| As _ -> assert false
- | Obs vset ->
+ | Obs vset ->
ISet.iter (fun x -> use_obs p x t (get x t)) vset ;
t, [ty]
and use_root p x ptr t =
match get ptr t with
- | As (up, (left, right, size)) ->
- IMap.iter (fun x p' -> Error.already_used p p') right ;
+ | As (up, (left, right, size)) ->
+ IMap.iter (fun x p' -> Error.already_used p p') right ;
(match left with
| None -> ()
| Some p' -> Error.already_used p p') ;
@@ -216,9 +216,9 @@ end = struct
(match left with
| None -> ()
| Some p' -> Error.already_used p p') ;
- (try
+ (try
let p' = IMap.find x right in
- Error.already_used p p'
+ Error.already_used p p'
with Not_found ->
let right = IMap.add x p right in
let size = size - 1 in
@@ -231,7 +231,7 @@ end = struct
| Used p' -> Error.already_used p p'
| _ -> use (p, x) t
- and use_obs p x t v =
+ and use_obs p x t v =
match v with
| Used p' -> Error.already_used p p'
| As (root, (left, right, _)) ->
@@ -243,28 +243,28 @@ end = struct
| As_root ptr
| As_child ptr -> use_obs p x t (get ptr t)
| _ -> ()
-
+
let push t = IMap.empty :: t
-
- let check_left (_, sub1) (bp, sub2) =
+
+ let check_left (_, sub1) (bp, sub2) =
IMap.iter (
- fun x p ->
- if IMap.mem x sub2
+ fun x p ->
+ if IMap.mem x sub2
then ()
else (Error.forgot_branch p bp)
) sub1
- let check sub1 sub2 =
+ let check sub1 sub2 =
check_left sub1 sub2 ;
check_left sub2 sub1 ;
sub1
- let just_used t (bp, sub) =
+ let just_used t (bp, sub) =
bp, IMap.fold (
fun x ty acc ->
match ty with
- | Used xp when mem x t ->
+ | Used xp when mem x t ->
IMap.add x xp acc
| _ -> acc
) sub IMap.empty
@@ -277,36 +277,36 @@ end = struct
| _ -> ()
) env
- let merge t subl =
+ let merge t subl =
let subl = List.map (fun (p, t) -> p, List.hd t) subl in
List.iter check_unused subl ;
let subl = List.map (just_used t) subl in
let hd, tl = hdtl subl in
- let subl = List.fold_left check hd tl in
+ let subl = List.fold_left check hd tl in
IMap.fold (fun x p -> add x (Used p)) (snd subl) t
- let pop t =
+ let pop t =
check_unused (Pos.none, List.hd t)
- let closure t vset =
+ let closure t vset =
let env, t = hdtl t in
t, [Obs vset]
- let partial t vl =
+ let partial t vl =
t, [Obs (
List.fold_left (
fun acc v ->
match v with
- | Obs s -> ISet.union acc s
+ | Obs s -> ISet.union acc s
| _ -> acc
- ) ISet.empty vl
+ ) ISet.empty vl
)]
end
module FreeObsVars = struct
- let rec id obs env t (p, x) =
+ let rec id obs env t (p, x) =
match Env.get x env with
| Type.As_root x -> id obs env t (p, x)
| Type.As_child x -> id obs env t (p, x)
@@ -322,20 +322,20 @@ module FreeObsVars = struct
| Type.As (x, _) -> obs_id obs env t (p, x)
| Type.Obs s when not obs -> Error.esc_scope p
| _ -> ISet.add x t
-
- let rec pat obs t (_, ptl) =
+
+ let rec pat obs t (_, ptl) =
List.fold_left (pat_tuple obs) t ptl
- and pat_tuple obs t (_, pel) =
+ and pat_tuple obs t (_, pel) =
List.fold_left (pat_el obs) t pel
and pat_el obs t (_, p) = pat_ obs t p
and pat_ obs t = function
| Pany -> t
- | Pid (_, x) -> ISet.remove x t
+ | Pid (_, x) -> ISet.remove x t
| Pvalue _ -> t
- | Pvariant (_, p) -> pat obs t p
+ | Pvariant (_, p) -> pat obs t p
| Precord pfl -> List.fold_left (pat_field obs) t pfl
| Pas ((_, x), p) -> ISet.remove x (pat obs t p)
@@ -346,26 +346,26 @@ module FreeObsVars = struct
| PFid (_, x) -> ISet.remove x t
| PField (_, p) -> pat obs t p
- and tuple obs env t (_, tpl) =
+ and tuple obs env t (_, tpl) =
List.fold_left (tuple_pos obs env) t tpl
-
+
and tuple_pos obs env t (_, e) = expr_ obs env t e
and expr obs env t (ty, e) = expr_ obs env t e
and expr_ obs env t = function
| Eid x -> id obs env t x
| Evalue _ -> t
| Evariant (_, e) -> tuple obs env t e
- | Ebinop (_, e1, e2) ->
+ | Ebinop (_, e1, e2) ->
let t = expr obs env t e1 in
let t = expr obs env t e2 in
t
| Euop (_, e) -> expr obs env t e
- | Erecord fdl -> List.fold_left (field obs env) t fdl
- | Ewith (e, fdl) ->
+ | Erecord fdl -> List.fold_left (field obs env) t fdl
+ | Ewith (e, fdl) ->
let t = List.fold_left (field obs env) t fdl in
expr obs env t e
| Efield (e, _) -> expr obs env t e
- | Ematch (e, al) ->
+ | Ematch (e, al) ->
let t = List.fold_left (action obs env) t al in
tuple obs env t e
| Elet (p, e1, e2) ->
@@ -377,17 +377,17 @@ module FreeObsVars = struct
let t = tuple obs env t e1 in
let t = tuple obs env t e2 in
expr obs env t c
- | Eapply (_, _, x, e) ->
+ | Eapply (_, _, x, e) ->
let t = id obs env t x in
let t = tuple obs env t e in
t
- | Eseq (e1, e2) ->
+ | Eseq (e1, e2) ->
let t = expr obs env t e1 in
let t = tuple obs env t e2 in
t
| Eobs x -> obs_id obs env t x
| Efree _ -> t
- | Epartial (f, e) ->
+ | Epartial (f, e) ->
let t = expr obs env t f in
let t = tuple obs env t e in
t
@@ -405,34 +405,36 @@ module FreeObsVars = struct
end
-let rec program mdl =
+let rec program mdl =
List.iter module_ mdl
-and module_ md =
+and module_ md =
List.iter def md.md_defs
-
-and def (_, _, ((tyl, _) as p), e) =
+
+and def (_, _, ((tyl, _) as p), e) =
let vl = Type.fresh (snd tyl) in
let t = pat Env.empty p vl in
let t, _ = tuple t e in
Env.pop t ;
Hashtbl.clear Type.pany_table
-and pat t (_, pl) vl =
+and pat t (_, pl) vl =
List.fold_left (pat_tuple vl) t pl
-and pat_tuple vl t (_, pel) =
- List.fold_left2 pat_el t pel vl
+and pat_tuple vl t (_, pel) =
+ List.fold_left2 pat_el t pel vl
-and pat_el t (ty, p) v =
+and pat_el t (ty, p) v =
pat_ t ty p v
-and pat_ t ty p v =
+and pat_ t ty p v =
match p with
- | Pany ->
+ | Pany ->
let v = match ty with _, Tprim _ -> Type.Safe | _ -> v in
Env.bind (Type.make_pany (fst ty)) v t
- | Pid id -> Env.bind id v t
+ | Pid id ->
+ let v = match ty with _, Tprim _ -> Type.Safe | _ -> v in
+ Env.bind id v t
| Pvalue _ -> t
| Pvariant (_, p) -> pat t p (make_value v p)
| Precord pfl -> List.fold_left (pat_field (fst ty) v) t pfl
@@ -443,7 +445,7 @@ and pat_ t ty p v =
| _ ->
let up = Ident.fresh (snd x) in
let t = Env.bind (fst x, up) v t in
- let vars = PatVars.pat p IMap.empty in
+ let vars = PatVars.pat p IMap.empty in
let size = IMap.fold (fun _ _ acc -> 1+acc) vars 0 in
let left = None in
let right = IMap.empty in
@@ -460,9 +462,9 @@ and pat_field_ pos v t = function
| PField (_, p) -> pat t p (make_value v p)
and make_value v ((_, tyl), pl) =
- let v =
+ let v =
match v with
- | Type.Safe
+ | Type.Safe
| Type.As_child _
| Type.Obs _ as v -> v
| _ -> Type.Fresh
@@ -470,9 +472,9 @@ and make_value v ((_, tyl), pl) =
List.map (fun _ -> v) tyl
-and tuple t (_, tpl) =
+and tuple t (_, tpl) =
(* Everything but identifiers *)
- let t, pvl1 =
+ let t, pvl1 =
List.fold_right (
fun (tyl, e) (t, acc) ->
match e with
@@ -482,27 +484,27 @@ and tuple t (_, tpl) =
t, (fst tyl, vl) :: acc
) tpl (t, []) in
(* Identifiers *)
- let t, pvl2 =
+ let t, pvl2 =
List.fold_right (
fun (tyl, e) (t, acc) ->
match e with
- | Eid _ ->
+ | Eid _ ->
let t, vl = expr_ t (snd tyl) e in
- t, (fst tyl, vl) :: acc
+ t, (fst tyl, vl) :: acc
| _ -> t, (fst tyl, []) :: acc
) tpl (t, []) in
- let pvl =
+ let pvl =
List.fold_right2 (
fun x y acc ->
match x, y with
- | (_, []), v
+ | (_, []), v
| v, _ -> v :: acc
) pvl1 pvl2 [] in
List.iter (
fun (p, vl) ->
List.iter (
- function
- | Type.Obs v ->
+ function
+ | Type.Obs v ->
ISet.iter (
fun x ->
ignore (Env.obs (p, x) (Env.get x t) t)
@@ -511,36 +513,36 @@ and tuple t (_, tpl) =
) vl
) pvl ;
let vl = List.flatten (List.map snd pvl) in
- t, vl
+ t, vl
and expr t (ty, e) = expr_ t [ty] e
and expr_ t ty = function
- | Eid x ->
+ | Eid x ->
(match ty with
- | [_, Tprim _] ->
+ | [_, Tprim _] ->
Env.bind x Type.Safe t, [Type.Safe]
| _ -> Env.use x t)
- | Evalue _ ->
+ | Evalue _ ->
t, [Type.Safe]
- | Evariant (x, e) ->
+ | Evariant (x, e) ->
let t, _ = tuple t e in
t, Type.fresh ty
- | Ebinop (_, e1, e2) ->
+ | Ebinop (_, e1, e2) ->
let t, _ = expr t e1 in
let t, _ = expr t e2 in
t, [Type.Safe]
- | Euop (_, e) ->
+ | Euop (_, e) ->
let t, _ = expr t e in
t, [Type.Safe]
- | Erecord fdl ->
+ | Erecord fdl ->
let t = List.fold_left field t fdl in
t, Type.fresh ty
- | Ewith (e, fdl) ->
+ | Ewith (e, fdl) ->
let t = List.fold_left field t fdl in
let t, _ = expr t e in
t, Type.fresh ty
| Efield (e, _) -> proj t e
- | Ematch (e, al) ->
+ | Ematch (e, al) ->
let t, vl = tuple t e in
let t' = Env.push t in
let tall = List.map (action t' vl) al in
@@ -552,7 +554,7 @@ and expr_ t ty = function
let t = pat t p v in
let t, v = tuple t e2 in
t, v
- | Eif (c, e1, e2) ->
+ | Eif (c, e1, e2) ->
let t, _ = expr t c in
let t' = Env.push t in
let t1, vl1 = tuple t' e1 in
@@ -568,23 +570,23 @@ and expr_ t ty = function
| Eseq (e1, e2) ->
let t, _ = expr t e1 in
tuple t e2
- | Eobs x ->
+ | Eobs x ->
Env.obs x (Env.get (snd x) t) t
- | Efree (_, x) ->
- Env.use x t
- | Epartial (f, e) ->
+ | Efree (_, x) ->
+ Env.use x t
+ | Epartial (f, e) ->
let t, _ = expr t f in
let t, vl = tuple t e in
let t, vl = Env.partial t vl in
t, vl
- | Efun (_, obs, p, e) as e_ ->
+ | Efun (_, obs, p, e) as e_ ->
let vset = FreeObsVars.expr_ obs t ISet.empty e_ in
let t = Env.push t in
let tyl = List.map fst p in
let tyl = List.fold_right (fun x acc -> x :: acc) tyl [] in
let t = List.fold_left2 pat_el t p (Type.fresh tyl) in
let t, _ = tuple t e in
- if obs
+ if obs
then Env.closure t vset
else t, [Type.Fresh]
@@ -598,13 +600,13 @@ and action t vl (p, a) =
let t, vl = tuple t a in
(pos, t), vl
-and proj t (_, e) =
+and proj t (_, e) =
match e with
| Eid x -> Env.obs x (Env.get (snd x) t) t
| Efield (e, _) -> proj t e
| _ -> assert false
-and apply tyl t x vl =
+and apply tyl t x vl =
let obs_set = List.fold_left (
fun acc v ->
match v with
@@ -613,9 +615,9 @@ and apply tyl t x vl =
) ISet.empty vl in
if ISet.is_empty obs_set
then t, Type.fresh tyl
- else
+ else
t, List.map (
- function
+ function
| _, Tprim _ -> Type.Safe
| _, Tapply ((_, x), _) when x = Naming.tobs -> Type.Obs obs_set
| _ -> Type.Fresh
View
113 compiler/recordCheck.ml
@@ -39,7 +39,7 @@ and ty_ =
| Rid of Ident.t
| R of (field * ty) IMap.t
-and field =
+and field =
| Read
| Write of Pos.t
@@ -47,13 +47,13 @@ module Debug = struct
let rec ty l = List.iter ty_ l
and ty_ = function
- | P -> o "P"
+ | P -> o "P"
| A -> o "A"
- | Rid x -> o "Rid"
- | R fdl -> o "{" ; IMap.iter field fdl ; o "}"
+ | Rid x -> o "Rid"
+ | R fdl -> o "{" ; IMap.iter field fdl ; o "}"
and field fd (k, v) =
- o (Ident.to_string fd) ;
+ o (Ident.to_string fd) ;
field_kind k ;
o ": " ;
ty v ;
@@ -61,26 +61,26 @@ module Debug = struct
and field_kind = function
| Read -> o "[R]"
- | Write _ -> o "[W]"
+ | Write _ -> o "[W]"
end
-let get_record_type x t =
+let get_record_type x t =
try match IMap.find x t with
| [x] -> x
| _ -> assert false
with Not_found -> A
-let rec is_pointer l =
+let rec is_pointer l =
let c = List.fold_left (fun acc x -> x = P && acc) true l in
not c
let rec assign pos t ty1 ty2 = List.map2 (assign_ pos t) ty1 ty2
-and assign_ pos t ty1 ty2 =
+and assign_ pos t ty1 ty2 =
match ty1, ty2 with
| Rid x, _ -> assign_ pos t (get_record_type x t) ty2
| _, Rid x -> assign_ pos t ty1 (get_record_type x t)
- | R m1, R m2 ->
+ | R m1, R m2 ->
R (IMap.fold (assign_map pos m2) m1 m1)
| _ -> assert false
@@ -91,13 +91,13 @@ and assign_map pos m2 x (a1, _) m = try
| _, Write _ -> assert false
| _-> IMap.add x t2 m
with Not_found -> m
-
+
module Unify = struct
exception Error of Ident.t
let rec unify tyl1 tyl2 = List.map2 unify_ tyl1 tyl2
- and unify_ ty1 ty2 =
+ and unify_ ty1 ty2 =
match ty1, ty2 with
| P, P -> P
| P, t | t, P -> t
@@ -106,31 +106,31 @@ module Unify = struct
| _, (Rid _ as ty) -> ty
| R m1, R m2 -> R (iimap2 unify_fields m1 m2)
- and unify_fields x (a1, ty1) (a2, ty2) =
+ and unify_fields x (a1, ty1) (a2, ty2) =
unify_access x a1 a2 ;
a1, unify ty1 ty2
- and unify_access x a1 a2 =
+ and unify_access x a1 a2 =
match a1, a2 with
| Read _, Read _ -> ()
| Write p, Read _
| Read _, Write p -> raise (Error x)
| Write _, Write _ -> ()
- let rec unify_types (p1, tyl1) (p2, tyl2) =
+ let rec unify_types (p1, tyl1) (p2, tyl2) =
try p1, unify tyl1 tyl2
with Error x -> Error.field_defined_both_sides p1 p2 x
end
-let rec check_type pos tyl = List.iter (check_type_ pos) tyl
+let rec check_type pos tyl = List.iter (check_type_ pos) tyl
and check_type_ pos = function
| A
| P
| Rid _ -> ()
- | R m -> IMap.iter (check_field pos) m
+ | R m -> IMap.iter (check_field pos) m
-and check_field pos x (a, ty) =
+and check_field pos x (a, ty) =
check_type pos ty ;
match a with
| Read _ -> ()
@@ -140,7 +140,7 @@ let rec type_expr_list (_, tyl) = List.map type_expr tyl
and type_expr (_, ty) = type_expr_ ty
and type_expr_ = function
| Tprim _ -> P
- | Tany
+ | Tany
| Tvar _ | Tfun _ -> A
| Tapply ((_, x), (_, [ty])) when x = Naming.tobs -> A
| Tid (_, x)
@@ -150,7 +150,7 @@ let read_only pos = function
| Read _ -> ()
| Write _ -> Error.field_no_val pos
-let free_field t pos v (x, ty) =
+let free_field t pos v (x, ty) =
if ty = [P]
then ()
else match x with
@@ -161,7 +161,7 @@ let rec free_ty t pos = function
| P
| A -> ()
| Rid x -> free_ty t pos (get_record_type x t)
- | R m -> IMap.iter (free_field t pos) m
+ | R m -> IMap.iter (free_field t pos) m
let free t pos l = List.iter (free_ty t pos) l
@@ -171,18 +171,18 @@ module Env: sig
val make: program -> ty IMap.t
end = struct
- let rec make mdl =
+ let rec make mdl =
List.fold_left module_ IMap.empty mdl
- and module_ t md =
+ and module_ t md =
List.fold_left decl t md.md_decls
-
+
and decl t = function
| Dalgebric _ -> t
| Drecord td -> tdef t td
| Dval _ -> t
- and tdef t td =
+ and tdef t td =
let m = IMap.map (
fun (_, ty) -> Read, type_expr_list ty
) td.td_map in
@@ -190,76 +190,76 @@ end = struct
end
-let rec program mdl =
+let rec program mdl =
let t = Env.make mdl in
List.iter (module_ t) mdl
-and module_ t md =
- List.iter (def t) md.md_defs
+and module_ t md =
+ List.iter (def t) md.md_defs
-and def t (_, x, ((tyl, _) as p), e) =
+and def t (_, x, ((tyl, _) as p), e) =
let tyl = type_expr_list tyl in
let t = pat t p tyl in
check_type (fst (fst e)) (tuple t e)
and pat t (_, ptl) tl = List.fold_left (pat_tuple tl) t ptl
and pat_tuple tl t (_, pel) = List.fold_left2 pat_el t pel tl
-and pat_el t (_, p) ty =
+and pat_el t (_, p) ty =
pat_ t p ty
-
-and pat_ t p ty =
+
+and pat_ t p ty =
match p with
| Pvalue _
| Pany -> t
| Pid (_, x) -> IMap.add x [ty] t
| Pvariant (_, ((tyl, _) as p)) -> pat t p (type_expr_list tyl)
| Precord pfl -> pat_record t pfl ty
- | Pas ((_, x), p) ->
+ | Pas ((_, x), p) ->
let t = IMap.add x [ty] t in
pat t p [ty]
and pat_record t pfl = function
| A
| P -> t
- | R m ->
+ | R m ->
let t, m = List.fold_left pat_field (t, m) pfl in
let t = List.fold_left (pat_rest m) t pfl in
t
| Rid x -> pat_record t pfl (get_record_type x t)
-and pat_rest m t (_, pf) =
+and pat_rest m t (_, pf) =
match pf with
| PFany -> t
| PFid (_, x) -> IMap.add x [R m] t
| _ -> t
and pat_field tm (_, pf) = pat_field_ tm pf
-and pat_field_ (t, m) pf =
+and pat_field_ (t, m) pf =
match pf with
- | PFany
+ | PFany
| PFid _ -> t, m
| PField ((pos, x), p) ->
let a, ty = IMap.find x m in
read_only pos a ;
let t = pat t p ty in
let t = IMap.add x ty t in
- let m =
- if is_pointer ty
- then IMap.add x (Write pos, ty) m
+ let m =
+ if is_pointer ty
+ then IMap.add x (Write pos, ty) m
else m in
t, m
-and tuple t (_, tpl) =
+and tuple t (_, tpl) =
List.fold_right (fun e acc ->
tuple_pos t e @ acc) tpl []
and tuple_pos t ((p, tyl), e) = expr_ t p tyl e
-and expr t ((p, ty_) as ty, e) = expr_ t p [ty] e
+and expr t ((p, ty_) as ty, e) = expr_ t p [ty] e
and expr_ t pos ty = function
| Eobs (_, x)
- | Eid (_, x) ->
+ | Eid (_, x) ->
(try IMap.find x t with Not_found -> type_expr_list (pos, ty))
| Evalue _ -> [P]
| Ebinop (_, e1, e2) ->
@@ -268,13 +268,13 @@ and expr_ t pos ty = function
[P]
| Euop (_, e) -> let _ = expr t e in [P]
| Evariant _ -> List.map type_expr ty
- | Ematch (e, al) ->
+ | Ematch (e, al) ->
let pl = List.map (fun (_, ((p, _), _)) -> p) al in
let ty = tuple t e in
let tyl = List.map (action t ty) al in
let tyl = List.map2 (fun x y -> (x, y)) pl tyl in
snd (List.fold_left Unify.unify_types (List.hd tyl) (List.tl tyl))
- | Elet (p, e1, e2) ->
+ | Elet (p, e1, e2) ->
let ty1 = tuple t e1 in
let t = pat t p ty1 in
tuple t e2
@@ -292,38 +292,38 @@ and expr_ t pos ty = function
let _ = tuple t e in
List.map type_expr ty
| Efun (_, _, _, e)
- | Eapply (_, _, _, e) ->
+ | Eapply (_, _, _, e) ->
check_type pos (tuple t e) ;
- List.map type_expr ty
- | Efield (e, (p, x)) ->
+ List.map type_expr ty
+ | Efield (e, (p, x)) ->
let ty = expr t e in
proj t p ty x
- | Erecord fdl ->
+ | Erecord fdl ->
let m = List.fold_left (field t) IMap.empty fdl in
let ty = List.map type_expr ty in
let fdm = get_fields t ty in
[R (add_write_only pos fdm m)]
- | Ewith (e, fdl) ->
+ | Ewith (e, fdl) ->
let ty1 = expr t e in
let m = List.fold_left (field t) IMap.empty fdl in
let ty2 = [R m] in
assign pos t ty1 ty2
- | Eseq (e1, e2) ->
+ | Eseq (e1, e2) ->
ignore (expr t e1) ;
tuple t e2
-and field t m ((_, x), e) =
+and field t m ((_, x), e) =
IMap.add x (Read, tuple t e) m
-and get_fields t ty =
- match ty with
+and get_fields t ty =
+ match ty with
| [Rid x] -> (match get_record_type x t with
| R m -> m
| _ -> assert false)
| [R m] -> m
| _ -> assert false
-and add_write_only pos fdm m =
+and add_write_only pos fdm m =
IMap.fold (fun x (_, ty) m ->
if IMap.mem x m
then m
@@ -336,8 +336,9 @@ and action t ty (p, e) =
and proj t p ty x =
match ty with
| [Rid y] -> proj t p (IMap.find y t) x
- | [R m] ->
+ | [R m] ->
let a, ty = IMap.find x m in
read_only p a ;
ty
+ | [A] -> [A]
| _ -> assert false
View
53 compiler/stastOfTast.ml
@@ -40,12 +40,12 @@ module Env = struct
records: ISet.t ;
}
- let rec program types mdl =
+ let rec program types mdl =
let recs = ISet.empty in
let recs = List.fold_left module_ recs mdl in
{ types = types ; records = recs }
- and module_ t md =
+ and module_ t md =
List.fold_left decl t md.md_decls
and decl t = function
@@ -53,10 +53,11 @@ module Env = struct
| _ -> t
end
-let check_binop op ((p, _) as ty) =
- let ty =
+let check_binop op ((p, _) as ty) =
+ let ty =
match ty with
| p, Stast.Tprim Stast.Tstring -> Error.no_string p
+ | _, Stast.Tapply (x, (_, [_, Stast.Tprim ty])) when snd x = Naming.tobs -> ty
| _, Stast.Tprim ty -> ty
| p, _ -> Error.expected_primty p in
match op, ty with
@@ -70,8 +71,8 @@ let check_binop op ((p, _) as ty) =
| Ast.Eminus, (Stast.Tint | Stast.Tfloat) -> ()
| Ast.Estar, (Stast.Tint | Stast.Tfloat) -> ()
| Ast.Ediv, (Stast.Tint | Stast.Tfloat) -> ()
- | Ast.Eor, (Stast.Tint | Stast.Tfloat) -> ()
- | Ast.Eand, (Stast.Tint | Stast.Tfloat) -> ()
+ | Ast.Eor, (Stast.Tbool) -> ()
+ | Ast.Eand, (Stast.Tbool) -> ()
| _ -> Error.expected_numeric p
let check_bool (ty, _) =
@@ -79,9 +80,9 @@ let check_bool (ty, _) =
| _, Neast.Tprim Neast.Tbool -> ()
| p, _ -> Error.expected_bool p
-let rec program types mdl =
+let rec program types mdl =
let t = Env.program types mdl in
- List.map (module_ t) mdl
+ List.map (module_ t) mdl
and module_ t md = {
Stast.md_sig = md.md_sig ;
@@ -90,7 +91,7 @@ and module_ t md = {
Stast.md_defs = List.map (def t) md.md_defs ;
}
-and decl t d acc =
+and decl t d acc =
match d with
| Neast.Dabstract _ -> acc
| Neast.Dalgebric td -> Stast.Dalgebric (tdef t td) :: acc
@@ -103,7 +104,7 @@ and tdef t td = {
Stast.td_map = IMap.map (id_type t) td.Neast.td_map ;
}
-and id_type t (x, tyl) =
+and id_type t (x, tyl) =
let tyl = type_expr_list t tyl in
x, tyl
@@ -111,19 +112,19 @@ and type_expr t (p, ty) = p, type_expr_ t ty
and type_expr_ t = function
| Neast.Tany -> Stast.Tany
| Neast.Tprim ty -> Stast.Tprim ty
- | Neast.Tvar ((_, x) as v) ->
+ | Neast.Tvar ((_, x) as v) ->
(try snd (type_expr t (IMap.find x t.Env.types))
with Not_found -> Stast.Tvar v)
| Neast.Tid x -> Stast.Tid x
- | Neast.Tapply (x, tyl) ->
+ | Neast.Tapply (x, tyl) ->
let tyl = type_expr_list t tyl in
Stast.Tapply (x, tyl)
- | Neast.Tfun (k, tyl1, tyl2) ->
+ | Neast.Tfun (k, tyl1, tyl2) ->
Stast.Tfun (k, type_expr_list t tyl1, type_expr_list t tyl2)
and type_expr_list t (p, tyl) = p, List.map (type_expr t) tyl
-and def t (k, x, p, e) =
+and def t (k, x, p, e) =
let e = tuple t e in
k, x, pat t p, e
@@ -145,36 +146,36 @@ and pat_field_ t = function
| PField (x, p) -> Stast.PField (x, pat t p)
and tuple t (tyl, tpl) = type_expr_list t tyl, List.map (tuple_pos t) tpl
-and tuple_pos t (tyl, e) =
+and tuple_pos t (tyl, e) =
let tyl = type_expr_list t tyl in
tyl, expr_ t tyl e
-and expr t (ty, e) =
+and expr t (ty, e) =
let ty = type_expr t ty in
ty, expr_ t (fst ty, [ty]) e
and expr_ t ty = function
| Eid x -> Stast.Eid x
| Evalue v -> Stast.Evalue v
- | Evariant (id, e) ->
+ | Evariant (id, e) ->
let e = tuple t e in
Stast.Evariant (id, e)
- | Ebinop (bop, e1, e2) ->
+ | Ebinop (bop, e1, e2) ->
let e1 = expr t e1 in
let e2 = expr t e2 in
check_binop bop (fst e1) ;
Stast.Ebinop (bop, e1, e2)
| Euop (uop, e) -> Stast.Euop (uop, expr t e)
| Erecord (itl) -> Stast.Erecord (List.map (id_tuple t) itl)
- | Ewith (e, itl) ->
+ | Ewith (e, itl) ->
let e = expr t e in
Stast.Ewith (e, List.map (id_tuple t) itl)
| Efield (e, x) -> Stast.Efield (expr t e, x)
| Ematch (e, pal) -> Stast.Ematch (tuple t e, List.map (action t) pal)
- | Elet (p, e1, e2) ->
+ | Elet (p, e1, e2) ->
let e1 = tuple t e1 in
let e2 = tuple t e2 in
Stast.Elet (pat t p, e1, e2)
- | Eif (e1, e2, e3) ->
+ | Eif (e1, e2, e3) ->
check_bool e1 ;
let e2 = tuple t e2 in
let e3 = tuple t e3 in
@@ -183,7 +184,7 @@ and expr_ t ty = function
let fty = type_expr t fty in
let e = tuple t e in
Stast.Eapply (fk, fty, x, e)
- | Eseq (e1, e2) ->
+ | Eseq (e1, e2) ->
let e2 = tuple t e2 in
Stast.Eseq (expr t e1, e2)
| Eobs x -> Stast.Eobs x
@@ -194,19 +195,19 @@ and expr_ t ty = function
| Stast.Tid (_, x) when ISet.mem x t.Env.records -> ()
| _ -> Error.cannot_free (fst ty) (Typing.Print.type_expr t.Env.types ty)) ;
Stast.Efree (ty', x)
- | Epartial (f, e) ->
+ | Epartial (f, e) ->
let f = expr t f in
let e = tuple t e in
Stast.Epartial (f, e)
- | Efun (k, obs, idl, e) ->
+ | Efun (k, obs, idl, e) ->
let idl = List.map (pat_el t) idl in
let e = tuple t e in
Stast.Efun (k, obs, idl, e)
-and id_tuple t (x, e) =
+and id_tuple t (x, e) =
let e = tuple t e in
x, e
-and action t (p, a) =
+and action t (p, a) =
let e = tuple t a in
pat t p, e
View
260 compiler/typing.ml
@@ -34,11 +34,11 @@ open Neast
type env = type_expr IMap.t ref
-let add x ty env =
+let add x ty env =
env := IMap.add x ty !(env) ;
env
-let find x env =
+let find x env =
IMap.find x !(env)
module Print = struct
@@ -49,39 +49,39 @@ module Print = struct
let def_list o = function
| [] -> assert false
- | (x, _) :: _ ->
+ | (x, _) :: _ ->
let x = Ident.debug x in
o ("typeof("^x^")")
-
- let rec type_expr env o (_, ty) =
+
+ let rec type_expr env o (_, ty) =
type_expr_ env o ty
and type_expr_ env o = function
| Tany -> o "_"
| Tprim ty -> type_prim o ty
- | Tvar x ->
+ | Tvar x ->
(try type_expr env o (IMap.find (snd x) env)
with Not_found ->
id o x)
| Tid x -> id o x
- | Tapply (x, tyl) ->
+ | Tapply (x, tyl) ->
type_expr_list env o tyl ;
- o " " ;
+ o " " ;
id o x
- | Tfun (k, tyl1, tyl2) ->
- o "(" ;
- type_expr_list env o tyl1 ;
+ | Tfun (k, tyl1, tyl2) ->
+ o "(" ;
+ type_expr_list env o tyl1 ;
o (match k with Ast.Cfun -> " #" | _ -> " ") ;
- o "-> " ;
- type_expr_list env o tyl2 ;
+ o "-> " ;
+ type_expr_list env o tyl2 ;
o ")"
- and type_expr_list env o (_, l) =
+ and type_expr_list env o (_, l) =
match l with
| [x] -> type_expr env o x
| _ ->
- o "(" ;
- print_list o (type_expr env) ", " l ;
+ o "(" ;
+ print_list o (type_expr env) ", " l ;
o ")"
and type_prim o = function
@@ -92,7 +92,7 @@ module Print = struct
| Tfloat -> o "float"
| Tstring -> o "string"
- let debug env tyl =
+ let debug env tyl =
type_expr_list env (output_string stdout) (Pos.none, tyl) ;
print_newline()
@@ -113,9 +113,9 @@ module LocalUtils = struct
let tfun x y = Pos.none, Tfun (Ast.Cfun, (Pos.none, x), (Pos.none, y))
let list l = Pos.none, l
- let o s =
- output_string stdout s ;
- print_newline() ;
+ let o s =
+ output_string stdout s ;
+ print_newline() ;
flush stdout
let is_observed = function
@@ -127,7 +127,7 @@ module LocalUtils = struct
| (_, Tapply ((_, x), (_, [ty1]))) when x = Naming.tobs -> ty1
| x -> x
- let make_observed (p, ty) =
+ let make_observed (p, ty) =
match ty with
| Tprim _ -> (p, ty)
| Tapply ((_, x), _) when x = Naming.tobs -> p, ty
@@ -139,16 +139,16 @@ module LocalUtils = struct
let pos_variant p ty = p, (snd ty)
- let rec has_any b (_, ty) =
+ let rec has_any b (_, ty) =
match ty with
| Tany -> true
| Tprim _ -> b
| Tvar _ -> b
| Tid _ -> b
- | Tapply (_, l) -> has_any_list b l
+ | Tapply (_, l) -> has_any_list b l
| Tfun (_, l1, l2) -> has_any_list b l1 || has_any_list b l2
- and has_any_list b (_, l) =
+ and has_any_list b (_, l) =
List.fold_left has_any b l
let has_any ty = has_any false ty
@@ -156,7 +156,7 @@ module LocalUtils = struct
(* assumes the type is a function *)
let get_fkind = function
| _, Tapply (_, (_, [_, Tfun (k, _, _)])) -> k
- | _, Tfun (k, _, _) -> k
+ | _, Tfun (k, _, _) -> k
| _ -> assert false
end
@@ -178,23 +178,23 @@ module Type = struct
} in
raise (Error.Type [err])
- let rec unify_list (env: env) ((p1, _) as l1) ((p2, _) as l2) =
+ let rec unify_list (env: env) ((p1, _) as l1) ((p2, _) as l2) =
try unify_list_ env l1 l2
with Error.Type err_l ->
let err = Error.Unify {
Error.pos1 = p1 ;
Error.pos2 = p2 ;
Error.print1 = Print.type_expr_list !env l1 ;
- Error.print2 = Print.type_expr_list !env l2 ;
+ Error.print2 = Print.type_expr_list !env l2 ;
} in
- raise (Error.Type (err :: err_l))
+ raise (Error.Type (err :: err_l))
- and unify_list_ env (p1, tyl1) (p2, tyl2) =
+ and unify_list_ env (p1, tyl1) (p2, tyl2) =
if List.length tyl1 <> List.length tyl2
then Error.arity p1 p2 (List.length tyl1) (List.length tyl2)
else (p1, List.map2 (unify_el_ env) tyl1 tyl2)
-
- and unify_el env ty1 ty2 =
+
+ and unify_el env ty1 ty2 =
try unify_el_ env ty1 ty2
with Error.Type _ ->
let err = Error.Unify {
@@ -203,9 +203,9 @@ module Type = struct
Error.print1 = Print.type_expr !env ty1 ;
Error.print2 = Print.type_expr !env ty2 ;
} in
- raise (Error.Type [err])
+ raise (Error.Type [err])
- and unify_el_ env ((p1, _) as ty1) ((p2, _) as ty2) =
+ and unify_el_ env ((p1, _) as ty1) ((p2, _) as ty2) =
p2, unify_el_prim env ty1 ty2
and unify_el_prim env ((p1, ty1) as pty1) ((p2, ty2) as pty2) =
@@ -213,52 +213,52 @@ module Type = struct
| Tprim x, Tprim y when x = y -> ty2
| Tany, _ -> ty2
| _, Tany -> ty1
- | Tprim _, Tapply (y, (_, [ty2])) when snd y = Naming.tobs ->
+ | Tprim _, Tapply (y, (_, [ty2])) when snd y = Naming.tobs ->
snd (unify_el env pty1 ty2)
- | Tapply (y, (_, [ty1])), Tprim _ when snd y = Naming.tobs ->
+ | Tapply (y, (_, [ty1])), Tprim _ when snd y = Naming.tobs ->
snd (unify_el env ty1 pty2)
| Tvar _, Tapply (y, _)
- | Tapply (y, _), Tvar _ when snd y = Naming.tobs ->
+ | Tapply (y, _), Tvar _ when snd y = Naming.tobs ->
unify_error !env pty1 pty2
- | Tvar (_, x1), Tvar (_, x2) ->
+ | Tvar (_, x1), Tvar (_, x2) ->
(try snd (unify_el env (find x1 env) pty2)
- with Not_found ->
+ with Not_found ->
try snd (unify_el env pty1 (find x2 env))
with Not_found ->
let ty = p2, Tvar (p2, fresh x2) in
ignore (add x1 ty env) ;
ignore (add x2 ty env) ;
snd ty)
- | _, Tvar (_, x) ->
+ | _, Tvar (_, x) ->
(try snd (unify_el env pty1 (find x env))
with Not_found ->
ignore (add x pty1 env) ;
ty1)
- | Tvar (_, x), _ ->
+ | Tvar (_, x), _ ->
(try snd (unify_el env (find x env) pty2)
with Not_found ->
ignore (add x pty2 env) ;
ty2)
- | Tapply ((_, x) as id, tyl1), Tapply ((_, y), tyl2) when x = y ->
- let tyl = unify_list env tyl1 tyl2 in
+ | Tapply ((_, x) as id, tyl1), Tapply ((_, y), tyl2) when x = y ->
+ let tyl = unify_list env tyl1 tyl2 in
Tapply (id, tyl)
| Tfun (k1, tyl1, tyl2), Tfun (k2, tyl3, tyl4) when k1 = k2 ->
let tyl1 = unify_list_ env tyl1 tyl3 in
let tyl2 = unify_list_ env tyl2 tyl4 in
Tfun (k1, tyl1, tyl2)
| Tid (_, x), Tid (_, y) when x = y -> ty2
- | _ -> unify_error !env pty1 pty2
+ | _ -> unify_error !env pty1 pty2
- let call env tyl1 tyl2 rty =
+ let call env tyl1 tyl2 rty =
let _ = unify_list env tyl1 tyl2 in
- rty
+ rty
- let fold_types env tyl =
+ let fold_types env tyl =
match tyl with
| [] -> assert false
| ty :: tyl -> List.fold_left (unify_el env) ty tyl
- let fold_type_lists env tyll =
+ let fold_type_lists env tyll =
match tyll with
| [] -> assert false
| tyl :: rl -> List.fold_left (unify_list env) tyl rl
@@ -269,7 +269,7 @@ module Env = struct
let tassert = tfun [tprim Tbool] [tprim Tunit]
- let tsome =
+ let tsome =
let tmp = Ident.tmp() in
tfun [tvar tmp] [tapply Naming.toption [tvar tmp]]
@@ -277,7 +277,7 @@ module Env = struct
let tnot = tfun [tprim Tbool] [tprim Tbool]
let tabs = tfun [tprim Tint] [tprim Tint]
- let rec make mdl =
+ let rec make mdl =
let env = IMap.empty in
let env = IMap.add Naming.some tsome env in
let env = IMap.add Naming.none tnone env in
@@ -286,8 +286,8 @@ module Env = struct
let env = List.fold_left module_ env mdl in
env
- and module_ env md =
- List.fold_left decl env md.md_decls
+ and module_ env md =
+ List.fold_left decl env md.md_decls
and decl env = function
| Dabstract _ -> env
@@ -298,32 +298,32 @@ module Env = struct
and algebric env tdef =
IMap.fold (variant tdef.td_args tdef.td_id) tdef.td_map env
- and variant pl tid _ ((p, x), tyl) env =
+ and variant pl tid _ ((p, x), tyl) env =
let rty = match pl with
| [] -> p, Tid tid
- | _ ->
+ | _ ->
let fvs = List.fold_left (TVars.type_expr env) ISet.empty (snd tyl) in
- let argl = List.map (tvar fvs) pl in
+ let argl = List.map (tvar fvs) pl in
let argl = p, argl in
p, Tapply (tid, argl) in
match snd tyl with
| [] -> IMap.add x rty env
- | _ ->
+ | _ ->
let v_ty = p, Tfun (Ast.Lfun, tyl, (p, [rty])) in
IMap.add x v_ty env
-
- and tvar fvs ((p, x) as id) =
- p, if ISet.mem x fvs
+
+ and tvar fvs ((p, x) as id) =
+ p, if ISet.mem x fvs
then Tvar id
- else Tany
+ else Tany
end
-let rec program mdl =
+let rec program mdl =
let types = Env.make mdl in
let env = ref types in
let mdl = List.map (module_ env) mdl in
!env, mdl
-
+
and module_ env md = try
let _ = List.fold_left declare env md.md_decls in
let defs = List.map (def env) md.md_defs in
@@ -332,27 +332,33 @@ and module_ env md = try
Tast.md_decls = md.md_decls ;
Tast.md_defs = defs ;
}
-with Error.Type errl ->
+with Error.Type errl ->
Error.unify errl
-
+
and declare env = function
| Dval (_, x, ty, (Ast.Ext_C _ | Ast.Ext_Asm _)) -> add (snd x) ty env
| Dval (_, x, ty, Ast.Ext_none) -> add (snd x) ty env
| _ -> env
and def env (fid, p, e) =
- match find (snd fid) env with
- | _, Tfun (k, tyl, rty) ->
+ let fty = find (snd fid) env in
+ match fty with
+ | fp, Tfun (k, tyl, rty) ->
let env, p = pat env p tyl in
let rty', e = tuple env e in
let rty = Type.unify_list env rty' rty in
+ let tyl = ExpandType.type_expr_list !env tyl in
+ let rty = ExpandType.type_expr_list !env rty in
+ let fty' = fp, Tfun (k, tyl, rty) in
+ (* TODO error messages are bad *)
+(* SubType.type_expr fty fty'; *)
k, fid, p, (rty, e)
| _ -> assert false
-and pat env (p1, pl) (p2, tyl) =
+and pat env (p1, pl) (p2, tyl) =
match pl with
| [] -> assert false
- | [(p1, l_) as l] ->
+ | [(p1, l_) as l] ->
let size1 = List.length l_ in
let size2 = List.length tyl in
if size1 <> size2
@@ -360,12 +366,12 @@ and pat env (p1, pl) (p2, tyl) =
let env, (tyl, pl) = pat_tuple env l tyl in
env, (tyl, [pl])
- | ((p1, _) as l) :: rl ->
+ | ((p1, _) as l) :: rl ->
let env, (_, rl) = pat env (p1, rl) (p2, tyl) in
let env, (tyl, pl) = pat_tuple env l tyl in
env, (tyl, pl :: rl)
-and pat_tuple env (p, l) tyl =
+and pat_tuple env (p, l) tyl =
let env, (tyl, pl) = pat_tuple_ env l tyl in
let tyl = p, tyl in
env, (tyl, (tyl, pl))
@@ -380,15 +386,15 @@ and pat_tuple_ env l tyl =
env, (ty :: tyl, p :: pl)
and pat_el env (pos, p) ((hpos, ty)) =
- let pty = pos, ty in
+ let pty = pos, ty in
let is_obs = is_observed pty in
- let env, (rty, p) =
+ let env, (rty, p) =
match p with
| Pany -> env, (pty, Tast.Pany)
- | Pid ((_, x) as id) ->
+ | Pid ((_, x) as id) ->
let env = add x pty env in
env, (pty, Tast.Pid id)
- | Pvariant (x, (_, [])) ->
+ | Pvariant (x, (_, [])) ->
let pty = get_true_type pty in
let ty2 = find (snd x) env in
let ty2 = pos, (snd ty2) in
@@ -398,34 +404,34 @@ and pat_el env (pos, p) ((hpos, ty)) =
let pty = get_true_type pty in
let env, rty, args = pat_variant is_obs env x args pty in
env, (rty, Tast.Pvariant (x, args))
- | Pvalue v ->
+ | Pvalue v ->
let pty = get_true_type pty in
let rty = Type.unify_el env (pos, Tprim (value v)) pty in
env, (rty, Tast.Pvalue v)
- | Precord pfl ->
+ | Precord pfl ->
let pty = get_true_type pty in
let env, pfl = lfold (pat_field is_obs pty) env pfl in
let tyl = List.map fst pfl in
let pfl = List.map snd pfl in
- let ty = Type.fold_types env tyl in
- env, (ty, Tast.Precord pfl)
- | Pas (((_, x) as id), p) ->
+ let ty = Type.fold_types env tyl in
+ env, (ty, Tast.Precord pfl)
+ | Pas (((_, x) as id), p) ->
let env = add x pty env in
let env, p = pat env p (fst pty, [pty]) in
env, ((fst pty, ty), Tast.Pas (id, p))
in
- let rty = if is_obs
+ let rty = if is_obs
then make_observed rty
else rty in
env, (rty, p)
-and pat_field is_obs pty env (p, pf) =
+and pat_field is_obs pty env (p, pf) =
let pty = p, snd pty in
- match pf with
- | PFany ->
+ match pf with
+ | PFany ->
let pty = if is_obs then make_observed pty else pty in
env, (pty, (p, Tast.PFany))
- | PFid ((_, x) as id) ->
+ | PFid ((_, x) as id) ->
let pty = if is_obs then make_observed pty else pty in
let env = add x pty env in
env, (pty, (p, Tast.PFid id))
@@ -436,37 +442,37 @@ and pat_field is_obs pty env (p, pf) =
and pat_variant is_obs env x args pty =
let fty = Instantiate.type_expr !env (find (snd x) env) in
- let argty, rty =
+ let argty, rty =
match fty with
| _, Tfun (_, tyl, rty) -> tyl, rty
- | _ -> Error.no_argument (fst pty)
+ | _ -> Error.no_argument (fst pty)
in
let pty = fst pty, [pty] in
- let tyl = Type.call env rty pty argty in
- let obs_tyl =
- if is_obs
- then fst tyl, List.map make_observed (snd tyl)
- else tyl
+ let tyl = Type.call env rty pty argty in
+ let obs_tyl =
+ if is_obs
+ then fst tyl, List.map make_observed (snd tyl)
+ else tyl
in let env, ((tyl, _) as args) = pat env args obs_tyl in
let tyl = fst tyl, List.map get_true_type (snd tyl) in
let fty = fst x, snd (find (snd x) env) in
let rty = apply env (fst pty) fty tyl in
- let rty = match rty with
+ let rty = match rty with
| _, [_, x] -> fst pty, x
| _ -> assert false in
env, rty, args
-and tuple env (p, el) =
+and tuple env (p, el) =
let el = List.map (tuple_pos env) el in
let tyl = List.map fst el in
let tyl = List.map snd tyl in
let tyl = List.flatten tyl in
((p, tyl), el)
-and tuple_pos env (p, e) =
+and tuple_pos env (p, e) =
let (tyl, e) = tuple_ env p e in
((p, snd tyl), e)
-
+
and tuple_ env p = function
| Eapply (x, el) ->
let ((tyl, _) as el) = tuple env el in
@@ -475,38 +481,38 @@ and tuple_ env p = function
let fty = unobserve (find (snd x) env) in
let fk = get_fkind fty in
let res = rty, Tast.Eapply (fk, fty, x, el) in
- res
+ res
| Epartial (f, args) ->
let ((tyl, _) as args) = tuple env args in
let (fty, _) as f = expr env f in
let fty = unobserve fty in
let rty = partial env p fty tyl in
rty, Tast.Epartial (f, args)
- | Eif (e1, el1, el2) ->
+ | Eif (e1, el1, el2) ->
let e1 = expr env e1 in
let ((tyl1, _) as el1) = tuple env el1 in
let ((tyl2, _) as el2) = tuple env el2 in
let tyl = Type.unify_list env tyl1 tyl2 in
(tyl, Tast.Eif (e1, el1, el2))
- | Elet (argl, e1, e2) ->
+ | Elet (argl, e1, e2) ->
let ((tyl, _) as e1) = tuple env e1 in
- let env, argl = pat env argl tyl in
+ let env, argl = pat env argl tyl in
let ((tyl, _) as e2) = tuple env e2 in
(tyl, Tast.Elet (argl, e1, e2))
- | Efield (e, ((p, x) as fd_id)) ->
+ | Efield (e, ((p, x) as fd_id)) ->
let ((ty, _) as e) = expr env e in
- let fdtype = find x env in
+ let fdtype = find x env in
let fdtype = p, snd fdtype in
let tyl = proj env ty fdtype in
(tyl, Tast.Efield (e, fd_id))
- | Ematch (el, pel) ->
+ | Ematch (el, pel) ->
let ((tyl, _) as el) = tuple env el in
let pel = List.map (action env tyl) pel in
let tyl = List.map fst pel in
let pel = List.map snd pel in
let tyl = Type.fold_type_lists env tyl in
- (tyl, Tast.Ematch (el, pel))
- | Eseq (((p, _) as e1), e2) ->
+ (tyl, Tast.Ematch (el, pel))
+ | Eseq (((p, _) as e1), e2) ->
let (ty1, e1) = expr env e1 in
let ty1 = Type.unify_el env ty1 (p, Tprim Tunit) in
let e1 = ty1, e1 in
@@ -516,7 +522,7 @@ and tuple_ env p = function
let (ty, e) = expr_ env (p, e) in
((p, [ty]), e)
-and expr env ((p, _) as e) =
+and expr env ((p, _) as e) =
let el = tuple env (p, [e]) in
match snd el with
| [] -> assert false
@@ -524,20 +530,20 @@ and expr env ((p, _) as e) =
| _ -> Error.no_tuple p
and expr_ env (p, e) =
- match e with
- | Eid ((_, x) as id) ->
+ match e with
+ | Eid ((_, x) as id) ->
let ty = find x env in
let ty = p, (snd ty) in
(ty, Tast.Eid id)
- | Evalue v ->
+ | Evalue v ->
let ty = p, Tprim (value v) in
(ty, Tast.Evalue v)
- | Evariant ((p1, x), (p2, [])) ->
+ | Evariant ((p1, x), (p2, [])) ->
let rty = find x env in
let rty = pos_variant p1 rty in
let argty = p2, [] in
(rty, Tast.Evariant ((p1, x), (argty, [])))
- | Evariant (x, el) ->
+ | Evariant (x, el) ->
let (ty, (x, el)) = variant env (x, el) in
let ty = pos_variant p ty in
(ty, Tast.Evariant (x, el))
@@ -547,16 +553,16 @@ and expr_ env (p, e) =
let ty = Type.unify_el env ty1 ty2 in
let ty = binop env bop p ty in
(ty, Tast.Ebinop (bop, e1, e2))
- | Euop (Ast.Euminus, e) ->
+ | Euop (Ast.Euminus, e) ->
let (ty, _ as e) = expr env e in
(ty, Tast.Euop (Ast.Euminus, e))
- | Erecord fdl ->
+ | Erecord fdl ->
let fdl = List.map (variant env) fdl in
let tyl = List.map fst fdl in
let fdl = List.map snd fdl in
let ty = Type.fold_types env tyl in
(ty, Tast.Erecord fdl)
- | Ewith (e, fdl) ->
+ | Ewith (e, fdl) ->
let ((ty1, _) as e) = expr env e in
let fdl = List.map (variant env) fdl in
let tyl = List.map fst fdl in
@@ -569,7 +575,7 @@ and expr_ env (p, e) =
let ty = p, (snd ty) in
let obs_ty = make_observed ty in
(obs_ty, Tast.Eobs id)
- | Efree ((p, x) as id) ->
+ | Efree ((p, x) as id) ->
let ty = find x env in