summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Makefile2
-rw-r--r--src/initial_check.ml169
-rw-r--r--src/initial_check.mli11
-rw-r--r--src/monomorphise_new.ml2
-rw-r--r--src/pretty_print.ml1
-rw-r--r--src/pretty_print.mli5
-rw-r--r--src/pretty_print_lem.ml6
-rw-r--r--src/pretty_print_lem_ast.ml2
-rw-r--r--src/pretty_print_ocaml.ml2
-rw-r--r--src/pretty_print_sail.ml1
-rw-r--r--src/pretty_print_t_ascii.ml152
-rw-r--r--src/process_file.ml56
-rw-r--r--src/process_file.mli14
-rw-r--r--src/rewriter.ml2
-rw-r--r--src/rewriter.mli2
-rw-r--r--src/sail.ml33
-rw-r--r--src/sail.odocl1
-rw-r--r--src/sail_lib.ml76
-rw-r--r--src/spec_analysis.mli2
-rw-r--r--src/type_check.ml5068
-rw-r--r--src/type_check.mli179
-rw-r--r--src/type_check_new.ml2644
-rw-r--r--src/type_check_new.mli217
-rw-r--r--src/type_internal.ml4545
-rw-r--r--src/type_internal.mli391
25 files changed, 2917 insertions, 10666 deletions
diff --git a/src/Makefile b/src/Makefile
index a58646b1..8ef800a6 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -50,7 +50,7 @@ all: sail lib doc
full: sail lib power doc test
sail:
- ocamlbuild sail.native sail_lib.cma sail_lib.cmxa
+ ocamlbuild sail.native
sail.native: sail
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 39454049..c71a2376 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -40,11 +40,37 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-open Type_internal
open Ast
+open Util
-type kind = Type_internal.kind
-type typ = Type_internal.t
+module Envmap = Finite_map.Fmap_map(String)
+module Nameset' = Set.Make(String)
+module Nameset = struct
+ include Nameset'
+ let pp ppf nameset =
+ Format.fprintf ppf "{@[%a@]}"
+ (Pp.lst ",@ " Pp.pp_str)
+ (Nameset'.elements nameset)
+end
+
+type kind = { mutable k : k_aux }
+and k_aux =
+ | K_Typ
+ | K_Nat
+ | K_Ord
+ | K_Efct
+ | K_Val
+ | K_Lam of kind list * kind
+ | K_infer
+
+let rec kind_to_string kind = match kind.k with
+ | K_Nat -> "Nat"
+ | K_Typ -> "Type"
+ | K_Ord -> "Order"
+ | K_Efct -> "Effect"
+ | K_infer -> "Infer"
+ | K_Val -> "Val"
+ | K_Lam (kinds,kind) -> "Lam [" ^ string_of_list ", " kind_to_string kinds ^ "] -> " ^ (kind_to_string kind)
(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *)
type envs = Nameset.t * kind Envmap.t * order
@@ -404,7 +430,7 @@ let to_ast_lit (Parse_ast.L_aux(lit,l)) : lit =
| Parse_ast.L_string(s) -> L_string(s))
,l)
-let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pat,l) : Parse_ast.pat) : tannot pat =
+let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pat,l) : Parse_ast.pat) : unit pat =
P_aux(
(match pat with
| Parse_ast.P_lit(lit) -> P_lit(to_ast_lit lit)
@@ -419,17 +445,17 @@ let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pa
| Parse_ast.P_record(fpats,_) ->
P_record(List.map
(fun (Parse_ast.FP_aux(Parse_ast.FP_Fpat(id,fp),l)) ->
- FP_aux(FP_Fpat(to_ast_id id, to_ast_pat k_env def_ord fp),(l,NoTyp)))
+ FP_aux(FP_Fpat(to_ast_id id, to_ast_pat k_env def_ord fp),(l,())))
fpats, false)
| Parse_ast.P_vector(pats) -> P_vector(List.map (to_ast_pat k_env def_ord) pats)
| Parse_ast.P_vector_indexed(ipats) -> P_vector_indexed(List.map (fun (i,pat) -> i,to_ast_pat k_env def_ord pat) ipats)
| Parse_ast.P_vector_concat(pats) -> P_vector_concat(List.map (to_ast_pat k_env def_ord) pats)
| Parse_ast.P_tup(pats) -> P_tup(List.map (to_ast_pat k_env def_ord) pats)
| Parse_ast.P_list(pats) -> P_list(List.map (to_ast_pat k_env def_ord) pats)
- ), (l,NoTyp))
+ ), (l,()))
-let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_aux(lb,l) : Parse_ast.letbind) : tannot letbind =
+let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_aux(lb,l) : Parse_ast.letbind) : unit letbind =
LB_aux(
(match lb with
| Parse_ast.LB_val_explicit(typschm,pat,exp) ->
@@ -437,9 +463,9 @@ let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_a
LB_val_explicit(typsch,to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp)
| Parse_ast.LB_val_implicit(pat,exp) ->
LB_val_implicit(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp)
- ), (l,NoTyp))
+ ), (l,()))
-and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : tannot exp =
+and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit exp =
E_aux(
(match exp with
| Parse_ast.E_block(exps) ->
@@ -466,14 +492,14 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l)
(match to_ast_iexps false k_env def_ord exps with
| Some([]) -> E_vector([])
| Some(iexps) -> E_vector_indexed(iexps,
- Def_val_aux(Def_val_empty,(l,NoTyp)))
+ Def_val_aux(Def_val_empty,(l,())))
| None -> E_vector(List.map (to_ast_exp k_env def_ord) exps))
| Parse_ast.E_vector_indexed(iexps,Parse_ast.Def_val_aux(default,dl)) ->
(match to_ast_iexps true k_env def_ord iexps with
| Some(iexps) -> E_vector_indexed (iexps,
Def_val_aux((match default with
| Parse_ast.Def_val_empty -> Def_val_empty
- | Parse_ast.Def_val_dec e -> Def_val_dec (to_ast_exp k_env def_ord e)),(dl,NoTyp)))
+ | Parse_ast.Def_val_dec e -> Def_val_dec (to_ast_exp k_env def_ord e)),(dl,())))
| _ -> raise (Reporting_basic.err_unreachable l "to_ast_iexps didn't throw error"))
| Parse_ast.E_vector_access(vexp,exp) -> E_vector_access(to_ast_exp k_env def_ord vexp, to_ast_exp k_env def_ord exp)
| Parse_ast.E_vector_subrange(vex,exp1,exp2) ->
@@ -500,9 +526,9 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l)
| Parse_ast.E_exit exp -> E_exit(to_ast_exp k_env def_ord exp)
| Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp)
| Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg)
- ), (l,NoTyp))
+ ), (l,()))
-and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : tannot lexp =
+and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp =
LEXP_aux(
(match exp with
| Parse_ast.E_id(id) -> LEXP_id(to_ast_id id)
@@ -530,17 +556,17 @@ and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l
LEXP_vector_range(to_ast_lexp k_env def_ord vexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2)
| Parse_ast.E_field(fexp,id) -> LEXP_field(to_ast_lexp k_env def_ord fexp, to_ast_id id)
| _ -> typ_error l "Only identifiers, cast identifiers, vector accesses, vector slices, and fields can be on the lefthand side of an assignment" None None None)
- , (l,NoTyp))
+ , (l,()))
-and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex,l) : Parse_ast.pexp) : tannot pexp =
+and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex,l) : Parse_ast.pexp) : unit pexp =
match pex with
- | Parse_ast.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,NoTyp))
+ | Parse_ast.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,()))
| Parse_ast.Pat_when(pat,guard,exp) ->
- Pat_aux (Pat_when (to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord guard, to_ast_exp k_env def_ord exp), (l, NoTyp))
+ Pat_aux (Pat_when (to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord guard, to_ast_exp k_env def_ord exp), (l, ()))
-and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : tannot fexps option =
+and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : unit fexps option =
match exps with
- | [] -> Some(FES_aux(FES_Fexps([],false), (Parse_ast.Unknown,NoTyp)))
+ | [] -> Some(FES_aux(FES_Fexps([],false), (Parse_ast.Unknown,())))
| fexp::exps -> let maybe_fexp,maybe_error = to_ast_record_try k_env def_ord fexp in
(match maybe_fexp,maybe_error with
| Some(fexp),None ->
@@ -553,12 +579,12 @@ and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exp
else None
| _ -> None)
-and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l):Parse_ast.exp): tannot fexp option * (l * string) option =
+and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l):Parse_ast.exp): unit fexp option * (l * string) option =
match exp with
| Parse_ast.E_app_infix(left,op,r) ->
(match left, op with
| Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(Parse_ast.Id("="),leq) ->
- Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp k_env def_ord r), (l,NoTyp))),None
+ Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp k_env def_ord r), (l,()))),None
| Parse_ast.E_aux(_,li) , Parse_ast.Id_aux(Parse_ast.Id("="),leq) ->
None,Some(li,"Expected an identifier to begin this field assignment")
| Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(_,leq) ->
@@ -568,7 +594,7 @@ and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp
| _ ->
None,Some(l, "Expected a field assignment to be identifier = expression")
-and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps:Parse_ast.exp list):(int * tannot exp) list option =
+and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps:Parse_ast.exp list):(int * unit exp) list option =
match exps with
| [] -> Some([])
| iexp::exps -> (match to_iexp_try k_env def_ord iexp with
@@ -581,7 +607,7 @@ and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exp
then typ_error l msg None None None
else None
| _ -> None)
-and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): Parse_ast.exp): ((int * tannot exp) option * (l*string) option) =
+and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): Parse_ast.exp): ((int * unit exp) option * (l*string) option) =
match exp with
| Parse_ast.E_app_infix(left,op,r) ->
(match left,op with
@@ -593,7 +619,7 @@ and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): P
None,(Some(leq,"Expected an indexed vector assignment constant = expression")))
| _ -> None,(Some(l,"Expected an indexed vector assignment: constant = expression"))
-let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : (tannot default_spec) envs_out =
+let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : (unit default_spec) envs_out =
match default with
| Parse_ast.DT_aux(df,l) ->
(match df with
@@ -616,23 +642,23 @@ let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_ty
DT_aux(DT_order default_order,l),(names,k_env,default_order)
| _ -> typ_error l "Inc and Dec must have kind Order" None None None))
-let to_ast_spec (names,k_env,default_order) (val_:Parse_ast.val_spec) : (tannot val_spec) envs_out =
+let to_ast_spec (names,k_env,default_order) (val_:Parse_ast.val_spec) : (unit val_spec) envs_out =
match val_ with
| Parse_ast.VS_aux(vs,l) ->
(match vs with
| Parse_ast.VS_val_spec(ts,id) ->
(*let _ = Printf.eprintf "to_ast_spec called for internal spec: for %s\n" (id_to_string (to_ast_id id)) in*)
let typsch,_,_ = to_ast_typschm k_env default_order ts in
- VS_aux(VS_val_spec(typsch,to_ast_id id),(l,NoTyp)),(names,k_env,default_order)
+ VS_aux(VS_val_spec(typsch,to_ast_id id),(l,())),(names,k_env,default_order)
| Parse_ast.VS_extern_spec(ts,id,s) ->
let typsch,_,_ = to_ast_typschm k_env default_order ts in
- VS_aux(VS_extern_spec(typsch,to_ast_id id,s),(l,NoTyp)),(names,k_env,default_order)
+ VS_aux(VS_extern_spec(typsch,to_ast_id id,s),(l,())),(names,k_env,default_order)
| Parse_ast.VS_cast_spec(ts,id) ->
let typsch,_,_ = to_ast_typschm k_env default_order ts in
- VS_aux(VS_cast_spec(typsch,to_ast_id id),(l,NoTyp)),(names,k_env,default_order)
+ VS_aux(VS_cast_spec(typsch,to_ast_id id),(l,())),(names,k_env,default_order)
| Parse_ast.VS_extern_no_rename(ts,id) ->
let typsch,_,_ = to_ast_typschm k_env default_order ts in
- VS_aux(VS_extern_no_rename(typsch,to_ast_id id),(l,NoTyp)),(names,k_env,default_order))
+ VS_aux(VS_extern_no_rename(typsch,to_ast_id id),(l,())),(names,k_env,default_order))
let to_ast_namescm (Parse_ast.Name_sect_aux(ns,l)) =
@@ -660,7 +686,7 @@ let to_ast_type_union k_env default_order (Parse_ast.Tu_aux(tu,l)) =
| _ -> Tu_aux(Tu_ty_id(typ, to_ast_id id), l))
| Parse_ast.Tu_id id -> (Tu_aux(Tu_id(to_ast_id id),l))
-let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_def) envs_out =
+let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_def) envs_out =
match td with
| Parse_ast.TD_aux(td,l) ->
(match td with
@@ -668,7 +694,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_
let id = to_ast_id id in
let key = id_to_string id in
let typschm,k_env,_ = to_ast_typschm k_env def_ord typschm in
- let td_abrv = TD_aux(TD_abbrev(id,to_ast_namescm name_scm_opt,typschm),(l,NoTyp)) in
+ let td_abrv = TD_aux(TD_abbrev(id,to_ast_namescm name_scm_opt,typschm),(l,())) in
let typ = (match typschm with
| TypSchm_aux(TypSchm_ts(tq,typ), _) ->
begin match (typquant_to_quantkinds k_env tq) with
@@ -681,7 +707,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_
let key = id_to_string id in
let typq,k_env,_ = to_ast_typquant k_env typq in
let fields = List.map (fun (atyp,id) -> (to_ast_typ k_env def_ord atyp),(to_ast_id id)) fields in (* Add check that all arms have unique names locally *)
- let td_rec = TD_aux(TD_record(id,to_ast_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in
+ let td_rec = TD_aux(TD_record(id,to_ast_namescm name_scm_opt,typq,fields,false),(l,())) in
let typ = (match (typquant_to_quantkinds k_env typq) with
| [ ] -> {k = K_Typ}
| typs -> {k = K_Lam(typs,{k=K_Typ})}) in
@@ -691,7 +717,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_
let key = id_to_string id in
let typq,k_env,_ = to_ast_typquant k_env typq in
let arms = List.map (to_ast_type_union k_env def_ord) arms in (* Add check that all arms have unique names *)
- let td_var = TD_aux(TD_variant(id,to_ast_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in
+ let td_var = TD_aux(TD_variant(id,to_ast_namescm name_scm_opt,typq,arms,false),(l,())) in
let typ = (match (typquant_to_quantkinds k_env typq) with
| [ ] -> {k = K_Typ}
| typs -> {k = K_Lam(typs,{k=K_Typ})}) in
@@ -701,7 +727,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_
let key = id_to_string id in
let enums = List.map to_ast_id enums in
let keys = List.map id_to_string enums in
- let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *)
+ let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *)
let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in
td_enum, (names,k_env,def_ord)
| Parse_ast.TD_register(id,t1,t2,ranges) ->
@@ -710,9 +736,9 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_
let n1 = to_ast_nexp k_env t1 in
let n2 = to_ast_nexp k_env t2 in
let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in
- TD_aux(TD_register(id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord))
+ TD_aux(TD_register(id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord))
-let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def) envs_out =
+let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (unit kind_def) envs_out =
match td with
| Parse_ast.KD_aux(td,l) ->
(match td with
@@ -723,7 +749,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
(match k.k with
| K_Typ | K_Lam _ ->
let typschm,k_env,_ = to_ast_typschm k_env def_ord typschm in
- let kd_abrv = KD_aux(KD_abbrev(kind,id,to_ast_namescm name_scm_opt,typschm),(l,NoTyp)) in
+ let kd_abrv = KD_aux(KD_abbrev(kind,id,to_ast_namescm name_scm_opt,typschm),(l,())) in
let typ = (match typschm with
| TypSchm_aux(TypSchm_ts(tq,typ), _) ->
begin match (typquant_to_quantkinds k_env tq) with
@@ -737,7 +763,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
| Parse_ast.TypSchm_aux(Parse_ast.TypSchm_ts(Parse_ast.TypQ_aux(tq,_),atyp),_) ->
(match tq with
| Parse_ast.TypQ_no_forall ->
- KD_aux(KD_nabbrev(kind,id,to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l,NoTyp))
+ KD_aux(KD_nabbrev(kind,id,to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l,()))
| _ -> typ_error l "Def with kind Nat cannot have universal quantification" None None None)) in
kd_nabrv,(names,Envmap.insert k_env (key, k),def_ord)
| _ -> assert false
@@ -748,7 +774,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
let (kind,k) = to_ast_kind k_env kind in
let typq,k_env,_ = to_ast_typquant k_env typq in
let fields = List.map (fun (atyp,id) -> (to_ast_typ k_env def_ord atyp),(to_ast_id id)) fields in (* Add check that all arms have unique names locally *)
- let kd_rec = KD_aux(KD_record(kind,id,to_ast_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in
+ let kd_rec = KD_aux(KD_record(kind,id,to_ast_namescm name_scm_opt,typq,fields,false),(l,())) in
let typ = (match (typquant_to_quantkinds k_env typq) with
| [ ] -> {k = K_Typ}
| typs -> {k = K_Lam(typs,{k=K_Typ})}) in
@@ -759,7 +785,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
let kind,k = to_ast_kind k_env kind in
let typq,k_env,_ = to_ast_typquant k_env typq in
let arms = List.map (to_ast_type_union k_env def_ord) arms in (* Add check that all arms have unique names *)
- let kd_var = KD_aux(KD_variant(kind,id,to_ast_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in
+ let kd_var = KD_aux(KD_variant(kind,id,to_ast_namescm name_scm_opt,typq,arms,false),(l,())) in
let typ = (match (typquant_to_quantkinds k_env typq) with
| [ ] -> {k = K_Typ}
| typs -> {k = K_Lam(typs,{k=K_Typ})}) in
@@ -770,7 +796,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
let kind,k = to_ast_kind k_env kind in
let enums = List.map to_ast_id enums in
let keys = List.map id_to_string enums in
- let kd_enum = KD_aux(KD_enum(kind,id,to_ast_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *)
+ let kd_enum = KD_aux(KD_enum(kind,id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *)
let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in
kd_enum, (names,k_env,def_ord)
| Parse_ast.KD_register(kind,id,t1,t2,ranges) ->
@@ -780,7 +806,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def
let n1 = to_ast_nexp k_env t1 in
let n2 = to_ast_nexp k_env t2 in
let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in
- KD_aux(KD_register(kind,id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord))
+ KD_aux(KD_register(kind,id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord))
let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt =
@@ -802,25 +828,25 @@ let to_ast_effects_opt (k_env : kind Envmap.t) (Parse_ast.Effect_opt_aux(e,l)) :
| Parse_ast.Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l)
| Parse_ast.Effect_opt_effect(typ) -> Effect_opt_aux(Effect_opt_effect(to_ast_effects k_env typ),l)
-let to_ast_funcl (names,k_env,def_ord) (Parse_ast.FCL_aux(fcl,l) : Parse_ast.funcl) : (tannot funcl) =
+let to_ast_funcl (names,k_env,def_ord) (Parse_ast.FCL_aux(fcl,l) : Parse_ast.funcl) : (unit funcl) =
(*let _ = Printf.eprintf "to_ast_funcl\n" in*)
match fcl with
| Parse_ast.FCL_Funcl(id,pat,exp) ->
- FCL_aux(FCL_Funcl(to_ast_id id, to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,NoTyp))
+ FCL_aux(FCL_Funcl(to_ast_id id, to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,()))
-let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.fundef) : (tannot fundef) envs_out =
+let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.fundef) : (unit fundef) envs_out =
match fd with
| Parse_ast.FD_function(rec_opt,tannot_opt,effects_opt,funcls) ->
(*let _ = Printf.eprintf "to_ast_fundef\n" in*)
let tannot_opt, k_env,_ = to_ast_tannot_opt k_env def_ord tannot_opt in
- FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,NoTyp)), (names,k_env,def_ord)
+ FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,())), (names,k_env,def_ord)
type def_progress =
No_def
| Def_place_holder of id * Parse_ast.l
- | Finished of tannot def
+ | Finished of unit def
-type partial_def = ((tannot def) * bool) ref * kind Envmap.t
+type partial_def = ((unit def) * bool) ref * kind Envmap.t
let rec def_in_progress (id : id) (partial_defs : (id * partial_def) list) : partial_def option =
match partial_defs with
@@ -834,17 +860,17 @@ let to_ast_alias_spec k_env def_ord (Parse_ast.E_aux(e,le)) =
AL_aux(
(match e with
| Parse_ast.E_field(Parse_ast.E_aux(Parse_ast.E_id id,li), field) ->
- AL_subreg(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_id field)
+ AL_subreg(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_id field)
| Parse_ast.E_vector_access(Parse_ast.E_aux(Parse_ast.E_id id,li),range) ->
- AL_bit(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_exp k_env def_ord range)
+ AL_bit(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord range)
| Parse_ast.E_vector_subrange(Parse_ast.E_aux(Parse_ast.E_id id,li),base,stop) ->
- AL_slice(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_exp k_env def_ord base,to_ast_exp k_env def_ord stop)
+ AL_slice(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord base,to_ast_exp k_env def_ord stop)
| Parse_ast.E_vector_append(Parse_ast.E_aux(Parse_ast.E_id first,lf),
Parse_ast.E_aux(Parse_ast.E_id second,ls)) ->
- AL_concat(RI_aux(RI_id (to_ast_id first),(lf,NoTyp)),
- RI_aux(RI_id (to_ast_id second),(ls,NoTyp)))
+ AL_concat(RI_aux(RI_id (to_ast_id first),(lf,())),
+ RI_aux(RI_id (to_ast_id second),(ls,())))
| _ -> raise (Reporting_basic.err_unreachable le "Found an expression not supported by parser in to_ast_alias_spec")
- ), (le,NoTyp))
+ ), (le,()))
let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) =
DEC_aux(
@@ -855,7 +881,7 @@ let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) =
DEC_alias(to_ast_id id,to_ast_alias_spec k_env def_ord e)
| Parse_ast.DEC_typ_alias(typ,id,e) ->
DEC_typ_alias(to_ast_typ k_env def_ord typ,to_ast_id id,to_ast_alias_spec k_env def_ord e)
- ),(l,NoTyp))
+ ),(l,()))
let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out * (id * partial_def) list =
let envs = (names,k_env,def_ord) in
@@ -887,11 +913,11 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out
(match sd with
| Parse_ast.SD_scattered_function(rec_opt, tannot_opt, effects_opt, id) ->
let rec_opt = to_ast_rec rec_opt in
- let tannot,k_env',k_local = to_ast_tannot_opt k_env def_ord tannot_opt in
+ let unit,k_env',k_local = to_ast_tannot_opt k_env def_ord tannot_opt in
let effects_opt = to_ast_effects_opt k_env' effects_opt in
let id = to_ast_id id in
(match (def_in_progress id partial_defs) with
- | None -> let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,tannot,effects_opt,[]),(l,NoTyp)))),false) in
+ | None -> let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,unit,effects_opt,[]),(l,())))),false) in
(No_def,envs),((id,(partial_def,k_local))::partial_defs)
| Some(d,k) -> typ_error l "Scattered function definition header name already in use by scattered definition" (Some id) None None)
| Parse_ast.SD_scattered_funcl(funcl) ->
@@ -919,7 +945,7 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out
| [ ] -> {k = K_Typ}
| typs -> {k = K_Lam(typs,{k=K_Typ})}) in
(match (def_in_progress id partial_defs) with
- | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,NoTyp)))),false) in
+ | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,())))),false) in
(Def_place_holder(id,l),(names,Envmap.insert k_env ((id_to_string id),kind),def_ord)),(id,(partial_def,k_env'))::partial_defs
| Some(d,k) -> typ_error l "Scattered type definition header name already in use by scattered definition" (Some id) None None)
| Parse_ast.SD_scattered_unioncl(id,tu) ->
@@ -975,3 +1001,30 @@ let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : ord
| (_, true) -> ()))
partial_defs;
(Defs defs),k_env,def_ord
+
+let initial_kind_env =
+ Envmap.from_list [
+ ("bool", {k = K_Typ});
+ ("nat", {k = K_Typ});
+ ("int", {k = K_Typ});
+ ("uint8", {k = K_Typ});
+ ("uint16", {k= K_Typ});
+ ("uint32", {k=K_Typ});
+ ("uint64", {k=K_Typ});
+ ("unit", {k = K_Typ});
+ ("bit", {k = K_Typ});
+ ("string", {k = K_Typ});
+ ("real", {k = K_Typ});
+ ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})});
+ ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})});
+ ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})});
+ ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) });
+ ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } );
+ ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})});
+ ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) });
+ ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} );
+ ]
+
+let process_ast defs =
+ let (ast, _, _) = to_ast Nameset.empty initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown)) defs in
+ ast
diff --git a/src/initial_check.mli b/src/initial_check.mli
index 5e4b7e77..063a0131 100644
--- a/src/initial_check.mli
+++ b/src/initial_check.mli
@@ -41,13 +41,8 @@
(**************************************************************************)
open Ast
-open Type_internal
-type kind = Type_internal.kind
-type typ = Type_internal.t
-(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *)
-type envs = Nameset.t * kind Envmap.t * Ast.order
-type 'a envs_out = 'a * envs
+val process_ast : Parse_ast.defs -> unit defs
-val to_ast : Nameset.t -> kind Envmap.t -> Ast.order -> Parse_ast.defs -> tannot defs * kind Envmap.t * Ast.order
-val to_ast_exp : kind Envmap.t -> Ast.order -> Parse_ast.exp -> Type_internal.tannot Ast.exp
+
+
diff --git a/src/monomorphise_new.ml b/src/monomorphise_new.ml
index 6bb920da..e7a3528d 100644
--- a/src/monomorphise_new.ml
+++ b/src/monomorphise_new.ml
@@ -1,7 +1,7 @@
open Parse_ast
open Ast
open Ast_util
-open Type_check_new
+open Type_check
let disable_const_propagation = ref false
let size_set_limit = 8
diff --git a/src/pretty_print.ml b/src/pretty_print.ml
index 7ef6b537..e827320b 100644
--- a/src/pretty_print.ml
+++ b/src/pretty_print.ml
@@ -40,7 +40,6 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-include Pretty_print_t_ascii
include Pretty_print_lem_ast
include Pretty_print_sail
include Pretty_print_ocaml
diff --git a/src/pretty_print.mli b/src/pretty_print.mli
index 78764657..24816206 100644
--- a/src/pretty_print.mli
+++ b/src/pretty_print.mli
@@ -41,7 +41,7 @@
(**************************************************************************)
open Ast
-open Type_check_new
+open Type_check
(* Prints the defs following source syntax *)
val pp_defs : out_channel -> 'a defs -> unit
@@ -53,6 +53,3 @@ val pp_lem_defs : Format.formatter -> tannot defs -> unit
val pp_defs_ocaml : out_channel -> tannot defs -> string -> string list -> unit
val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit
-
-
-val pp_format_annot_ascii : Type_internal.tannot -> string
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 911c4138..6b7b8aca 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -41,7 +41,7 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-open Type_check_new
+open Type_check
open Ast
open Ast_util
open Rewriter
@@ -1351,10 +1351,6 @@ let find_regtypes (Defs defs) =
| _ -> acc
) [] defs
-
-let typ_to_t env =
- Type_check.typ_to_t env false false
-
let pp_defs_lem (types_file,types_modules) (prompt_file,prompt_modules) (state_file,state_modules) d top_line =
let regtypes = find_regtypes d in
let (typdefs,valdefs) = doc_defs_lem regtypes d in
diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml
index 0fb6ed91..6809826a 100644
--- a/src/pretty_print_lem_ast.ml
+++ b/src/pretty_print_lem_ast.ml
@@ -40,7 +40,7 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-open Type_check_new
+open Type_check
open Ast
open Format
open Big_int
diff --git a/src/pretty_print_ocaml.ml b/src/pretty_print_ocaml.ml
index 35a34cd6..652b0ce9 100644
--- a/src/pretty_print_ocaml.ml
+++ b/src/pretty_print_ocaml.ml
@@ -43,7 +43,7 @@
open Big_int
open Ast
open Ast_util
-open Type_check_new
+open Type_check
open PPrint
open Pretty_print_common
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index c674735d..51f23e3f 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -40,7 +40,6 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-(* open Type_internal *)
open Ast
open PPrint
open Pretty_print_common
diff --git a/src/pretty_print_t_ascii.ml b/src/pretty_print_t_ascii.ml
deleted file mode 100644
index 273ceb29..00000000
--- a/src/pretty_print_t_ascii.ml
+++ /dev/null
@@ -1,152 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-open Type_internal
-open Ast
-open Pretty_print_common
-open Big_int
-
-(* **************************************************************************
- * pp from tannot to ASCII source, for pp of built-in type environment
- *)
-
-let rec pp_format_t_ascii t =
- match t.t with
- | Tid i -> i
- | Tvar i -> "'" ^ i
- | Tfn(t1,t2,_,e) -> (pp_format_t_ascii t1) ^ " -> " ^ (pp_format_t_ascii t2) ^ (match e.effect with Eset [] -> "" | _ -> " effect " ^ pp_format_e_ascii e)
- | Ttup(tups) -> "(" ^ (list_format ", " pp_format_t_ascii tups) ^ ")"
- | Tapp(i,args) -> i ^ "<" ^ list_format ", " pp_format_targ_ascii args ^ ">"
- | Tabbrev(ti,ta) -> (pp_format_t_ascii ti) (* (pp_format_t_ascii ta) *)
- | Tuvar(_) -> failwith "Tuvar in pp_format_t_ascii"
- | Toptions _ -> failwith "Toptions in pp_format_t_ascii"
-and pp_format_targ_ascii = function
- | TA_typ t -> pp_format_t_ascii t
- | TA_nexp n -> pp_format_n_ascii n
- | TA_eft e -> pp_format_e_ascii e
- | TA_ord o -> pp_format_o_ascii o
-and pp_format_n_ascii n =
- match n.nexp with
- | Nid (i, n) -> i (* from an abbreviation *)
- | Nvar i -> "'" ^ i
- | Nconst i -> (string_of_int (int_of_big_int i))
- | Npos_inf -> "infinity"
- | Nadd(n1,n2) -> (pp_format_n_ascii n1) ^ "+" ^ (pp_format_n_ascii n2)
- | Nsub(n1,n2) -> (pp_format_n_ascii n1) ^ "-" ^ (pp_format_n_ascii n2)
- | Nmult(n1,n2) -> (pp_format_n_ascii n1) ^ "*" ^ (pp_format_n_ascii n2)
- | N2n(n,_) -> "2**"^(pp_format_n_ascii n) (* string_of_big_int i ^ *)
- | Nneg n -> "-" ^ (pp_format_n_ascii n)
- | Nuvar _ -> failwith "Nuvar in pp_format_n_ascii"
- | Nneg_inf -> "-infinity"
- | Npow _ -> failwith "Npow in pp_format_n_ascii"
- | Ninexact -> failwith "Ninexact in pp_format_n_ascii"
-and pp_format_e_ascii e =
- match e.effect with
- | Evar i -> "'" ^ i
- | Eset es -> "{" ^
- (list_format ", " pp_format_base_effect_ascii es) ^ "}"
- | Euvar(_) -> failwith "Euvar in pp_format_e_ascii"
-and pp_format_o_ascii o =
- match o.order with
- | Ovar i -> "'" ^ i
- | Oinc -> "inc"
- | Odec -> "dec"
- | Ouvar(_) -> failwith "Ouvar in pp_format_o_ascii"
-and pp_format_base_effect_ascii (BE_aux(e,l)) =
- match e with
- | BE_rreg -> "rreg"
- | BE_wreg -> "wreg"
- | BE_rmem -> "rmem"
- | BE_rmemt -> "rmemt"
- | BE_wmem -> "wmem"
- | BE_wmv -> "wmv"
- | BE_wmvt -> "wmvt"
- | BE_eamem -> "eamem"
- | BE_exmem -> "exmem"
- | BE_barr -> "barr"
- | BE_depend -> "depend"
- | BE_undef -> "undef"
- | BE_unspec -> "unspec"
- | BE_nondet -> "nondet"
- | BE_lset -> "lset"
- | BE_lret -> "lret"
- | BE_escape -> "escape"
-
-and pp_format_nes_ascii nes =
- list_format ", " pp_format_ne_ascii nes
-
-and pp_format_ne_ascii ne =
- match ne with
- | Lt(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " < " ^ pp_format_n_ascii n2
- | LtEq(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " <= " ^ pp_format_n_ascii n2
- | NtEq(_,n1,n2) -> pp_format_n_ascii n1 ^ " != " ^ pp_format_n_ascii n2
- | Eq(_,n1,n2) -> pp_format_n_ascii n1 ^ " = " ^ pp_format_n_ascii n2
- | GtEq(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " >= " ^ pp_format_n_ascii n2
- | Gt(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " > " ^ pp_format_n_ascii n2
- | In(_,i,ns) | InS(_,{nexp=Nvar i},ns) ->
- i ^ " IN {" ^ (list_format ", " string_of_int ns)^ "}"
- | InS(_,_,ns) -> (* when the variable has been replaced by a unification variable, we use this *)
- failwith "InS in pp_format_nes_ascii" (*"(Nec_in \"fresh\" [" ^ (list_format "; " string_of_int ns)^ "])"*)
- | Predicate(_,n1,n2) -> "flow_constraints(" ^ pp_format_ne_ascii n1 ^", "^ pp_format_ne_ascii n2 ^")"
- | CondCons(_,_,_,nes_c,nes_t) ->
- failwith "CondCons in pp_format_nes_ascii" (*"(Nec_cond " ^ (pp_format_nes nes_c) ^ " " ^ (pp_format_nes nes_t) ^ ")"*)
- | BranchCons(_,_,nes_b) ->
- failwith "BranchCons in pp_format_nes_ascii" (*"(Nec_branch " ^ (pp_format_nes nes_b) ^ ")"*)
-
-let rec pp_format_annot_ascii = function
- | NoTyp -> "Nothing"
- | Base((targs,t),tag,nes,efct,efctsum,_) ->
- (*TODO print out bindings for use in pattern match in interpreter*)
- (match tag with External (Some s) -> "("^s^") " | _ -> "") ^
- (match (targs,nes) with ([],[]) -> "\n" | _ ->
- "forall " ^ list_format ", " (function (i,k) -> kind_to_string k ^" '"^ i) targs ^
- (match nes with [] -> "" | _ -> ", " ^ pp_format_nes_ascii nes)
- ^ ".\n") ^ " "
- ^ pp_format_t_ascii t
- ^ "\n"
-(*
-^ " ********** " ^ pp_format_tag tag ^ ", " ^ pp_format_nes nes ^ ", " ^
- pp_format_e_lem efct ^ ", " ^ pp_format_e_lem efctsum ^ "))"
-*)
- | Overload (tannot, return_type_overloading_allowed, tannots) ->
- (*pp_format_annot_ascii tannot*) "\n" ^ String.concat "" (List.map (function tannot' -> " " ^ pp_format_annot_ascii tannot' ) tannots)
-
diff --git a/src/process_file.ml b/src/process_file.ml
index 438666e6..c26632d1 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -40,8 +40,6 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-open Type_internal
-
type out_type =
| Lem_ast_out
| Lem_out of string option
@@ -83,13 +81,12 @@ let parse_file (f : string) : Parse_ast.defs =
(*Should add a flag to say whether we want to consider Oinc or Odec the default order *)
-let convert_ast (defs : Parse_ast.defs) : (Type_internal.tannot Ast.defs * kind Envmap.t * Ast.order)=
- Initial_check.to_ast Nameset.empty Type_internal.initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown)) defs
+let convert_ast (defs : Parse_ast.defs) : unit Ast.defs = Initial_check.process_ast defs
let load_file env f =
let ast = parse_file f in
- let (ast, _, _) = convert_ast ast in
- Type_check_new.check env ast
+ let ast = convert_ast ast in
+ Type_check.check env ast
let opt_new_typecheck = ref false
let opt_just_check = ref false
@@ -97,35 +94,24 @@ let opt_ddump_tc_ast = ref false
let opt_dno_cast = ref false
let opt_mono_split = ref ([]:((string * int) * string) list)
-let check_ast (defs : Type_internal.tannot Ast.defs) (k : kind Envmap.t) (o:Ast.order) : Type_check_new.tannot Ast.defs * Type_check_new.Env.t =
- let d_env = { Type_internal.k_env = k; Type_internal.abbrevs = Type_internal.initial_abbrev_env;
- Type_internal.nabbrevs = Envmap.empty;
- Type_internal.namesch = Envmap.empty; Type_internal.enum_env = Envmap.empty;
- Type_internal.rec_env = []; Type_internal.alias_env = Envmap.empty;
- Type_internal.default_o =
- {Type_internal.order = (match o with | (Ast.Ord_aux(Ast.Ord_inc,_)) -> Type_internal.Oinc
- | (Ast.Ord_aux(Ast.Ord_dec,_)) -> Type_internal.Odec
- | _ -> Type_internal.Oinc)};} in
- (* if !opt_new_typecheck
- then *)
- let ienv = if !opt_dno_cast then Type_check_new.Env.no_casts Type_check_new.initial_env else Type_check_new.initial_env in
- let ast, env = Type_check_new.check ienv defs in
- let ast = match !opt_mono_split with
- | [] -> ast
- | l ->
- let ast = Monomorphise_new.split_defs l ast in
- let ienv = Type_check_new.Env.no_casts Type_check_new.initial_env in
- let ast, _ = Type_check_new.check ienv ast in
- ast
- in
- let () = if !opt_ddump_tc_ast then Pretty_print.pp_defs stdout ast else () in
- let () = if !opt_just_check then exit 0 else () in
- (ast, env)
- (* else Type_check.check (Type_check.Env (d_env, Type_internal.initial_typ_env,Type_internal.nob,Envmap.empty)) defs *)
-
-let rewrite_ast (defs: Type_check_new.tannot Ast.defs) = Rewriter.rewrite_defs defs
-let rewrite_ast_lem (defs: Type_check_new.tannot Ast.defs) = Rewriter.rewrite_defs_lem defs
-let rewrite_ast_ocaml (defs: Type_check_new.tannot Ast.defs) = Rewriter.rewrite_defs_ocaml defs
+let check_ast (defs : unit Ast.defs) : Type_check.tannot Ast.defs * Type_check.Env.t =
+ let ienv = if !opt_dno_cast then Type_check.Env.no_casts Type_check.initial_env else Type_check.initial_env in
+ let ast, env = Type_check.check ienv defs in
+ let ast = match !opt_mono_split with
+ | [] -> ast
+ | l ->
+ let ast = Monomorphise_new.split_defs l ast in
+ let ienv = Type_check.Env.no_casts Type_check.initial_env in
+ let ast, _ = Type_check.check ienv ast in
+ ast
+ in
+ let () = if !opt_ddump_tc_ast then Pretty_print.pp_defs stdout ast else () in
+ let () = if !opt_just_check then exit 0 else () in
+ (ast, env)
+
+let rewrite_ast (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs defs
+let rewrite_ast_lem (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs_lem defs
+let rewrite_ast_ocaml (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs_ocaml defs
let open_output_with_check file_name =
let (temp_file_name, o) = Filename.open_temp_file "ll_temp" "" in
diff --git a/src/process_file.mli b/src/process_file.mli
index c966367b..f91fa064 100644
--- a/src/process_file.mli
+++ b/src/process_file.mli
@@ -41,13 +41,13 @@
(**************************************************************************)
val parse_file : string -> Parse_ast.defs
-val convert_ast : Parse_ast.defs -> Type_internal.tannot Ast.defs * Type_internal.kind Type_internal.Envmap.t * Ast.order
-val check_ast: Type_internal.tannot Ast.defs -> Type_internal.kind Type_internal.Envmap.t -> Ast.order -> Type_check_new.tannot Ast.defs * Type_check_new.Env.t
-val rewrite_ast: Type_check_new.tannot Ast.defs -> Type_check_new.tannot Ast.defs
-val rewrite_ast_lem : Type_check_new.tannot Ast.defs -> Type_check_new.tannot Ast.defs
-val rewrite_ast_ocaml : Type_check_new.tannot Ast.defs -> Type_check_new.tannot Ast.defs
+val convert_ast : Parse_ast.defs -> unit Ast.defs
+val check_ast: unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t
+val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val load_file : Type_check_new.Env.t -> string -> Type_check_new.tannot Ast.defs * Type_check_new.Env.t
+val load_file : Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t
val opt_new_typecheck : bool ref
val opt_just_check : bool ref
@@ -63,7 +63,7 @@ type out_type =
val output :
string -> (* The path to the library *)
out_type -> (* Backend kind *)
- (string * Type_check_new.tannot Ast.defs) list -> (*File names paired with definitions *)
+ (string * Type_check.tannot Ast.defs) list -> (*File names paired with definitions *)
unit
(** [always_replace_files] determines whether Sail only updates modified files.
diff --git a/src/rewriter.ml b/src/rewriter.ml
index 96a729e6..d1e73c0a 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -44,7 +44,7 @@
open Big_int
open Ast
open Ast_util
-open Type_check_new
+open Type_check
open Spec_analysis
type 'a rewriters = {
diff --git a/src/rewriter.mli b/src/rewriter.mli
index 584d33fa..b2b0bf5e 100644
--- a/src/rewriter.mli
+++ b/src/rewriter.mli
@@ -43,7 +43,7 @@
open Big_int
open Ast
-open Type_check_new
+open Type_check
type 'a rewriters = { rewrite_exp : 'a rewriters -> 'a exp -> 'a exp;
rewrite_lexp : 'a rewriters -> 'a lexp -> 'a lexp;
diff --git a/src/sail.ml b/src/sail.ml
index 82ce4f83..5eba006a 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -77,15 +77,9 @@ let options = Arg.align ([
Arg.String (fun l -> lib := l::!lib),
"<library_filename> treat this file as input only and generate no output for it");
*)
- ( "-print_initial_env",
- Arg.Set opt_print_initial_env,
- " print the built-in initial type environment and terminate");
( "-verbose",
Arg.Set opt_print_verbose,
" (debug) pretty-print the input to standard output");
- ( "-skip_constraints",
- Arg.Clear Type_internal.do_resolve_constraints,
- " (debug) skip constraint resolution in type-checking");
( "-mono-split",
Arg.String (fun s ->
let l = Util.split_on_char ':' s in
@@ -103,7 +97,7 @@ let options = Arg.align ([
Arg.Set opt_ddump_tc_ast,
" (debug) dump the typechecked ast to stdout");
( "-dtc_verbose",
- Arg.Int (fun verbosity -> Type_check_new.opt_tc_debug := verbosity),
+ Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity),
" (debug) verbose typechecker output: 0 is silent");
( "-dno_cast",
Arg.Set opt_dno_cast,
@@ -128,29 +122,14 @@ let _ =
let main() =
if !(opt_print_version)
then Printf.printf "Sail private release \n"
- else if !(opt_print_initial_env) then
- let ppd_initial_typ_env =
- String.concat ""
- (List.map
- (function (comment,tenv) ->
- "(* "^comment^" *)\n" ^
- String.concat ""
- (List.map
- (function (id,tannot) ->
- id ^ " : " ^
- Pretty_print.pp_format_annot_ascii tannot
- ^ "\n")
- tenv))
- Type_internal.initial_typ_env_list) in
- Printf.printf "%s" ppd_initial_typ_env ;
- else
+ else
let parsed = (List.map (fun f -> (f,(parse_file f))) !opt_file_arguments) in
- let ast =
+ let ast =
List.fold_right (fun (_,(Parse_ast.Defs ast_nodes)) (Parse_ast.Defs later_nodes)
-> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in
- let (ast,kenv,ord) = convert_ast ast in
- let (ast,type_envs) = check_ast ast kenv ord in
+ let ast = convert_ast ast in
+ let (ast, type_envs) = check_ast ast in
(* let ast = match !opt_mono_split with
| [] -> ast
@@ -162,7 +141,7 @@ let main() =
| None -> fst (List.hd parsed)
| Some f -> f ^ ".sail" in
(*let _ = Printf.eprintf "Type checked, next to pretty print" in*)
- begin
+ begin
(if !(opt_print_verbose)
then ((Pretty_print.pp_defs stdout) ast)
else ());
diff --git a/src/sail.odocl b/src/sail.odocl
index 0872c3f9..445d6b73 100644
--- a/src/sail.odocl
+++ b/src/sail.odocl
@@ -12,5 +12,4 @@ pretty_print
process_file
reporting_basic
type_check
-type_internal
util
diff --git a/src/sail_lib.ml b/src/sail_lib.ml
deleted file mode 100644
index df2b6d61..00000000
--- a/src/sail_lib.ml
+++ /dev/null
@@ -1,76 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-(** A Sail library *)
-
-(* This library is not well-thought. It has grown driven by the need to
- * reuse some components of Sail in the Power XML extraction tool. It
- * should by no means by considered stable (hence the lack of mli
- * interface file), and is not intended for general consumption. Use at
- * your own risks. *)
-
-module Pretty = Pretty_print
-
-let parse_exps s =
- let lexbuf = Lexing.from_string s in
- try
- let pre_exps = Parser.nonempty_exp_list Lexer.token lexbuf in
- List.map (Initial_check.to_ast_exp Type_internal.initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown))) pre_exps
- with
- | Parsing.Parse_error ->
- let pos = Lexing.lexeme_start_p lexbuf in
- let msg = Printf.sprintf "syntax error on character %d" pos.Lexing.pos_cnum in
- failwith msg
- | Parse_ast.Parse_error_locn(l,m) ->
- let rec format l = match l with
- | Parse_ast.Unknown -> "???"
- | Parse_ast.Range(p1,p2) -> Printf.sprintf "%d:%d" p1.Lexing.pos_cnum p2.Lexing.pos_cnum
- | Parse_ast.Generated l -> Printf.sprintf "code generated near: %s" (format l)
- | Parse_ast.Int(s,_) -> Printf.sprintf "code for by: %s" s in
- let msg = Printf.sprintf "syntax error: %s %s" (format l) m in
- failwith msg
- | Lexer.LexError(s,p) ->
- let msg = Printf.sprintf "lexing error: %s %d" s p.Lexing.pos_cnum in
- failwith msg
-
-
-
diff --git a/src/spec_analysis.mli b/src/spec_analysis.mli
index 7c6f3685..6295a7ec 100644
--- a/src/spec_analysis.mli
+++ b/src/spec_analysis.mli
@@ -42,7 +42,7 @@
open Ast
open Util
-open Type_check_new
+open Type_check
(*Determines if the first typ is within the range of the the second typ,
using the constraints provided when the first typ contains variables.
diff --git a/src/type_check.ml b/src/type_check.ml
index fa64364d..f3374fea 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -9,6 +9,7 @@
(* Robert Norton-Wright *)
(* Christopher Pulte *)
(* Peter Sewell *)
+(* Alasdair Armstrong *)
(* *)
(* All rights reserved. *)
(* *)
@@ -40,2495 +41,2604 @@
(* SUCH DAMAGE. *)
(**************************************************************************)
-open Big_int
open Ast
-open Type_internal
-type kind = Type_internal.kind
-type typ = Type_internal.t
-type 'a exp = 'a Ast.exp
-type 'a emap = 'a Envmap.t
-
-type envs = Env of def_envs * tannot emap * bounds_env * t_arg emap
-type 'a envs_out = 'a * envs
-
-let id_to_string (Id_aux(id,l)) =
- match id with
- | Id(s) -> s
- | DeIid(s) -> s
-
-let get_e_typ (E_aux(_,(_,a))) =
- match a with
- | Base((_,t),_,_,_,_,_) -> t
- | _ -> new_t ()
-
-let typ_error l msg = raise (Reporting_basic.err_typ l msg)
-
-let rec field_equivs fields fmaps =
- match fields with
- | [] -> Some []
- | (FP_aux(FP_Fpat(id,pat),(l,annot)))::fields ->
- if (List.mem_assoc (id_to_string id) fmaps)
- then match (field_equivs fields fmaps) with
- | None -> None
- | Some [] -> None
- | Some fs -> Some(((List.assoc (id_to_string id) fmaps),id,l,pat)::fs)
- else None
-
-let rec fields_to_rec fields rec_env =
- match rec_env with
- | [] -> None
- | (id,Register,tannot,fmaps)::rec_env -> fields_to_rec fields rec_env
- | (id,Record,tannot,fmaps)::rec_env ->
- if (List.length fields) = (List.length fmaps) then
- match field_equivs fields fmaps with
- | Some(ftyps) -> Some(id,tannot,ftyps)
- | None -> fields_to_rec fields rec_env
- else fields_to_rec fields rec_env
-
-let kind_to_k (K_aux((K_kind baseks),l)) =
- let bk_to_k (BK_aux(bk,l')) =
- match bk with
- | BK_type -> { k = K_Typ}
- | BK_nat -> { k = K_Nat}
- | BK_order -> { k = K_Ord}
- | BK_effect -> { k = K_Efct}
- in
- match baseks with
- | [] -> raise (Reporting_basic.err_unreachable l "Empty kind")
- | [bk] -> bk_to_k bk
- | bks -> (match List.rev bks with
- | [] -> raise (Reporting_basic.err_unreachable l "Empty after reverse")
- | out::args -> {k = K_Lam( List.map bk_to_k (List.rev args), bk_to_k out) })
-
-let rec has_typ_app check_nested name (Typ_aux(typ,_)) =
- match typ with
- | Typ_id i -> name = (id_to_string i)
- | Typ_tup ts -> List.exists (has_typ_app check_nested name) ts
- | Typ_app(i,args) -> name = (id_to_string i) ||
- (check_nested && (List.exists (has_typ_app_ta check_nested name) args))
- | _ -> false
-and has_typ_app_ta check_nested name (Typ_arg_aux(ta,_)) =
- match ta with
- | Typ_arg_typ t -> has_typ_app check_nested name t
- | _ -> false
+open Util
+open Ast_util
+open Big_int
-let rec extract_if_first recur name (Typ_aux(typ,l)) =
- match (typ,recur) with
- | (Typ_id i,_) | (Typ_app(i,_),_) ->
- if name = (id_to_string i) then Some(typ, Typ_aux(Typ_id (Id_aux (Id "unit", l)),l)) else None
- | (Typ_tup[t'],true) -> extract_if_first false name t'
- | (Typ_tup[t1;t2],true) -> (match extract_if_first false name t1 with
- | Some(t,_) -> Some(t,t2)
- | None -> None)
- | (Typ_tup(t'::ts),true) -> (match (extract_if_first false name t') with
- | Some(t,_) -> Some(t, Typ_aux(Typ_tup ts,l))
- | None -> None)
- | _ -> None
-
-let rec typ_to_t envs imp_ok fun_ok (Typ_aux(typ,l)) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- let trans t = typ_to_t envs false false t in
- match typ with
- | Typ_id i ->
- let t_init = {t = Tid (id_to_string i)} in
- let t_abbrev,_ = get_abbrev d_env t_init in
- t_abbrev
- | Typ_var (Kid_aux((Var i),l')) -> {t = Tvar i}
- | Typ_fn (ty1,ty2,e) ->
- if fun_ok
- then
- if has_typ_app false "implicit" ty1
- then
- if imp_ok
- then (match extract_if_first true "implicit" ty1 with
- | Some(imp,new_ty1) -> (match imp with
- | Typ_app(_,[Typ_arg_aux(Typ_arg_nexp ((Nexp_aux(n,l')) as ne),_)]) ->
- {t = Tfn (trans new_ty1, trans ty2, IP_user (anexp_to_nexp envs ne), aeffect_to_effect e)}
- | _ -> typ_error l "Declaring an implicit parameter requires a Nat specification")
- | None -> typ_error l "A function type with an implicit parameter must declare the implicit first")
- else typ_error l "This function has one (or more) implicit parameter(s) not permitted here"
- else {t = Tfn (trans ty1,trans ty2,IP_none,aeffect_to_effect e)}
- else typ_error l "Function types are only permitted at the top level."
- | Typ_tup(tys) -> {t = Ttup (List.map trans tys) }
- | Typ_app(i,args) -> {t = Tapp (id_to_string i,List.map (typ_arg_to_targ envs) args) }
- | Typ_wild -> new_t ()
-and typ_arg_to_targ envs (Typ_arg_aux(ta,l)) =
- match ta with
- | Typ_arg_nexp n -> TA_nexp (anexp_to_nexp envs n)
- | Typ_arg_typ t -> TA_typ (typ_to_t envs false false t)
- | Typ_arg_order o -> TA_ord (aorder_to_ord o)
- | Typ_arg_effect e -> TA_eft (aeffect_to_effect e)
-and anexp_to_nexp envs ((Nexp_aux(n,l)) : Ast.nexp) : nexp =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match n with
- | Nexp_var (Kid_aux((Var i),l')) -> mk_nv i
- | Nexp_id id ->
- let s = id_to_string id in
- (match Envmap.apply d_env.nabbrevs s with
- |Some n -> n
- | None -> typ_error l ("Unbound nat id " ^ s))
- | Nexp_constant i -> mk_c_int i
- | Nexp_times(n1,n2) -> mk_mult (anexp_to_nexp envs n1) (anexp_to_nexp envs n2)
- | Nexp_sum(n1,n2) -> mk_add (anexp_to_nexp envs n1) (anexp_to_nexp envs n2)
- | Nexp_minus(n1,n2) -> mk_sub (anexp_to_nexp envs n1) (anexp_to_nexp envs n2)
- | Nexp_exp n -> mk_2n(anexp_to_nexp envs n)
- | Nexp_neg n -> mk_neg(anexp_to_nexp envs n)
-and aeffect_to_effect ((Effect_aux(e,l)) : Ast.effect) : effect =
- match e with
- | Effect_var (Kid_aux((Var i),l')) -> {effect = Evar i}
- | Effect_set effects -> {effect = Eset effects}
-and aorder_to_ord (Ord_aux(o,l) : Ast.order) =
- match o with
- | Ord_var (Kid_aux((Var i),l')) -> {order = Ovar i}
- | Ord_inc -> {order = Oinc}
- | Ord_dec -> {order = Odec}
-
-let rec quants_to_consts ((Env (d_env,t_env,b_env,tp_env)) as env) qis : (t_params * t_arg list * nexp_range list) =
- match qis with
- | [] -> [],[],[]
- | (QI_aux(qi,l))::qis ->
- let (ids,typarms,cs) = quants_to_consts env qis in
- (match qi with
- | QI_id(KOpt_aux(ki,l')) ->
- (match ki with
- | KOpt_none (Kid_aux((Var i),l'')) ->
- (match Envmap.apply d_env.k_env i with
- | Some k ->
- let targ = match k.k with
- | K_Typ -> TA_typ {t = Tvar i}
- | K_Nat -> TA_nexp (mk_nv i)
- | K_Ord -> TA_ord { order = Ovar i}
- | K_Efct -> TA_eft { effect = Evar i}
- | _ -> raise (Reporting_basic.err_unreachable l'' "illegal kind allowed") in
- ((i,k)::ids,targ::typarms,cs)
- | None -> raise (Reporting_basic.err_unreachable l'' "Unkinded id without default after initial check"))
- | KOpt_kind(kind,Kid_aux((Var i),l'')) ->
- let k = kind_to_k kind in
- let targ = match k.k with
- | K_Typ -> TA_typ {t = Tvar i}
- | K_Nat -> TA_nexp (mk_nv i)
- | K_Ord -> TA_ord { order = Ovar i}
- | K_Efct -> TA_eft { effect = Evar i}
- | K_Lam _ -> typ_error l'' "kind -> kind not permitted here"
- | _ -> raise (Reporting_basic.err_unreachable l'' "Kind either infer or internal here") in
- ((i,k)::ids,targ::typarms,cs))
- | QI_const(NC_aux(nconst,l')) ->
- (*TODO: somehow the requirement vs best guarantee needs to be derived from user or context*)
- (match nconst with
- | NC_fixed(n1,n2) ->
- (ids,typarms,Eq(Specc l',anexp_to_nexp env n1,anexp_to_nexp env n2)::cs)
- | NC_bounded_ge(n1,n2) ->
- (ids,typarms,GtEq(Specc l',Guarantee,anexp_to_nexp env n1,anexp_to_nexp env n2)::cs)
- | NC_bounded_le(n1,n2) ->
- (ids,typarms,LtEq(Specc l',Guarantee,anexp_to_nexp env n1,anexp_to_nexp env n2)::cs)
- | NC_nat_set_bounded(Kid_aux((Var i),l''), bounds) -> (ids,typarms,In(Specc l',i,bounds)::cs)))
-
-let typq_to_params envs (TypQ_aux(tq,l)) =
- match tq with
- | TypQ_tq(qis) -> quants_to_consts envs qis
- | TypQ_no_forall -> [],[],[]
-
-let typschm_to_tannot envs imp_parm_ok fun_ok ((TypSchm_aux(typschm,l)):typschm) (tag : tag) : tannot =
- match typschm with
- | TypSchm_ts(tq,typ) ->
- let t = typ_to_t envs imp_parm_ok fun_ok typ in
- let (ids,_,constraints) = typq_to_params envs tq in
- Base((ids,t),tag,constraints,pure_e,pure_e,nob)
-
-let into_register_typ t =
- match t.t with
- | Tapp("register",_) -> t
- | Tabbrev(ti,{t=Tapp("register",_)}) -> t
- | _ -> {t=Tapp("register",[TA_typ t])}
-
-let into_register d_env (t : tannot) : tannot =
- match t with
- | Base((ids,ty),tag,constraints,eftl,eftr,bindings) ->
- let ty',_ = get_abbrev d_env ty in
- Base((ids,into_register_typ ty'),tag,constraints,eftl,eftr,bindings)
- | t -> t
-
-let rec check_pattern envs emp_tag expect_t (P_aux(p,(l,annot))) : ((tannot pat) * (tannot emap) * nexp_range list * bounds_env * t) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- (*let _ = Printf.eprintf "checking pattern with expected type %s\n" (t_to_string expect_t) in*)
- let expect_t,cs = get_abbrev d_env expect_t in
- (*let _ = Printf.eprintf "check pattern expect_t after abbrev %s\n" (t_to_string expect_t) in*)
- let expect_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in
- match p with
- | P_lit (L_aux(lit,l')) ->
- let t,lit =
- (match lit with
- | L_unit -> unit_t,lit
- | L_zero -> bit_t,lit
- | L_one -> bit_t,lit
- | L_true -> bit_t,L_one
- | L_false -> bit_t,L_zero
- | L_num i ->
- (match expect_actual.t with
- | Tid "bit" ->
- if i = 0 then bit_t,L_zero
- else if i = 1 then bit_t,L_one
- else {t = Tapp("atom",
- [TA_nexp (mk_c_int i)])},lit
- | _ -> {t = Tapp("atom",
- [TA_nexp (mk_c_int i)])},lit)
- | L_hex s ->
- let size = big_int_of_int ((String.length s) * 4) in
- let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in
- {t = Tapp("vector",
- [TA_nexp (if is_inc then n_zero else mk_c(sub_big_int size one));
- TA_nexp (mk_c size);
- TA_ord d_env.default_o; TA_typ{t=Tid "bit"}])},lit
- | L_bin s ->
- let size = big_int_of_int (String.length s) in
- let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in
- {t = Tapp("vector",
- [TA_nexp(if is_inc then n_zero else mk_c(sub_big_int size one));
- TA_nexp (mk_c size);
- TA_ord d_env.default_o;TA_typ{t = Tid"bit"}])},lit
- | L_string s -> {t = Tid "string"},lit
- | L_undef -> typ_error l' "Cannot pattern match on undefined") in
- (*let _ = Printf.eprintf "checking pattern literal. expected type is %s. t is %s\n"
- (t_to_string expect_t) (t_to_string t) in*)
- let t',cs' = type_consistent (Patt l) d_env Require true t expect_t in
- let cs_l = cs@cs' in
- (P_aux(P_lit(L_aux(lit,l')),(l,cons_tag_annot t emp_tag cs_l)),Envmap.empty,cs_l,nob,t)
- | P_wild ->
- (P_aux(p,(l,cons_tag_annot expect_t emp_tag cs)),Envmap.empty,cs,nob,expect_t)
- | P_as(pat,id) ->
- let v = id_to_string id in
- let (pat',env,constraints,bounds,t) = check_pattern envs emp_tag expect_t pat in
- let bounds = extract_bounds d_env v t in
- let tannot = Base(([],t),emp_tag,cs,pure_e,pure_e,bounds) in
- (P_aux(P_as(pat',id),(l,tannot)),Envmap.insert env (v,tannot),cs@constraints,bounds,t)
- | P_typ(typ,pat) ->
- let t = typ_to_t envs false false typ in
- let t = typ_subst tp_env false t in
- let (pat',env,constraints,bounds,u) = check_pattern envs emp_tag t pat in
- let t,cs_consistent = type_consistent (Patt l) d_env Guarantee false t expect_t in
- (P_aux(P_typ(typ,pat'),(l,tag_annot t emp_tag)),env,cs@constraints@cs_consistent,bounds,t)
- | P_id id ->
- let i = id_to_string id in
- let default_bounds = extract_bounds d_env i expect_t in
- let default = let id_annot = Base(([],expect_t),emp_tag,cs,pure_e,pure_e,default_bounds) in
- let pat_annot = match is_enum_typ d_env expect_t with
- | None -> id_annot
- | Some n -> Base(([],expect_t), Enum n, cs,pure_e,pure_e,default_bounds) in
- (P_aux(p,(l,pat_annot)),Envmap.from_list [(i,id_annot)],cs,default_bounds,expect_t) in
- (match Envmap.apply t_env i with
- | Some(Base((params,t),Constructor n,cs,efl,efr,bounds)) ->
- let t,cs,ef,_ = subst params false false t cs efl in
- (match t.t with
- | Tfn({t = Tid "unit"},t',_,ef) ->
- if conforms_to_t d_env true false t' expect_t
- then
- let tp,cp = type_consistent (Expr l) d_env Guarantee false t' expect_t in
- (P_aux(P_app(id,[]),(l,tag_annot t (Constructor n))),Envmap.empty,cs@cp,bounds,tp)
- else default
- | Tfn(t1,t',_,e) ->
- if conforms_to_t d_env true false t' expect_t
- then typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none")
- else default
- | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type"))
- | Some(Base((params,t),Enum max,cs,efl,efr,bounds)) ->
- let t,cs,ef,_ = subst params false false t cs efl in
- if conforms_to_t d_env false false t expect_t
- then
- let tp,cp = type_consistent (Expr l) d_env Guarantee false t expect_t in
- (P_aux(P_app(id,[]),(l,tag_annot t (Enum max))),Envmap.empty,cs@cp,bounds,tp)
- else default
- | _ -> default)
- | P_app(id,pats) ->
- let i = id_to_string id in
- (*let _ = Printf.eprintf "checking constructor pattern %s with expected type %s \n" i (t_to_string expect_t) in*)
- (match Envmap.apply t_env i with
- | None | Some NoTyp | Some Overload _ -> typ_error l ("Constructor " ^ i ^ " in pattern is undefined")
- | Some(Base((params,t),Constructor n,constraints,efl,efr,bounds)) ->
- let t,dec_cs,_,_ = subst params false false t constraints efl in
- (match t.t with
- | Tid id -> if pats = []
- then let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t expect_t in
- (P_aux(p,(l,cons_tag_annot t' (Constructor n) dec_cs)), Envmap.empty,dec_cs@ret_cs,nob,t')
- else typ_error l ("Constructor " ^ i ^ " does not expect arguments")
- | Tfn(t1,t2,IP_none,ef) ->
- let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t2 expect_t in
- (match pats with
- | [] -> let _ = type_consistent (Patt l) d_env Guarantee false unit_t t1 in
- (P_aux(P_app(id,[]),(l,cons_tag_annot t' (Constructor n) dec_cs)),
- Envmap.empty,dec_cs@ret_cs,nob,t')
- | [p] -> let (p',env,p_cs,bounds,u) = check_pattern envs emp_tag t1 p in
- (*let _ = Printf.eprintf "return constraints are %s\n" (constraints_to_string ret_cs) in*)
- (P_aux(P_app(id,[p']),
- (l,cons_tag_annot t' (Constructor n) dec_cs)),env,dec_cs@p_cs@ret_cs,bounds,t')
- | pats -> let (pats',env,p_cs,bounds,u) =
- match check_pattern envs emp_tag t1 (P_aux(P_tup(pats),(l,annot))) with
- | ((P_aux(P_tup(pats'),_)),env,constraints,bounds,u) -> (pats',env,constraints,bounds,u)
- | _ -> assert false in
- (*let _ = Printf.eprintf "return constraints are %s\n" (constraints_to_string ret_cs) in*)
- (P_aux(P_app(id,pats'),
- (l,cons_tag_annot t' (Constructor n) dec_cs)),env,dec_cs@p_cs@ret_cs,bounds,t'))
- | _ -> typ_error l ("Identifier " ^ i ^ " must be a union constructor"))
- | Some(Base((params,t),tag,constraints,efl,efr,bounds)) ->
- typ_error l ("Identifier " ^ i ^ " used in pattern is not a union constructor"))
- | P_record(fpats,_) ->
- (match (fields_to_rec fpats d_env.rec_env) with
- | None -> typ_error l ("No struct exists with the listed fields")
- | Some(id,tannot,typ_pats) ->
- (match tannot with
- | (Base((vs,t),tag,cs,eft,_,bounds)) ->
- (*let tup = {t = Ttup(List.map (fun (t,_,_,_) -> t) typ_pats)} in*)
- (*let ft = {t = Tfn(tup,t, IP_none,pure_e) } in*)
- let (ft_subst,cs,_,_) = subst vs false false t cs pure_e in
- let subst_rtyp,subst_typs =
- match ft_subst.t with | Tfn({t=Ttup tups},rt,_,_) -> rt,tups
- | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec gave a non function type") in
- let pat_checks =
- List.map2 (fun (_,id,l,pat) styp ->
- let (pat,env,constraints,new_bounds,u) = check_pattern envs emp_tag styp pat in
- let pat = FP_aux(FP_Fpat(id,pat),(l,Base(([],styp),tag,constraints,pure_e,pure_e,new_bounds))) in
- (pat,env,constraints,new_bounds)) typ_pats subst_typs in
- let pats' = List.map (fun (a,_,_,_) -> a) pat_checks in
- (*Need to check for variable duplication here*)
- let env = List.fold_right (fun (_,env,_,_) env' -> Envmap.union env env') pat_checks Envmap.empty in
- let constraints = (List.fold_right (fun (_,_,cs,_) cons -> cs@cons) pat_checks [])@cs in
- let bounds = List.fold_right (fun (_,_,_,bounds) b_env -> merge_bounds bounds b_env) pat_checks nob in
- let t',cs' = type_consistent (Patt l) d_env Guarantee false ft_subst expect_t in
- (P_aux((P_record(pats',false)),(l,cons_tag_annot t' emp_tag (cs@cs'))),env,constraints@cs',bounds,t')
- | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec returned a non Base tannot")))
- | P_vector pats ->
- let (item_t, base, rise, ord) = match expect_actual.t with
- | Tapp("vector",[TA_nexp b;TA_nexp r;TA_ord o;TA_typ i]) -> (i,b,r,o)
- | Tuvar _ -> (new_t (),new_n (),new_n(), d_env.default_o)
- | _ -> typ_error l ("Expected a " ^ t_to_string expect_actual ^ " but found a vector") in
- let (pats',ts,t_envs,constraints,bounds) =
- List.fold_right
- (fun pat (pats,ts,t_envs,constraints,bounds) ->
- let (pat',t_env,cons,bs,t) = check_pattern envs emp_tag item_t pat in
- ((pat'::pats),(t::ts),(t_env::t_envs),(cons@constraints),merge_bounds bs bounds))
- pats ([],[],[],[],nob) in
- let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*Need to check for non-duplication of variables*)
- let (u,cs) = List.fold_right (fun u (t,cs) ->
- let t',cs = type_consistent (Patt l) d_env Require true u t in t',cs) ts (item_t,[]) in
- let len = List.length ts in
- let t =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) | (Ovar _, Oinc) | (Ouvar _,Oinc) ->
- {t = Tapp("vector",[TA_nexp n_zero;
- TA_nexp (mk_c_int len);
- TA_ord{order=Oinc};
- TA_typ u])}
- | (Odec,_) | (Ovar _, Odec) | (Ouvar _,Odec) ->
- {t= Tapp("vector", [TA_nexp (mk_c (if len = 0 then zero else (big_int_of_int (len -1))));
- TA_nexp (mk_c_int len);
- TA_ord{order=Odec};
- TA_typ u;])}
- | _ -> raise (Reporting_basic.err_unreachable l "Default order not set") in
- let _,v_cs = type_consistent (Patt l) d_env Guarantee true t expect_t in
- (*TODO Should gather the constraints here, with regard to the expected base and rise, and potentially reset them above*)
- (P_aux(P_vector(pats'),(l,cons_tag_annot t emp_tag (cs@v_cs))), env,cs@v_cs@constraints,bounds,t)
- | P_vector_indexed(ipats) ->
- let item_t = match expect_actual.t with
- | Tapp("vector",[b;r;o;TA_typ i]) -> i
- | Tuvar _ -> new_t ()
- | _ -> typ_error l ("Expected a vector by pattern form, but a " ^ t_to_string expect_actual ^ " by type") in
- let (is,pats) = List.split ipats in
- let (fst,lst) = (List.hd is),(List.hd (List.rev is)) in
- let inc_or_dec =
- if fst < lst then
- (let _ = List.fold_left
- (fun i1 i2 -> if i1 < i2 then i2
- else typ_error l "Indexed vector pattern was inconsistently increasing") fst (List.tl is) in
- true)
- else if lst < fst then
- (let _ = List.fold_left
- (fun i1 i2 -> if i1 > i2 then i2
- else typ_error l "Indexed vector pattern was inconsistently decreasing") fst (List.tl is) in
- false)
- else typ_error l "Indexed vector cannot be determined as either increasing or decreasing" in
- let base,rise = new_n (), new_n () in
- let (pats',ts,t_envs,constraints,bounds) =
- List.fold_right
- (fun (i,pat) (pats,ts,t_envs,constraints,bounds) ->
- let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag item_t pat in
- (((i,pat')::pats),(t::ts),(env::t_envs),(cons@constraints),merge_bounds new_bounds bounds))
- ipats ([],[],[],[],nob) in
- let co = Patt l in
- let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*TODO Need to check for non-duplication of variables*)
- let (u,cs) = List.fold_right (fun u (t,cs) -> type_consistent co d_env Require true u t) ts (item_t,[]) in
- let t = {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);
- (TA_ord{order=(if inc_or_dec then Oinc else Odec)});(TA_typ u)])} in
- let cs = if inc_or_dec
- then [LtEq(co, Require, base, mk_c_int fst); GtEq(co,Require, rise, mk_c_int(lst-fst));]@cs
- else [GtEq(co, Require, base, mk_c_int fst); LtEq(co,Require, rise, mk_c_int(fst -lst));]@cs in
- (P_aux(P_vector_indexed(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t)
- | P_tup(pats) ->
- let item_ts = match expect_actual.t with
- | Ttup ts ->
- if (List.length ts) = (List.length pats)
- then ts
- else typ_error l ("Expected a pattern with a tuple with " ^ (string_of_int (List.length ts)) ^ " elements")
- | Tuvar _ -> List.map (fun _ -> new_t ()) pats
- | _ -> typ_error l ("Expected a tuple by pattern form, but a " ^ (t_to_string expect_actual) ^ " by type") in
- let (pats',ts,t_envs,constraints,bounds) =
- List.fold_right
- (fun (pat,t) (pats,ts,t_envs,constraints,bounds) ->
- let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag t pat in
- ((pat'::pats),(t::ts),(env::t_envs),cons@constraints,merge_bounds new_bounds bounds))
- (List.combine pats item_ts) ([],[],[],[],nob) in
- let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*Need to check for non-duplication of variables*)
- let t = {t = Ttup ts} in
- (P_aux(P_tup(pats'),(l,tag_annot t emp_tag)), env,constraints,bounds,t)
- | P_vector_concat pats ->
- let item_t,base,rise,order =
- match expect_t.t with
- | Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])
- | Tabbrev(_,{t=Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])}) -> item,b,r,o
- | _ -> new_t (),new_n (), new_n (), d_env.default_o in
- let vec_ti _ = {t= Tapp("vector",[TA_nexp (new_n ());TA_nexp (new_n ());TA_ord order;TA_typ item_t])} in
- let (pats',ts,envs,constraints,bounds) =
- List.fold_right
- (fun pat (pats,ts,t_envs,constraints,bounds) ->
- let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag (vec_ti ()) pat in
- (pat'::pats,t::ts,env::t_envs,cons@constraints,merge_bounds new_bounds bounds))
- pats ([],[],[],[],nob) in
- let env =
- List.fold_right (fun e env -> Envmap.union e env) envs Envmap.empty in (*Need to check for non-duplication of variables*)
- let t = {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);(TA_ord order);(TA_typ item_t)])} in
- let base_c,r1 = match (List.hd ts).t with
- | Tapp("vector",[(TA_nexp b);(TA_nexp r);(TA_ord o);(TA_typ u)]) -> b,r
- | _ -> raise (Reporting_basic.err_unreachable l "vector concat pattern impossibility") in
- let range_c = List.fold_right
- (fun t rn ->
- match t.t with
- | Tapp("vector",[(TA_nexp b);(TA_nexp r);(TA_ord o);(TA_typ u)]) -> mk_add r rn
- | _ -> raise (Reporting_basic.err_unreachable l "vector concat pattern impossibility") ) (List.tl ts) r1 in
- let cs = [Eq((Patt l),rise,range_c)]@cs in
- (P_aux(P_vector_concat(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t)
- | P_list(pats) ->
- let item_t = match expect_actual.t with
- | Tapp("list",[TA_typ i]) -> i
- | Tuvar _ -> new_t ()
- | _ -> typ_error l ("Expected a list here by pattern form, but expected a " ^ t_to_string expect_actual ^ " by type") in
- let (pats',ts,envs,constraints,bounds) =
- List.fold_right
- (fun pat (pats,ts,t_envs,constraints,bounds) ->
- let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag item_t pat in
- (pat'::pats,t::ts,env::t_envs,cons@constraints,merge_bounds new_bounds bounds))
- pats ([],[],[],[],nob) in
- let env = List.fold_right (fun e env -> Envmap.union e env) envs Envmap.empty in (*TODO Need to check for non-duplication of variables*)
- let u,cs = List.fold_right (fun u (t,cs) -> let t',cs' = type_consistent (Patt l) d_env Require true u t in t',cs@cs') ts (item_t,[]) in
- let t = {t = Tapp("list",[TA_typ u])} in
- (P_aux(P_list(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t)
-
-let rec check_pattern_after_constraint_res envs concrete_length_req expect_t (P_aux(p,(l,annot))) : t =
- let check_pat = check_pattern_after_constraint_res envs in
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- (*let _ = Printf.eprintf "checking pattern after constraints with expected type %s\n" (t_to_string expect_t) in*)
- let expect_t,_ = get_abbrev d_env expect_t in
- (*let _ = Printf.eprintf "check pattern after constraints expect_t after abbrev %s\n" (t_to_string expect_t) in*)
- let expect_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in
- let t_inferred = match annot with
- | Base((_,t),tag,cs,_,_,_) -> t
- | _ -> failwith "Inference pass did not annotate a pattern with Base annot" in
- match p with
- | P_lit (L_aux(lit,l')) ->
- let t_from_lit = (match lit with
- | L_unit -> unit_t
- | L_zero | L_one | L_true | L_false -> bit_t
- | L_num i ->
- (match expect_actual.t with
- | Tid "bit" -> if i = 0 || i = 1 then bit_t else typ_error l' "Given number but expected bit"
- | _ -> {t = Tapp("atom", [TA_nexp (mk_c_int i)])})
- | L_hex s ->
- let size = big_int_of_int ((String.length s) * 4) in
- let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in
- mk_vector bit_t d_env.default_o (if is_inc then n_zero else mk_c (sub_big_int size one)) (mk_c size)
- | L_bin s ->
- let size = big_int_of_int (String.length s) in
- let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in
- mk_vector bit_t d_env.default_o (if is_inc then n_zero else mk_c(sub_big_int size one)) (mk_c size)
- | L_string s -> string_t
- | L_undef -> typ_error l' "Cannot pattern match on undefined") in
- let t_c,_ = type_consistent (Patt l) d_env Require true t_from_lit t_inferred in
- let t,_ = type_consistent (Patt l) d_env Require true t_c expect_t in
- t
- | P_wild ->
- let t,_ = type_consistent (Patt l) d_env Require true t_inferred expect_t in t
- | P_as(pat,id) -> check_pat concrete_length_req expect_t pat
- | P_typ(typ,pat) ->
- let tdec = typ_to_t envs false false typ in
- let tdec = typ_subst tp_env false tdec in
- let default _ = let tdec = check_pat false tdec pat in
- let t,_ = type_consistent (Patt l) d_env Guarantee false tdec t_inferred in
- let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in
- t
+let opt_tc_debug = ref 0
+let depth = ref 0
+
+let rec indent n = match n with
+ | 0 -> ""
+ | n -> "| " ^ indent (n - 1)
+
+let typ_debug m = if !opt_tc_debug > 1 then prerr_endline (indent !depth ^ m) else ()
+
+let typ_print m = if !opt_tc_debug > 0 then prerr_endline (indent !depth ^ m) else ()
+
+let typ_warning m = prerr_endline ("Warning: " ^ m)
+
+exception Type_error of l * string;;
+
+let typ_error l m = raise (Type_error (l, m))
+
+let deinfix = function
+ | Id_aux (Id v, l) -> Id_aux (DeIid v, l)
+ | Id_aux (DeIid v, l) -> Id_aux (DeIid v, l)
+
+let string_of_bind (typquant, typ) = string_of_typquant typquant ^ ". " ^ string_of_typ typ
+
+let unaux_nexp (Nexp_aux (nexp, _)) = nexp
+let unaux_order (Ord_aux (ord, _)) = ord
+let unaux_typ (Typ_aux (typ, _)) = typ
+
+let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown)
+let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown)
+let mk_id str = Id_aux (Id str, Parse_ast.Unknown)
+let mk_infix_id str = Id_aux (DeIid str, Parse_ast.Unknown)
+
+let mk_id_typ id = Typ_aux (Typ_id id, Parse_ast.Unknown)
+
+let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown)
+let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown)
+
+let int_typ = mk_id_typ (mk_id "int")
+let nat_typ = mk_id_typ (mk_id "nat")
+let unit_typ = mk_id_typ (mk_id "unit")
+let bit_typ = mk_id_typ (mk_id "bit")
+let real_typ = mk_id_typ (mk_id "real")
+let app_typ id args = mk_typ (Typ_app (id, args))
+let atom_typ nexp = mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)]))
+let range_typ nexp1 nexp2 = mk_typ (Typ_app (mk_id "range", [mk_typ_arg (Typ_arg_nexp nexp1); mk_typ_arg (Typ_arg_nexp nexp2)]))
+let bool_typ = mk_id_typ (mk_id "bool")
+let string_typ = mk_id_typ (mk_id "string")
+
+let vector_typ n m ord typ =
+ mk_typ (Typ_app (mk_id "vector",
+ [mk_typ_arg (Typ_arg_nexp n);
+ mk_typ_arg (Typ_arg_nexp m);
+ mk_typ_arg (Typ_arg_order ord);
+ mk_typ_arg (Typ_arg_typ typ)]))
+
+let is_range (Typ_aux (typ_aux, _)) =
+ match typ_aux with
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)])
+ when string_of_id f = "atom" -> Some (n, n)
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)])
+ when string_of_id f = "range" -> Some (n1, n2)
+ | _ -> None
+
+let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown)
+let nminus n1 n2 = Nexp_aux (Nexp_minus (n1, n2), Parse_ast.Unknown)
+let nsum n1 n2 = Nexp_aux (Nexp_sum (n1, n2), Parse_ast.Unknown)
+let ntimes n1 n2 = Nexp_aux (Nexp_times (n1, n2), Parse_ast.Unknown)
+let npow2 n = Nexp_aux (Nexp_exp n, Parse_ast.Unknown)
+let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown)
+
+let nc_eq n1 n2 = mk_nc (NC_fixed (n1, n2))
+let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2))
+let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown)
+let nc_gteq n1 n2 = NC_aux (NC_bounded_ge (n1, n2), Parse_ast.Unknown)
+let nc_lt n1 n2 = nc_lteq n1 (nsum n2 (nconstant 1))
+let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nconstant 1))
+
+let mk_lit l = E_aux (E_lit (L_aux (l, Parse_ast.Unknown)), (Parse_ast.Unknown, ()))
+
+(* FIXME: Can now negate all n_constraints *)
+let rec nc_negate (NC_aux (nc, _)) =
+ match nc with
+ | NC_bounded_ge (n1, n2) -> nc_lt n1 n2
+ | NC_bounded_le (n1, n2) -> nc_gt n1 n2
+ | NC_fixed (n1, n2) -> nc_neq n1 n2
+ | NC_not_equal (n1, n2) -> nc_eq n1 n2
+ | NC_and (n1, n2) -> mk_nc (NC_or (nc_negate n1, nc_negate n2))
+ | NC_or (n1, n2) -> mk_nc (NC_and (nc_negate n1, nc_negate n2))
+ | NC_nat_set_bounded (kid, []) -> typ_error Parse_ast.Unknown "Cannot negate empty nexp set"
+ | NC_nat_set_bounded (kid, [int]) -> nc_neq (nvar kid) (nconstant int)
+ | NC_nat_set_bounded (kid, int :: ints) ->
+ mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_nat_set_bounded (kid, ints)))))
+
+(* Utilities for constructing effect sets *)
+
+let mk_effect effs =
+ Effect_aux (Effect_set (List.map (fun be_aux -> BE_aux (be_aux, Parse_ast.Unknown)) effs), Parse_ast.Unknown)
+
+let no_effect = mk_effect []
+
+module BESet = Set.Make(BE)
+
+let union_effects e1 e2 =
+ match e1, e2 with
+ | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
+ let base_effs3 = BESet.elements (BESet.of_list (base_effs1 @ base_effs2)) in
+ Effect_aux (Effect_set base_effs3, Parse_ast.Unknown)
+ | _, _ -> assert false (* We don't do Effect variables *)
+
+let equal_effects e1 e2 =
+ match e1, e2 with
+ | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
+ BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0
+ | _, _ -> assert false (* We don't do Effect variables *)
+
+(* An index_sort is a more general form of range type: it can either
+ be IS_int, which represents every natural number, or some set of
+ natural numbers given by an IS_prop expression of the form
+ {'n. f('n) <= g('n) /\ ...} *)
+type index_sort =
+ | IS_int
+ | IS_prop of kid * (nexp * nexp) list
+
+let string_of_index_sort = function
+ | IS_int -> "INT"
+ | IS_prop (kid, constraints) ->
+ "{" ^ string_of_kid kid ^ " | "
+ ^ string_of_list " & " (fun (x, y) -> string_of_nexp x ^ " <= " ^ string_of_nexp y) constraints
+ ^ "}"
+
+(**************************************************************************)
+(* 1. Substitutions *)
+(**************************************************************************)
+
+let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l)
+and nexp_subst_aux sv subst = function
+ | Nexp_id v -> Nexp_id v
+ | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid
+ | Nexp_constant c -> Nexp_constant c
+ | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
+ | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
+ | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
+ | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp)
+ | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp)
+
+let rec nexp_set_to_or l subst = function
+ | [] -> typ_error l "Cannot substitute into empty nexp set"
+ | [int] -> NC_fixed (subst, nconstant int)
+ | (int :: ints) -> NC_or (mk_nc (NC_fixed (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints))
+
+let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l)
+and nc_subst_nexp_aux l sv subst = function
+ | NC_fixed (n1, n2) -> NC_fixed (nexp_subst sv subst n1, nexp_subst sv subst n2)
+ | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2)
+ | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2)
+ | NC_nat_set_bounded (kid, ints) as set_nc ->
+ if Kid.compare kid sv = 0
+ then nexp_set_to_or l (mk_nexp subst) ints
+ else set_nc
+ | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
+ | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
+
+let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l)
+and typ_subst_nexp_aux sv subst = function
+ | Typ_wild -> Typ_wild
+ | Typ_id v -> Typ_id v
+ | Typ_var kid -> Typ_var kid
+ | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2, effs)
+ | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs)
+ | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args)
+and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l)
+and typ_subst_arg_nexp_aux sv subst = function
+ | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp)
+ | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ)
+ | Typ_arg_order ord -> Typ_arg_order ord
+ | Typ_arg_effect eff -> Typ_arg_effect eff
+
+let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l)
+and typ_subst_typ_aux sv subst = function
+ | Typ_wild -> Typ_wild
+ | Typ_id v -> Typ_id v
+ | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid
+ | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2, effs)
+ | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs)
+ | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args)
+and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l)
+and typ_subst_arg_typ_aux sv subst = function
+ | Typ_arg_nexp nexp -> Typ_arg_nexp nexp
+ | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ)
+ | Typ_arg_order ord -> Typ_arg_order ord
+ | Typ_arg_effect eff -> Typ_arg_effect eff
+
+let order_subst_aux sv subst = function
+ | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid
+ | Ord_inc -> Ord_inc
+ | Ord_dec -> Ord_dec
+
+let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l)
+
+let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l)
+and typ_subst_order_aux sv subst = function
+ | Typ_wild -> Typ_wild
+ | Typ_id v -> Typ_id v
+ | Typ_var kid -> Typ_var kid
+ | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2, effs)
+ | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs)
+ | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args)
+and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l)
+and typ_subst_arg_order_aux sv subst = function
+ | Typ_arg_nexp nexp -> Typ_arg_nexp nexp
+ | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ)
+ | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord)
+ | Typ_arg_effect eff -> Typ_arg_effect eff
+
+let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l)
+and typ_subst_kid_aux sv subst = function
+ | Typ_wild -> Typ_wild
+ | Typ_id v -> Typ_id v
+ | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid
+ | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2, effs)
+ | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs)
+ | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args)
+and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l)
+and typ_subst_arg_kid_aux sv subst = function
+ | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp)
+ | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ)
+ | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord)
+ | Typ_arg_effect eff -> Typ_arg_effect eff
+
+let quant_item_subst_kid_aux sv subst = function
+ | QI_id (KOpt_aux (KOpt_none kid, l)) as qid ->
+ if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid
+ | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid ->
+ if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid
+ | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc)
+
+let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l)
+and nexp_simp_aux = function
+ | Nexp_sum (n1, n2) ->
+ begin
+ let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
+ let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
+ match n1_simp, n2_simp with
+ | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 + c2)
+ | _, Nexp_neg n2 -> Nexp_minus (n1, n2)
+ | _, _ -> Nexp_sum (n1, n2)
+ end
+ | Nexp_times (n1, n2) ->
+ begin
+ let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
+ let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
+ match n1_simp, n2_simp with
+ | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 * c2)
+ | _, _ -> Nexp_times (n1, n2)
+ end
+ | Nexp_minus (n1, n2) ->
+ begin
+ let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
+ let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
+ typ_debug ("SIMP: " ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2);
+ match n1_simp, n2_simp with
+ | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 - c2)
+ | _, _ -> Nexp_minus (n1, n2)
+ end
+ | nexp -> nexp
+
+let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l)
+
+let typquant_subst_kid_aux sv subst = function
+ | TypQ_tq quants -> TypQ_tq (List.map (quant_item_subst_kid sv subst) quants)
+ | TypQ_no_forall -> TypQ_no_forall
+
+let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l)
+
+(**************************************************************************)
+(* 2. Environment *)
+(**************************************************************************)
+
+type mut = Immutable | Mutable
+
+type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound
+
+module Env : sig
+ type t
+ val add_val_spec : id -> typquant * typ -> t -> t
+ val get_val_spec : id -> t -> typquant * typ
+ val is_union_constructor : id -> t -> bool
+ val add_record : id -> typquant -> (typ * id) list -> t -> t
+ val is_record : id -> t -> bool
+ val get_accessor : id -> t -> typquant * typ
+ val add_local : id -> mut * typ -> t -> t
+ val add_variant : id -> typquant * type_union list -> t -> t
+ val add_union_id : id -> typquant * typ -> t -> t
+ val add_flow : id -> (typ -> typ) -> t -> t
+ val get_flow : id -> t -> typ -> typ
+ val get_register : id -> t -> typ
+ val add_register : id -> typ -> t -> t
+ val add_regtyp : id -> int -> int -> (index_range * id) list -> t -> t
+ val is_regtyp : id -> t -> bool
+ val get_regtyp : id -> t -> int * int * (index_range * id) list
+ val is_mutable : id -> t -> bool
+ val get_constraints : t -> n_constraint list
+ val add_constraint : n_constraint -> t -> t
+ val get_typ_var : kid -> t -> base_kind_aux
+ val get_typ_vars : t -> base_kind_aux KBindings.t
+ val add_typ_var : kid -> base_kind_aux -> t -> t
+ val get_ret_typ : t -> typ option
+ val add_ret_typ : typ -> t -> t
+ val add_typ_synonym : id -> (typ_arg list -> typ) -> t -> t
+ val get_typ_synonym : id -> t -> typ_arg list -> typ
+ val add_overloads : id -> id list -> t -> t
+ val get_overloads : id -> t -> id list
+ val get_default_order : t -> order
+ val set_default_order_inc : t -> t
+ val set_default_order_dec : t -> t
+ val add_enum : id -> id list -> t -> t
+ val get_enum : id -> t -> id list
+ val get_casts : t -> id list
+ val allow_casts : t -> bool
+ val no_casts : t -> t
+ val enable_casts : t -> t
+ val add_cast : id -> t -> t
+ val lookup_id : id -> t -> lvar
+ val fresh_kid : t -> kid
+ val expand_synonyms : t -> typ -> typ
+ val base_typ_of : t -> typ -> typ
+ val empty : t
+end = struct
+ type t =
+ { top_val_specs : (typquant * typ) Bindings.t;
+ locals : (mut * typ) Bindings.t;
+ union_ids : (typquant * typ) Bindings.t;
+ registers : typ Bindings.t;
+ regtyps : (int * int * (index_range * id) list) Bindings.t;
+ variants : (typquant * type_union list) Bindings.t;
+ typ_vars : base_kind_aux KBindings.t;
+ typ_synonyms : (typ_arg list -> typ) Bindings.t;
+ overloads : (id list) Bindings.t;
+ flow : (typ -> typ) Bindings.t;
+ enums : IdSet.t Bindings.t;
+ records : (typquant * (typ * id) list) Bindings.t;
+ accessors : (typquant * typ) Bindings.t;
+ casts : id list;
+ allow_casts : bool;
+ constraints : n_constraint list;
+ default_order : order option;
+ ret_typ : typ option
+ }
+
+ let empty =
+ { top_val_specs = Bindings.empty;
+ locals = Bindings.empty;
+ union_ids = Bindings.empty;
+ registers = Bindings.empty;
+ regtyps = Bindings.empty;
+ variants = Bindings.empty;
+ typ_vars = KBindings.empty;
+ typ_synonyms = Bindings.empty;
+ overloads = Bindings.empty;
+ flow = Bindings.empty;
+ enums = Bindings.empty;
+ records = Bindings.empty;
+ accessors = Bindings.empty;
+ casts = [];
+ allow_casts = true;
+ constraints = [];
+ default_order = None;
+ ret_typ = None;
+ }
+
+ let counter = ref 0
+
+ let fresh_kid env =
+ let fresh = Kid_aux (Var ("'fv" ^ string_of_int !counter), Parse_ast.Unknown) in
+ incr counter; fresh
+
+ let freshen_kid env kid (typq, typ) =
+ let fresh = fresh_kid env in
+ (typquant_subst_kid kid fresh typq, typ_subst_kid kid fresh typ)
+
+ let freshen_bind env bind =
+ List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars)
+
+ let get_val_spec id env =
+ try
+ let bind = Bindings.find id env.top_val_specs in
+ typ_debug ("get_val_spec: Env has " ^ string_of_list ", " (fun (kid, bk) -> string_of_kid kid ^ " => " ^ string_of_base_kind_aux bk) (KBindings.bindings env.typ_vars));
+ let bind' = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in
+ typ_debug ("get_val_spec: freshened to " ^ string_of_bind bind');
+ bind'
+ with
+ | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id)
+
+ let add_val_spec id bind env =
+ if Bindings.mem id env.top_val_specs
+ then typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound")
+ else
+ begin
+ typ_print ("Adding val spec binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind);
+ { env with top_val_specs = Bindings.add id bind env.top_val_specs }
+ end
+
+ let is_union_constructor id env =
+ let is_ctor id (Tu_aux (tu, _)) = match tu with
+ | Tu_id ctor_id when Id.compare id ctor_id = 0 -> true
+ | Tu_ty_id (_, ctor_id) when Id.compare id ctor_id = 0 -> true
+ | _ -> false
in
- (match tdec.t, concrete_length_req with
- | Tapp ("vector", [_;TA_nexp {nexp = Nconst _};_;_]), true -> default ()
- | Tapp ("vector",_), true ->
- (try (let tdec = check_pat true tdec pat in
- let t,_ = type_consistent (Patt l) d_env Guarantee false tdec t_inferred in
- let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in t) with
- | Reporting_basic.Fatal_error(Reporting_basic.Err_type _) ->
- typ_error l "Type annotation does not provide a concrete vector length and one cannot be inferred")
- | _ -> default ())
- | P_id id ->
- let i = id_to_string id in
- let default t =
- let t,_ = type_consistent (Patt l) d_env Guarantee false t t_inferred in
- let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in t in
- (match Envmap.apply t_env i with
- | Some(Base((params,t),Constructor n,cs,efl,efr,bounds)) ->
- let t,cs,ef,_ = subst params false false t cs efl in
- (match t.t with
- | Tfn({t = Tid "unit"},t',IP_none,ef) ->
- if conforms_to_t d_env false false t' expect_t then default t' else default t
- | Tfn(t1,t',IP_none,e) ->
- if conforms_to_t d_env false false t' expect_t
- then typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none")
- else default t'
- | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type"))
- | Some(Base((params,t),Enum max,cs,efl,efr,bounds)) ->
- let t,cs,ef,_ = subst params false false t cs efl in default t
- | _ -> (match t_inferred.t, concrete_length_req with
- | Tapp ("vector", [_;TA_nexp {nexp = Nconst _};_;_]), true -> default t_inferred
- | Tapp ("vector", _), true ->
- typ_error l ("Unable to infer a vector length for paramter " ^ i ^ ", a type annotation may be required.")
- | _ -> default t_inferred))
- | P_app(id,pats) ->
- let i = id_to_string id in
- (*let _ = Printf.eprintf "checking constructor pattern %s\n" i in*)
- (match Envmap.apply t_env i with
- | None | Some NoTyp | Some Overload _ -> typ_error l ("Constructor " ^ i ^ " in pattern is undefined")
- | Some(Base((params,t),Constructor n,constraints,efl,efr,bounds)) ->
- let t,dec_cs,_,_ = subst params false false t constraints efl in
- (match t.t with
- | Tid id -> if pats = []
- then let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t expect_t in t'
- else typ_error l ("Constructor " ^ i ^ " does not expect arguments")
- | Tfn(t1,t2,IP_none,ef) ->
- let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t2 expect_t in
- (match pats with
- | [] -> let _ = type_consistent (Patt l) d_env Guarantee false unit_t t1 in t'
- | [p] -> check_pat concrete_length_req t1 p
- | pats -> check_pat concrete_length_req t1 (P_aux(P_tup(pats),(l,annot))))
- | _ -> typ_error l ("Identifier " ^ i ^ " must be a union constructor"))
- | Some(Base((params,t),tag,constraints,efl,efr,bounds)) ->
- typ_error l ("Identifier " ^ i ^ " used in pattern is not a union constructor"))
- | P_record(fpats,_) ->
- (match (fields_to_rec fpats d_env.rec_env) with
- | None -> typ_error l ("No struct exists with the listed fields")
- | Some(id,tannot,typ_pats) ->
- (match tannot with
- | (Base((vs,t),tag,cs,eft,_,bounds)) ->
- let (ft_subst,cs,_,_) = subst vs false false t cs pure_e in
- let subst_rtyp,subst_typs =
- match ft_subst.t with | Tfn({t=Ttup tups},rt,_,_) -> rt,tups
- | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec gave a non function type") in
- let _ =
- List.map2 (fun (_,id,l,pat) styp -> check_pat concrete_length_req styp pat) typ_pats subst_typs in
- let t',cs' = type_consistent (Patt l) d_env Guarantee false ft_subst expect_t in t'
- | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec returned a non Base tannot")))
- | P_vector pats ->
- let (item_t, base, rise, ord) = match expect_actual.t with
- | Tapp("vector",[TA_nexp b;TA_nexp r;TA_ord o;TA_typ i]) -> (i,b,r,o)
- | Tuvar _ -> (new_t (),new_n (),new_n(), d_env.default_o)
- | _ -> typ_error l ("Expected a " ^ t_to_string expect_actual ^ " but found a vector") in
- let ts = List.map (check_pat false item_t) pats in
- let (u,cs) = List.fold_right (fun u (t,cs) ->
- let t',cs = type_consistent (Patt l) d_env Require true u t in t',cs) ts (item_t,[]) in
- let len = List.length ts in
- let t =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) | (Ovar _, Oinc) | (Ouvar _,Oinc) ->
- {t = Tapp("vector",[TA_nexp n_zero;
- TA_nexp (mk_c_int len);
- TA_ord{order=Oinc};
- TA_typ u])}
- | (Odec,_) | (Ovar _, Odec) | (Ouvar _,Odec) ->
- {t= Tapp("vector", [TA_nexp (mk_c (if len = 0 then zero else (big_int_of_int (len -1))));
- TA_nexp (mk_c_int len);
- TA_ord{order=Odec};
- TA_typ u;])}
- | _ -> raise (Reporting_basic.err_unreachable l "Default order not set") in
- let _,_ = type_consistent (Patt l) d_env Guarantee true t expect_t in t
- | P_vector_indexed(ipats) ->
- let item_t = match expect_actual.t with
- | Tapp("vector",[b;r;o;TA_typ i]) -> i
- | Tuvar _ -> new_t ()
- | _ -> typ_error l ("Expected a vector by pattern form, but a " ^ t_to_string expect_actual ^ " by type") in
- let (is,pats) = List.split ipats in
- let (fst,lst) = (List.hd is),(List.hd (List.rev is)) in
- let inc_or_dec =
- if fst < lst then
- (let _ = List.fold_left
- (fun i1 i2 -> if i1 < i2 then i2
- else typ_error l "Indexed vector pattern was inconsistently increasing") fst (List.tl is) in
- true)
- else if lst < fst then
- (let _ = List.fold_left
- (fun i1 i2 -> if i1 > i2 then i2
- else typ_error l "Indexed vector pattern was inconsistently decreasing") fst (List.tl is) in
- false)
- else typ_error l "Indexed vector cannot be determined as either increasing or decreasing" in
- let base,rise = new_n (), new_n () in
- let ts = List.map (fun (_,pat) -> check_pat concrete_length_req item_t pat) ipats in
- let co = Patt l in
- let (u,cs) = List.fold_right (fun u (t,cs) -> type_consistent co d_env Require true u t) ts (item_t,[]) in
- {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);
- (TA_ord{order=(if inc_or_dec then Oinc else Odec)});(TA_typ u)])}
- | P_tup(pats) ->
- let item_ts = match expect_actual.t with
- | Ttup ts ->
- if (List.length ts) = (List.length pats)
- then ts
- else typ_error l ("Expected a pattern with a tuple with " ^
- (string_of_int (List.length ts)) ^ " elements, found one with " ^
- (string_of_int (List.length pats)))
- | Tuvar _ -> List.map (fun _ -> new_t ()) pats
- | _ -> typ_error l ("Expected a tuple by pattern form, but a " ^ (t_to_string expect_actual) ^ " by type") in
- let ts = List.map (fun (pat,t) -> check_pat false t pat) (List.combine pats item_ts) in
- {t = Ttup ts}
- | P_vector_concat pats ->
- let item_t,base,rise,order =
- match expect_t.t with
- | Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])
- | Tabbrev(_,{t=Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])}) -> item,b,r,o
- | _ -> new_t (),new_n (), new_n (), d_env.default_o in
- let vec_ti _ = {t= Tapp("vector",[TA_nexp (new_n ());TA_nexp (new_n ());TA_ord order;TA_typ item_t])} in
- let _ =
- let rec walk = function
- | [] -> []
- | [p] ->
- [check_pat concrete_length_req (*use enclosing pattern status in case of nested concats*) (vec_ti ()) p]
- | p::ps -> (check_pat true (vec_ti ()) p)::(walk ps) in
- walk pats in
- {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);(TA_ord order);(TA_typ item_t)])}
- | P_list(pats) ->
- let item_t = match expect_actual.t with
- | Tapp("list",[TA_typ i]) -> i
- | Tuvar _ -> new_t ()
- | _ -> typ_error l ("Expected a list here by pattern form, but expected a " ^ t_to_string expect_actual ^ " by type") in
- let ts = List.map (check_pat false item_t) pats in
- let u = List.fold_right (fun u t -> let t',_ = type_consistent (Patt l) d_env Require true u t in t') ts item_t in
- {t = Tapp("list",[TA_typ u])}
-
-let simp_exp e l t = E_aux(e,(l,simple_annot t))
-
-(*widen lets outer expressions control whether inner expressions should widen in the presence of literals or not.
- also controls whether we consider vector base to be unconstrained or constrained
- This is relevent largely for vector accesses and sub ranges,
- where if there's a constant we really want to look at that constant,
- and if there's a known vector base, we want to use that directly, vs assignments or branching values *)
-let rec check_exp envs (imp_param:nexp option) (widen_num:bool) (widen_vec:bool)
- (ret_t:t) (expect_t:t) (E_aux(e,(l,annot)):tannot exp)
- : (tannot exp * t * tannot emap * nexp_range list * bounds_env * effect) =
- let Env(d_env,t_env,b_env,tp_env) = envs in
- let expect_t,_ = get_abbrev d_env expect_t in
- let expect_t_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in
- let ret_t,_ = get_abbrev d_env ret_t in
- let rebuild annot = E_aux(e,(l,annot)) in
- match e with
- | E_block exps ->
- let (exps',annot',sc,t,ef) = check_block envs imp_param ret_t expect_t exps in
- (E_aux(E_block(exps'),(l,annot')),t,Envmap.empty,sc,nob,ef)
- | E_nondet exps ->
- let base_ef = add_effect (BE_aux(BE_nondet,l)) pure_e in
- let (ces, sc, ef) =
- List.fold_right
- (fun e (es,sc,ef) ->
- let (e,_,_,sc',_,ef') = (check_exp envs imp_param true true ret_t unit_t e) in
- (e::es,sc@sc',union_effects ef ef')) exps ([],[],base_ef) in
- let _,_ = type_consistent (Expr l) d_env Require false unit_t expect_t in
- (E_aux (E_nondet ces,(l,cons_efs_annot unit_t sc base_ef ef)),unit_t,t_env,sc,nob,ef)
- | E_id id ->
- let i = id_to_string id in
- (match Envmap.apply t_env i with
- | Some(Base((params,t),(Constructor n),cs,ef,_,bounds)) ->
- let t,cs,ef,_ = subst params false false t cs ef in
- (match t.t with
- | Tfn({t = Tid "unit"},t',IP_none,ef) ->
- let e = E_aux(E_app(id, []),
- (l, (Base(([],{t=Tfn(unit_t,t',IP_none,ef)}), (Constructor n), cs, ef,pure_e, bounds)))) in
- let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t' e expect_t in
- (e',t',t_env,cs@cs',nob,union_effects ef ef')
- | Tfn(t1,t',IP_none,e) ->
- typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none")
- | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type"))
- | Some(Base((params,t),(Enum max),cs,ef,_,bounds)) ->
- let t',cs,_,_ = subst params false false t cs ef in
- let t',cs',ef',e' =
- type_coerce (Expr l) d_env Require false false b_env t'
- (rebuild (cons_tag_annot t' (Enum max) cs)) expect_t in
- (e',t',t_env,cs@cs',nob,ef')
- | Some(Base(tp,Default,cs,ef,_,_)) | Some(Base(tp,Spec,cs,ef,_,_)) ->
- typ_error l ("Identifier " ^ i ^ " must be defined, not just specified, before use")
- | Some(Base((params,t),tag,cs,ef,_,bounds)) ->
- let ((t,cs,ef,_),is_alias) =
- match tag with | Emp_global | External _ -> (subst params false false t cs ef),false
- | Alias alias_inf -> (t,cs, add_effect (BE_aux(BE_rreg, Parse_ast.Unknown)) ef, Envmap.empty),true
- | _ -> (t,cs,ef,Envmap.empty),false
+ let type_unions = List.concat (List.map (fun (_, (_, tus)) -> tus) (Bindings.bindings env.variants)) in
+ List.exists (is_ctor id) type_unions
+
+ let get_typ_var kid env =
+ try KBindings.find kid env.typ_vars with
+ | Not_found -> typ_error (kid_loc kid) ("No kind identifier " ^ string_of_kid kid)
+
+ let get_typ_vars env = env.typ_vars
+
+ (* FIXME: Add an IdSet for builtin types *)
+ let bound_typ_id env id =
+ Bindings.mem id env.typ_synonyms
+ || Bindings.mem id env.variants
+ || Bindings.mem id env.records
+ || Bindings.mem id env.regtyps
+ || Bindings.mem id env.enums
+ || Id.compare id (mk_id "range") = 0
+ || Id.compare id (mk_id "vector") = 0
+ || Id.compare id (mk_id "register") = 0
+ || Id.compare id (mk_id "bit") = 0
+ || Id.compare id (mk_id "unit") = 0
+ || Id.compare id (mk_id "int") = 0
+ || Id.compare id (mk_id "nat") = 0
+ || Id.compare id (mk_id "bool") = 0
+ || Id.compare id (mk_id "real") = 0
+
+ (* Check if a type, order, or n-expression is well-formed. Throws a
+ type error if the type is badly formed. FIXME: Add arity to type
+ constructors, although arity checking for the builtin types does
+ seem to be done by the initial ast check. *)
+ let rec wf_typ env (Typ_aux (typ_aux, l)) =
+ match typ_aux with
+ | Typ_wild -> ()
+ | Typ_id id when bound_typ_id env id -> ()
+ | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id)
+ | Typ_var kid when KBindings.mem kid env.typ_vars -> ()
+ | Typ_var kid -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid)
+ | Typ_fn (typ_arg, typ_ret, effs) -> wf_typ env typ_arg; wf_typ env typ_ret
+ | Typ_tup typs -> List.iter (wf_typ env) typs
+ | Typ_app (id, args) when bound_typ_id env id -> List.iter (wf_typ_arg env) args
+ | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id)
+ and wf_typ_arg env (Typ_arg_aux (typ_arg_aux, _)) =
+ match typ_arg_aux with
+ | Typ_arg_nexp nexp -> wf_nexp env nexp
+ | Typ_arg_typ typ -> wf_typ env typ
+ | Typ_arg_order ord -> wf_order env ord
+ | Typ_arg_effect _ -> () (* Check: is this ever used? *)
+ and wf_nexp env (Nexp_aux (nexp_aux, l)) =
+ match nexp_aux with
+ | Nexp_id _ -> typ_error l "Unimplemented: Nexp_id"
+ | Nexp_var kid ->
+ begin
+ match get_typ_var kid env with
+ | BK_nat -> ()
+ | kind -> typ_error l ("Constraint is badly formed, "
+ ^ string_of_kid kid ^ " has kind "
+ ^ string_of_base_kind_aux kind ^ " but should have kind Nat")
+ end
+ | Nexp_constant _ -> ()
+ | Nexp_times (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
+ | Nexp_sum (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
+ | Nexp_minus (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
+ | Nexp_exp nexp -> wf_nexp env nexp (* MAYBE: Could put restrictions on what is allowed here *)
+ | Nexp_neg nexp -> wf_nexp env nexp
+ and wf_order env (Ord_aux (ord_aux, l)) =
+ match ord_aux with
+ | Ord_var kid ->
+ begin
+ match get_typ_var kid env with
+ | BK_order -> ()
+ | kind -> typ_error l ("Order is badly formed, "
+ ^ string_of_kid kid ^ " has kind "
+ ^ string_of_base_kind_aux kind ^ " but should have kind Order")
+ end
+ | Ord_inc | Ord_dec -> ()
+
+ let add_enum id ids env =
+ if bound_typ_id env id
+ then typ_error (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound")
+ else
+ begin
+ typ_print ("Adding enum " ^ string_of_id id);
+ { env with enums = Bindings.add id (IdSet.of_list ids) env.enums }
+ end
+
+ let get_enum id env =
+ try IdSet.elements (Bindings.find id env.enums)
+ with
+ | Not_found -> typ_error (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist")
+
+ let is_record id env = Bindings.mem id env.records
+
+ let add_record id typq fields env =
+ if bound_typ_id env id
+ then typ_error (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound")
+ else
+ begin
+ typ_print ("Adding record " ^ string_of_id id);
+ let fold_accessors accs (typ, fid) =
+ let acc_typ = mk_typ (Typ_fn (mk_id_typ id, typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in
+ typ_print (indent 1 ^ "Adding accessor " ^ string_of_id fid ^ " :: " ^ string_of_bind (typq, acc_typ));
+ Bindings.add fid (typq, acc_typ) accs
in
- let t,cs' = get_abbrev d_env t in
- let cs = cs@cs' in
- let t_actual = match t.t with
- | Tabbrev(_,t) -> t
- | _ -> t in
- (*let _ = Printf.eprintf "On general id check of %s, expect_t %s, t %s, tactual %s, expect_actual %s\n"
- (id_to_string id)
- (t_to_string expect_t) (t_to_string t) (t_to_string t_actual) (t_to_string expect_t_actual) in*)
- (match t_actual.t,expect_t_actual.t with
- | Tfn _,_ -> typ_error l
- ("Identifier " ^ (id_to_string id) ^ " is bound to a function and cannot be used as a value")
- | Tapp("register",[TA_typ(t')]),Tapp("register",[TA_typ(expect_t')]) ->
- let tannot = Base(([],t),(match tag with | External _ -> Emp_global | _ -> tag),
- cs,pure_e,pure_e,bounds) in
- let t',cs' = type_consistent (Expr l) d_env Require widen_vec t' expect_t' in
- (rebuild tannot,t,t_env,cs@cs',bounds,ef)
- | Tapp("register",[TA_typ(t')]),Tuvar _ ->
- (*let ef' = add_effect (BE_aux(BE_rreg,l)) ef in
- let tannot = Base(([],t),(if is_alias then tag else External (Some i)),cs,ef',ef',bounds) in*)
- let tannot = Base(([],t),
- (if is_alias then tag else (if tag = Emp_local then tag else Emp_global)),
- cs,pure_e,pure_e,bounds) in
- let _,cs',ef',e' =
- type_coerce (Expr l) d_env Require false widen_vec b_env t' (rebuild tannot) expect_t_actual in
- (e',t,t_env,cs@cs',bounds,ef')
- | Tapp("register",[TA_typ(t')]),_ ->
- let ef' = add_effect (BE_aux(BE_rreg,l)) ef in
- let tannot = Base(([],t),(if is_alias then tag else External (Some i)),cs,ef',ef',bounds) in
- let t',cs',_,e' =
- type_coerce (Expr l) d_env Require false widen_vec b_env t' (rebuild tannot) expect_t_actual in
- (e',t',t_env,cs@cs',bounds,ef')
- | Tapp("reg",[TA_typ(t')]),_ ->
- let tannot = cons_bs_annot t cs bounds in
- let t',cs',_,e' =
- type_coerce (Expr l) d_env Require false widen_num b_env t' (rebuild tannot) expect_t_actual in
- (e',t',t_env,cs@cs',bounds,pure_e)
- | _ ->
- let t',cs',ef',e' = type_coerce (Expr l) d_env Require false widen_num b_env
- t (rebuild (Base(([],t),tag,cs,pure_e,ef,bounds))) expect_t in
- (e',t',t_env,cs@cs',bounds,union_effects ef ef')
- )
- | Some NoTyp | Some Overload _ | None -> typ_error l ("Identifier " ^ (id_to_string id) ^ " is unbound"))
- | E_lit (L_aux(lit,l')) ->
- let e,cs,effect = (match lit with
- | L_unit -> (rebuild (simple_annot unit_t)),[],pure_e
- | L_zero ->
- (match expect_t_actual.t with
- | Tid "bool" -> simp_exp (E_lit(L_aux(L_zero,l'))) l bool_t,[],pure_e
- | _ -> simp_exp e l bit_t,[],pure_e)
- | L_one ->
- (match expect_t_actual.t with
- | Tid "bool" -> simp_exp (E_lit(L_aux(L_one,l'))) l bool_t,[],pure_e
- | _ -> simp_exp e l bit_t,[],pure_e)
- | L_true -> simp_exp e l bool_t,[],pure_e
- | L_false -> simp_exp e l bool_t,[],pure_e
- | L_num i ->
- (*let _ = Printf.eprintf "expected type of number literal %i is %s\n" i (t_to_string expect_t_actual) in*)
- (match expect_t_actual.t with
- | Tid "bit" | Toptions({t=Tid"bit"},_) ->
- if i = 0 then simp_exp (E_lit(L_aux(L_zero,l'))) l bit_t,[],pure_e
- else if i = 1 then simp_exp (E_lit(L_aux(L_one,l'))) l bit_t,[],pure_e
- else typ_error l ("Expected a bit, found " ^ string_of_int i)
- | Tid "bool" | Toptions({t=Tid"bool"},_)->
- if i = 0 then simp_exp (E_lit(L_aux(L_zero,l'))) l bit_t,[],pure_e
- else if i = 1 then simp_exp (E_lit(L_aux(L_one,l'))) l bit_t ,[],pure_e
- else typ_error l ("Expected bool or a bit, found " ^ string_of_int i)
- | Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})]) ->
- let n = mk_c_int i in
- let t = {t=Tapp("atom", [TA_nexp n;])} in
- let cs = [LtEq(Expr l,Guarantee,n,mk_sub (mk_2n rise) n_one)] in
- let f = match o.order with | Oinc -> "to_vec_inc" | Odec -> "to_vec_dec" | _ -> "to_vec_inc" in
- (*let _ = Printf.eprintf "adding a call to to_vec_*: bounds are %s\n" (bounds_to_string b_env) in*)
- let internal_tannot = (l,(cons_bs_annot {t = Tapp("implicit",[TA_nexp rise])} [] b_env)) in
- let tannot = (l,cons_tag_annot expect_t (External (Some f)) cs) in
- E_aux(E_app((Id_aux((Id f),l)),
- [(E_aux (E_internal_exp(internal_tannot), tannot));simp_exp e l t]),tannot),cs,pure_e
- | _ -> simp_exp e l {t = Tapp("atom", [TA_nexp (mk_c_int i)])},[],pure_e)
- | L_hex s ->
- let size = (String.length s) * 4 in
- let start = match d_env.default_o.order with
- | Oinc -> n_zero | Odec -> mk_c_int (size - 1) | _ -> n_zero in
- simp_exp e l {t = Tapp("vector",
- [TA_nexp start;
- TA_nexp (mk_c_int size);
- TA_ord d_env.default_o;TA_typ{t = Tid "bit"}])},[],pure_e
- | L_bin s ->
- let size = String.length s in
- let start = match d_env.default_o.order with
- | Oinc -> n_zero | Odec -> mk_c_int (size -1) | _ -> n_zero in
- simp_exp e l {t = Tapp("vector",
- [TA_nexp start;
- TA_nexp (mk_c_int size);
- TA_ord d_env.default_o ;TA_typ{t = Tid"bit"}])},[],pure_e
- | L_string s -> simp_exp e l {t = Tid "string"},[],pure_e
- | L_undef ->
- let ef = {effect=Eset[BE_aux(BE_undef,l)]} in
- (match expect_t_actual.t with
- | Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})])
- | Toptions({t = Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})])}, None) ->
- let f = match o.order with | Oinc -> "to_vec_inc_undef" | Odec -> "to_vec_dec_undef"
- | _ -> (match d_env.default_o.order with
- | Oinc -> "to_vec_inc_undef" | Odec -> "to_vec_dec_undef"
- | _ -> "to_vec_inc_undef") in
- let _ = set_imp_param rise in
- let internal_tannot = (l,(cons_bs_annot {t = Tapp("implicit",[TA_nexp rise])} [] b_env)) in
- let tannot = (l,Base(([],{t = Tapp("vector",[TA_nexp base; TA_nexp rise; TA_ord o; TA_typ bit_t])}),
- External (Some f),[],ef,ef,b_env)) in
- E_aux(E_app((Id_aux((Id f),l)),
- [(E_aux (E_internal_exp(internal_tannot), tannot));]),tannot),[],ef
- | _ -> simp_exp e l (new_t ()),[],ef)) in
- let t',cs',_,e' = type_coerce (Expr l) d_env Require false widen_num b_env (get_e_typ e) e expect_t in
- (e',t',t_env,cs@cs',nob,effect)
- | E_cast(typ,e) ->
- let cast_t = typ_to_t envs false false typ in
- let cast_t,cs_a = get_abbrev d_env cast_t in
- let cast_t = typ_subst tp_env false cast_t in
- let ct = {t = Toptions(cast_t,None)} in
- let (e',u,t_env,cs,bounds,ef) = check_exp envs imp_param true true ret_t ct e in
- (*let _ = Printf.eprintf "Type checking cast: cast_t is %s constraints after checking e are %s\n"
- (t_to_string cast_t) (constraints_to_string cs) in*)
- let t',cs2,ef',e' = type_coerce (Expr l) d_env Require true true b_env u e' cast_t in
- (*let _ = Printf.eprintf "Type checking cast: after first coerce with u %s, t' %s is and constraints are %s\n"
- (t_to_string u) (t_to_string t') (constraints_to_string cs2) in*)
- let t',cs3,ef'',e'' = type_coerce (Expr l) d_env Guarantee false false b_env cast_t e' expect_t in
- (*let _ = Printf.eprintf "Type checking cast: after second coerce expect_t %s, t' %s and constraints are %s\n"
- (t_to_string expect_t) (t_to_string t') (constraints_to_string cs3) in*)
- (e'',t',t_env,cs_a@cs@cs2@cs3,bounds,union_effects ef' (union_effects ef'' ef))
- | E_app(id,parms) ->
- let i = id_to_string id in
- let check_parms p_typ parms = (match parms with
- | [] | [(E_aux (E_lit (L_aux (L_unit,_)),_))]
- -> let (_,cs') = type_consistent (Expr l) d_env Require false unit_t p_typ in [],unit_t,cs',pure_e
- | [parm] -> let (parm',arg_t,t_env,cs',_,ef_p) = check_exp envs imp_param true true ret_t p_typ parm
- in [parm'],arg_t,cs',ef_p
- | parms ->
- (match check_exp envs imp_param true true ret_t p_typ (E_aux (E_tuple parms,(l,NoTyp))) with
- | ((E_aux(E_tuple parms',tannot')),arg_t,t_env,cs',_,ef_p) -> parms',arg_t,cs',ef_p
- | _ ->
- raise (Reporting_basic.err_unreachable l
- "check_exp, given a tuple and a tuple type, didn't return a tuple")))
- in
- let coerce_parms arg_t parms expect_arg_t =
- (match parms with
- | [] | [(E_aux (E_lit (L_aux(L_unit, _)), _))] -> [],pure_e,[]
- | [parm] ->
- let _,cs,ef,parm' =
- type_coerce (Expr l) d_env Guarantee false false b_env arg_t parm expect_arg_t in [parm'],ef,cs
- | parms ->
- (match type_coerce (Expr l) d_env Guarantee false false b_env arg_t
- (E_aux (E_tuple parms,(l,NoTyp))) expect_arg_t with
- | (_,cs,ef,(E_aux(E_tuple parms',tannot'))) -> (parms',ef,cs)
- | _ ->
- raise (Reporting_basic.err_unreachable l "type coerce given tuple and tuple type returned non-tuple")))
- in
- let check_result ret imp tag cs ef efr parms =
- match (imp,imp_param) with
- | (IP_length n ,None) | (IP_user n,None) | (IP_start n,None) ->
- (*let _ = Printf.eprintf "app of %s implicit required, no imp_param %s\n!" i (n_to_string n) in*)
- let internal_exp =
- let _ = set_imp_param n in
- let implicit = {t= Tapp("implicit",[TA_nexp n])} in
- let annot_i = Base(([],implicit),Emp_local,[],pure_e,pure_e,b_env) in
- E_aux(E_internal_exp((l,annot_i)),(l,simple_annot nat_t)) in
- type_coerce (Expr l) d_env Require false true b_env ret
- (E_aux (E_app(id, internal_exp::parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t
- | (IP_length n ,Some ne) | (IP_user n,Some ne) | (IP_start n,Some ne) ->
- (*let _ = Printf.eprintf "app of %s implicit length or var required %s with imp_param %s\n"
- i (n_to_string n) (n_to_string ne) in
- let _ = Printf.eprintf "and expected type is %s and return type is %s\n"
- (t_to_string expect_t) (t_to_string ret) in*)
- let _ = set_imp_param n; set_imp_param ne in
- let internal_exp =
- let implicit_user = {t = Tapp("implicit",[TA_nexp ne])} in
- let implicit = {t= Tapp("implicit",[TA_nexp n])} in
- let annot_iu = Base(([],implicit_user),Emp_local,[],pure_e,pure_e,b_env)in
- let annot_i = Base(([],implicit),Emp_local,[],pure_e,pure_e,b_env) in
- E_aux (E_internal_exp_user((l, annot_iu),(l,annot_i)), (l,simple_annot nat_t))
- in
- type_coerce (Expr l) d_env Require false true b_env ret
- (E_aux (E_app(id,internal_exp::parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t
- | (IP_none,_) ->
- (*let _ = Printf.eprintf "no implicit: ret %s and expect_t %s\n"
- (t_to_string ret) (t_to_string expect_t) in*)
- type_coerce (Expr l) d_env Require false true b_env ret
- (E_aux (E_app(id, parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t
- in
- (match Envmap.apply t_env i with
- | Some(Base(tp,Enum _,_,_,_,_)) ->
- typ_error l ("Expected function with name " ^ i ^ " but found an enumeration identifier")
- | Some(Base(tp,Default,_,_,_,_)) ->
- typ_error l ("Function " ^ i ^ " must be specified, not just declared as a default, before use")
- | Some(Base((params,t),tag,cs,efl,_,bounds)) ->
- (*let _ = Printf.eprintf "Going to check func call %s with unsubstituted types %s and constraints %s \n"
- i (t_to_string t) (constraints_to_string cs) in*)
- let t,cs,efl,_ = subst params false false t cs efl in
- (match t.t with
- | Tfn(arg,ret,imp,efl') ->
- (*let _ = Printf.eprintf "Checking funcation call of %s\n" i in
- let _ = Printf.eprintf "Substituted types and constraints are %s and %s\n"
- (t_to_string t) (constraints_to_string cs) in*)
- let ret,_ = get_abbrev d_env ret in
- let parms,arg_t,cs_p,ef_p = check_parms arg parms in
- (*let _ = Printf.eprintf "Checked parms of %s\n" i in*)
- let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs efl' (union_effects efl' ef_p) parms in
- (*let _ = Printf.eprintf "Checked result of %s and constraints are %s\n"
- i (constraints_to_string cs_r) in*)
- (e',ret_t,t_env,cs@cs_p@cs_r, bounds,union_effects efl' (union_effects ef_p ef_r))
- | _ -> typ_error l
- ("Expected a function or constructor, found identifier " ^ i ^ " bound to type " ^
- (t_to_string t)))
- | Some(Overload(Base((params,t),tag,cs,efl,_,_),overload_return,variants)) ->
- let t_p,cs_p,ef_p,_ = subst params false false t cs efl in
- let args,arg_t,arg_cs,arg_ef =
- (match t_p.t with
- | Tfn(arg,ret,_,ef') -> check_parms arg parms
- | _ ->
- typ_error l ("Expected a function or constructor, found identifier " ^ i
- ^ " bound to type " ^ (t_to_string t))) in
- (match (select_overload_variant d_env true overload_return variants arg_t) with
- | [] -> typ_error l
- ("No function found with name " ^ i ^ " that expects parameters " ^ (t_to_string arg_t))
- | [Base((params,t),tag,cs,efl,_,bounds)] ->
- (match t.t with
- | Tfn(arg,ret,imp,ef') ->
- let ret,_ = get_abbrev d_env ret in
- let args',arg_ef',arg_cs' = coerce_parms arg_t args arg in
- let cummulative_effects = union_effects (union_effects arg_ef arg_ef') (union_effects ef' ef_p) in
- let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef' cummulative_effects args' in
- (e',ret_t,t_env,cs_p@arg_cs@arg_cs'@cs_r,nob,
- union_effects ef_r cummulative_effects)
- | _ -> raise (Reporting_basic.err_unreachable l "Overloaded variant not a function"))
- | variants' ->
- (match select_overload_variant d_env false true variants' expect_t with
- | [] ->
- typ_error l ("No function found with name " ^ i ^ ", expecting parameters " ^
- (t_to_string arg_t) ^ " and returning " ^ (t_to_string expect_t))
- | [Base((params,t),tag,cs,efl,_,bounds)] ->
- (match t.t with
- |Tfn(arg,ret,imp,ef') ->
- let ret,_ = get_abbrev d_env ret in
- let args',arg_ef',arg_cs' = coerce_parms arg_t args arg in
- let cummulative_effects = union_effects (union_effects arg_ef arg_ef') (union_effects ef' ef_p) in
- let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef' cummulative_effects args' in
- (e',ret_t,t_env,cs_p@arg_cs@arg_cs'@cs_r,nob,union_effects ef_r cummulative_effects)
- | _ -> raise (Reporting_basic.err_unreachable l "Overloaded variant not a function"))
- | _ ->
- typ_error l ("More than one definition of " ^ i ^ " found with type " ^
- (t_to_string arg_t) ^ " -> " ^ (t_to_string expect_t) ^ ". A cast may be required")))
- | _ -> typ_error l ("Unbound function " ^ i))
- | E_app_infix(lft,op,rht) ->
- let i = id_to_string op in
- let check_parms arg_t lft rht =
- match check_exp envs imp_param true true ret_t arg_t (E_aux(E_tuple [lft;rht],(l,NoTyp))) with
- | ((E_aux(E_tuple [lft';rht'],_)),arg_t,_,cs',_,ef') -> (lft',rht',arg_t,cs',ef')
- | _ ->
- raise (Reporting_basic.err_unreachable l "check exp given tuple and tuple type and returned non-tuple")
- in
- let check_result ret imp tag cs ef efr lft rht =
- match imp with
- | _ -> (*implicit isn't allowed at the moment on any infix functions *)
- type_coerce (Expr l) d_env Require false true b_env ret
- (E_aux (E_app_infix(lft,op,rht),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t
- in
- (match Envmap.apply t_env i with
- | Some(Base(tp,Enum _,cs,ef,_,b)) ->
- typ_error l ("Expected function with name " ^ i ^ " but found an enumeration identifier")
- | Some(Base(tp,Default,cs,ef,_,b)) ->
- typ_error l ("Function " ^ i ^ " must be defined, not just declared as default, before use")
- | Some(Base((params,t),tag,cs,ef,_,b)) ->
- let t,cs,ef,_ = subst params false false t cs ef in
- (match t.t with
- | Tfn(arg,ret,imp,ef) ->
- let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in
- let cummulative_effects = union_effects ef ef_p in
- let ret_t,cs_r',ef_r,e' = check_result ret imp tag cs ef cummulative_effects lft' rht' in
- (e',ret_t,t_env,cs@cs_p@cs_r',nob,union_effects ef_r cummulative_effects)
- | _ ->
- typ_error l ("Expected a function, found identifier " ^ i ^ " bound to type " ^ (t_to_string t)))
- | Some(Overload(Base((params,t),tag,cs,ef,_,_),overload_return,variants)) ->
- let t_p,cs_p,ef_p,_ = subst params false false t cs ef in
- let lft',rht',arg_t,arg_cs,arg_ef =
- (match t_p.t with
- | Tfn(arg,ret,_,ef') -> check_parms arg lft rht
- | _ -> typ_error l ("Expected a function, found identifier " ^ i ^ " bound to type " ^ (t_to_string t))) in
- (*let _ = Printf.eprintf "Looking for overloaded function %s, generic type is %s, arg_t is %s\n"
- i (t_to_string t_p) (t_to_string arg_t) in*)
- (match (select_overload_variant d_env true overload_return variants arg_t) with
- | [] ->
- typ_error l ("No function found with name " ^ i ^
- " that expects parameters " ^ (t_to_string arg_t))
- | [Base((params,t),tag,cs,ef,_,b)] ->
- (*let _ = Printf.eprintf "Selected an overloaded function for %s,
- variant with function type %s for actual type %s\n" i (t_to_string t) (t_to_string arg_t) in*)
- (match t.t with
- | Tfn(arg,ret,imp,ef') ->
- (match arg.t,arg_t.t with
- | Ttup([tlft;trght]),Ttup([tlft_t;trght_t]) ->
- let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in
- let cummulative_effects = union_effects ef' (union_effects arg_ef ef_p) in
- let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef cummulative_effects lft' rht' in
- (e',ret_t,t_env,cs_p@arg_cs@cs@cs_r,nob, union_effects ef_r cummulative_effects)
- |_ -> raise (Reporting_basic.err_unreachable l "function no longer has tuple type"))
- | _ -> raise (Reporting_basic.err_unreachable l "overload variant does not have function"))
- | variants ->
- (*let _ = Printf.eprintf "Number of variants found before looking at return value %i\n%!"
- (List.length variants) in*)
- (match (select_overload_variant d_env false true variants expect_t) with
- | [] ->
- typ_error l ("No matching function found with name " ^ i ^ " that expects parameters " ^
- (t_to_string arg_t) ^ " returning " ^ (t_to_string expect_t))
- | [Base((params,t),tag,cs,ef,_,b)] ->
- (*let _ = Printf.eprintf "Selected an overloaded function for %s,
- variant with function type %s for actual type %s\n" i (t_to_string t) (t_to_string arg_t) in*)
- (match t.t with
- | Tfn(arg,ret,imp,ef') ->
- (match arg.t,arg_t.t with
- | Ttup([tlft;trght]),Ttup([tlft_t;trght_t]) ->
- let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in
- let cummulative_effects = union_effects ef' (union_effects ef_p arg_ef) in
- let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef cummulative_effects lft' rht' in
- (e',ret_t,t_env,cs_p@arg_cs@cs@cs_r,nob, union_effects ef_r cummulative_effects)
- |_ -> raise (Reporting_basic.err_unreachable l "function no longer has tuple type"))
- | _ -> raise (Reporting_basic.err_unreachable l "overload variant does not have function"))
- | _ ->
- typ_error l ("More than one variant of " ^ i ^ " found with type "
- ^ (t_to_string arg_t) ^ " -> " ^ (t_to_string expect_t) ^ ". A cast may be required")))
- | _ -> typ_error l ("Unbound infix function " ^ i))
- | E_tuple(exps) ->
- (match expect_t_actual.t with
- | Ttup ts ->
- let tl = List.length ts in
- let el = List.length exps in
- if tl = el then
- let exps,typs,consts,effect =
- List.fold_right2
- (fun e t (exps,typs,consts,effect) ->
- let (e',t',_,c,_,ef) =
- check_exp envs imp_param true true ret_t t e in
- ((e'::exps),(t'::typs),c@consts,union_effects ef effect))
- exps ts ([],[],[],pure_e) in
- let t = {t = Ttup typs} in
- (E_aux(E_tuple(exps),(l,simple_annot_efr t effect)),t,t_env,consts,nob,effect)
- else typ_error l ("Expected a tuple with " ^ (string_of_int tl) ^
- " arguments; found one with " ^ (string_of_int el))
- | _ ->
- let exps,typs,consts,effect =
- List.fold_right
- (fun e (exps,typs,consts,effect) ->
- let (e',t,_,c,_,ef) = check_exp envs imp_param true true ret_t (new_t ()) e in
- ((e'::exps),(t::typs),c@consts,union_effects ef effect))
- exps ([],[],[],pure_e) in
- let t = { t=Ttup typs } in
- let t',cs',ef',e' =
- type_coerce (Expr l) d_env Guarantee false false b_env
- t (E_aux(E_tuple(exps),(l,simple_annot_efr t effect))) expect_t in
- (e',t',t_env,consts@cs',nob,union_effects ef' effect))
- | E_if(cond,then_,else_) ->
- let (cond',_,_,c1,_,ef1) = check_exp envs imp_param true true ret_t bit_t cond in
- let (c1,c1p,c1n) = split_conditional_constraints c1 in
- (match expect_t.t with
- | Tuvar _ ->
- let then',then_t,then_env,then_c,then_bs,then_ef =
- check_exp envs imp_param true true ret_t (new_t ()) then_ in
- let else',else_t,else_env,else_c,else_bs,else_ef =
- check_exp envs imp_param true true ret_t (new_t ()) else_ in
- (*TOTHINK Possibly I should first consistency check else and then, with Guarantee,
- then check against expect_t with Require*)
- let then_t',then_c' = type_consistent (Expr l) d_env Require true then_t expect_t in
- let else_t',else_c' = type_consistent (Expr l) d_env Require true else_t expect_t in
- let t_cs = CondCons((Expr l),Positive,None,c1p,then_c@then_c') in
- let e_cs = CondCons((Expr l),Negative,None,c1n,else_c@else_c') in
- let sub_effects = union_effects ef1 (union_effects then_ef else_ef) in
- let resulting_env = Envmap.intersect_merge (tannot_merge (Expr l) d_env true) then_env else_env in
- (E_aux(E_if(cond',then',else'),(l,simple_annot_efr expect_t sub_effects)),
- expect_t, resulting_env,
- c1@[BranchCons(Expr l, None, [t_cs;e_cs])],
- merge_bounds then_bs else_bs, (*TODO Should be an intersecting merge*)
- sub_effects)
- | _ ->
- let then',then_t,then_env,then_c,then_bs,then_ef = check_exp envs imp_param true true ret_t expect_t then_ in
- let else',else_t,else_env,else_c,else_bs,else_ef = check_exp envs imp_param true true ret_t expect_t else_ in
- let t_cs = CondCons((Expr l),Positive,None,c1,then_c) in
- let e_cs = CondCons((Expr l),Negative,None,[],else_c) in
- let sub_effects = union_effects ef1 (union_effects then_ef else_ef) in
- (E_aux(E_if(cond',then',else'),(l,simple_annot_efr expect_t sub_effects)),
- expect_t,Envmap.intersect_merge (tannot_merge (Expr l) d_env true) then_env else_env,
- c1@[BranchCons(Expr l, None, [t_cs;e_cs])],
- merge_bounds then_bs else_bs,
- sub_effects))
- | E_for(id,from,to_,step,order,block) ->
- (*TOTHINK Instead of making up new ns here, perhaps I should instead make sure they conform to range
- without coercion as these nu variables are likely floating*)
- let f,t,s = new_n(),new_n(),new_n() in
- let ft,tt,st = mk_atom f, mk_atom t, mk_atom s in
- let from',from_t,_,from_c,_,from_ef = check_exp envs imp_param false false ret_t ft from in
- let to_',to_t,_,to_c,_,to_ef = check_exp envs imp_param false false ret_t tt to_ in
- let step',step_t,_,step_c,_,step_ef = check_exp envs imp_param false false ret_t st step in
- let new_annot,local_cs =
- match (aorder_to_ord order).order with
- | Oinc ->
- (simple_annot {t=Tapp("range",[TA_nexp f;TA_nexp t])},[LtEq((Expr l),Guarantee ,f,t)])
- | Odec ->
- (simple_annot {t=Tapp("range",[TA_nexp t; TA_nexp f])},[GtEq((Expr l),Guarantee,f,t)])
- | _ -> (typ_error l "Order specification in a foreach loop must be either inc or dec, not polymorphic")
- in
- (*TODO Might want to extend bounds here for the introduced variable*)
- let (block',b_t,_,b_c,_,b_ef)=
- check_exp (Env(d_env,Envmap.insert t_env (id_to_string id,new_annot),b_env,tp_env))
- imp_param true true ret_t expect_t block
- in
- let sub_effects = union_effects b_ef (union_effects step_ef (union_effects to_ef from_ef)) in
- (E_aux(E_for(id,from',to_',step',order,block'),(l,constrained_annot_efr b_t local_cs sub_effects)),expect_t,
- Envmap.empty,
- b_c@from_c@to_c@step_c@local_cs,nob,sub_effects)
- | E_vector(es) ->
- let item_t,ord = match expect_t_actual.t with
- | Tapp("vector",[base;rise;TA_ord ord;TA_typ item_t]) -> item_t,ord
- | _ -> new_t (),d_env.default_o in
- let es,cs,effect,item_t = (List.fold_right
- (fun (e,t,_,c,_,ef) (es,cs,effect,_) -> (e::es),(c@cs),union_effects ef effect,t)
- (List.map (check_exp envs imp_param true true ret_t item_t) es) ([],[],pure_e,item_t)) in
- let len = List.length es in
- let t = match ord.order,d_env.default_o.order with
- | (Oinc,_) | (Ouvar _,Oinc) | (Ovar _,Oinc) ->
- {t = Tapp("vector", [TA_nexp n_zero; TA_nexp (mk_c_int len);
- TA_ord {order = Oinc}; TA_typ item_t])}
- | (Odec,_) | (Ouvar _,Odec) | (Ovar _,Odec) ->
- {t = Tapp("vector",[TA_nexp (mk_c_int (len-1));
- TA_nexp (mk_c_int len);
- TA_ord {order= Odec}; TA_typ item_t])}
- | _ -> raise (Reporting_basic.err_unreachable l "Default order was neither inc or dec") in
- let t',cs',ef',e' = type_coerce (Expr l) d_env Guarantee false true b_env t
- (E_aux(E_vector es,(l,simple_annot_efr t effect))) expect_t in
- (e',t',t_env,cs@cs',nob,union_effects effect ef')
- | E_vector_indexed(eis,(Def_val_aux(default,(ld,annot)))) ->
- let item_t,base_n,rise_n = match expect_t_actual.t with
- | Tapp("vector",[TA_nexp base;TA_nexp rise;ord;TA_typ item_t]) -> item_t,base,rise
- | _ -> new_t (),new_n (), new_n () in
- let first,last = fst (List.hd eis), fst (List.hd (List.rev eis)) in
- let is_inc = first <= last in
- let es,cs,effect,contains_skip,_ =
- (List.fold_right
- (fun ((i,e),c,ef) (es,cs,effect,skips,prev) ->
- (*let _ = Printf.eprintf "Checking increasing %b %i %i\n" is_increasing prev i in*)
- let (esn, csn, efn) = (((i,e)::es), (c@cs), union_effects ef effect) in
- if (is_inc && prev > i)
- then (esn,csn,efn,(((prev-i) > 1) || skips),i)
- else if prev < i
- then (esn,csn,efn,(((i-prev) > 1) || skips),i)
- else if i = prev
- then (typ_error l ("Indexed vector contains a duplicate definition of index " ^ (string_of_int i)))
- else (typ_error l ("Indexed vector is not consistently " ^
- (if is_inc then "increasing" else "decreasing"))))
- (List.map (fun (i,e) ->
- let (e,_,_,cs,_,eft) = (check_exp envs imp_param true true ret_t item_t e) in ((i,e),cs,eft))
- eis) ([],[],pure_e,false,(if is_inc then (last+1) else (last-1)))) in
- let (default',fully_enumerate,cs_d,ef_d) = match (default,contains_skip) with
- | (Def_val_empty,false) -> (Def_val_aux(Def_val_empty,(ld,simple_annot item_t)),true,[],pure_e)
- | (Def_val_empty,true) ->
- let ef = add_effect (BE_aux(BE_unspec,l)) pure_e in
- let de = E_aux(E_lit (L_aux(L_undef,l)), (l,simple_annot item_t)) in
- (Def_val_aux(Def_val_dec de, (l, cons_efs_annot item_t [] ef ef)),false,[],ef)
- | (Def_val_dec e,_) -> let (de,t,_,cs_d,_,ef_d) = (check_exp envs imp_param true true ret_t item_t e) in
- (*Check that ef_d doesn't write to memory or registers? *)
- (Def_val_aux(Def_val_dec de,(ld,cons_efs_annot item_t cs_d pure_e ef_d)),false,cs_d,ef_d) in
- let (base_bound,length_bound,cs_bounds) =
- if fully_enumerate
- then (mk_c_int first, mk_c_int (List.length eis),[])
- else (base_n,rise_n,[LtEq(Expr l,Require, base_n,mk_c_int first);
- GtEq(Expr l,Require, rise_n,mk_c_int (List.length eis))])
- in
- let t = {t = Tapp("vector",
- [TA_nexp(base_bound);TA_nexp length_bound;
- TA_ord({order= if is_inc then Oinc else Odec});TA_typ item_t])} in
- let sub_effects = union_effects ef_d effect in
- let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t
- (E_aux (E_vector_indexed(es,default'),(l,simple_annot_efr t sub_effects))) expect_t in
- (e',t',t_env,cs@cs_d@cs_bounds@cs',nob,union_effects ef' sub_effects)
- | E_vector_access(vec,i) ->
- let base,len,ord = new_n(),new_n(),new_o() in
- let item_t = new_t () in
- let index = new_n () in
- let vt = {t= Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord ord; TA_typ item_t])} in
- let (vec',t',cs,ef),va_lef,tag = recheck_for_register envs imp_param false false ret_t vt vec in
- let it = mk_atom index in
- let (i',ti',_,cs_i,_,ef_i) = check_exp envs imp_param false false ret_t it i in
- let ord,item_t = match t'.t with
- | Tabbrev(_,{t=Tapp("vector",[_;_;TA_ord ord;TA_typ t])}) | Tapp("vector",[_;_;TA_ord ord;TA_typ t])
- | Tabbrev(_,{t=Tapp("register",[TA_typ{t=Tapp ("vector",[_;_;TA_ord ord;TA_typ t])}])})
- | Tapp("register", [TA_typ{t=Tapp ("vector",[_;_;TA_ord ord;TA_typ t])}]) -> ord,t
- | _ -> ord,item_t in
- let oinc_max_access = mk_sub (mk_add base len) n_one in
- let odec_min_access = mk_add (mk_sub base len) n_one in
- let cs_loc =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) ->
- [LtEq((Expr l),Require,base,index);LtEq((Expr l),Require, index,oinc_max_access);]
- | (Odec,_) ->
- [GtEq((Expr l),Require,base,index); GtEq((Expr l),Require,index,odec_min_access);]
- | (_,Oinc) ->
- [LtEq((Expr l),Require,base,index);LtEq((Expr l),Require, index,oinc_max_access);]
- | (_,Odec) ->
- [GtEq((Expr l),Require,base,index); GtEq((Expr l),Require,index,odec_min_access);]
- | _ -> typ_error l "A vector must be either increasing or decreasing to access a single element"
- in
- (*let _ = Printf.eprintf "Type checking vector access. item_t is %s and expect_t is %s\n"
- (t_to_string item_t) (t_to_string expect_t) in*)
- let sub_effects = union_effects (union_effects va_lef ef) ef_i in
- let t',cs',ef',e'=type_coerce (Expr l) d_env Require false true b_env item_t
- (E_aux(E_vector_access(vec',i'),(l,tag_efs_annot item_t tag va_lef sub_effects))) expect_t in
- (e',t',t_env,cs_loc@cs_i@cs@cs',nob,union_effects ef' sub_effects)
- | E_vector_subrange(vec,i1,i2) ->
- (*let _ = Printf.eprintf "checking e_vector_subrange: expect_t is %s\n" (t_to_string expect_t) in*)
- let base,length,ord = new_n(),new_n(),new_o() in
- let new_length = new_n() in
- let n1_start = new_n() in
- let n2_end = new_n() in
- let item_t = match expect_t_actual.t with
- | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t
- | _ -> new_t() in
- let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp length;TA_ord ord;TA_typ item_t])} in
- let (vec',vt',cs,ef),v_efs,tag = recheck_for_register envs imp_param false false ret_t vt vec in
- let i1t = {t=Tapp("atom",[TA_nexp n1_start])} in
- let (i1', ti1, _,cs_i1,_,ef_i1) = check_exp envs imp_param false false ret_t i1t i1 in
- let i2t = {t=Tapp("atom",[TA_nexp n2_end])} in
- let (i2', ti2, _,cs_i2,_,ef_i2) = check_exp envs imp_param false false ret_t i2t i2 in
- let cs_loc =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) ->
- [LtEq((Expr l), Require, base, n1_start);
- LtEq((Expr l), Require, n1_start, n2_end);
- LtEq((Expr l), Require, n2_end, mk_sub (mk_add base length) n_one);
- Eq((Expr l), new_length, mk_add (mk_sub n2_end n1_start) n_one)]
- | (Odec,_) ->
- [GtEq((Expr l), Require, base, n1_start);
- GtEq((Expr l), Require, n1_start, n2_end);
- GtEq((Expr l), Require, n2_end, mk_add (mk_sub base length) n_one);
- Eq((Expr l), new_length, mk_add (mk_sub n1_start n2_end) n_one)]
- | (_,Oinc) ->
- [LtEq((Expr l), Require, base, n1_start);
- LtEq((Expr l), Require, n1_start, n2_end);
- LtEq((Expr l), Require, n2_end, mk_sub (mk_add base length) n_one);
- Eq((Expr l), new_length, mk_add (mk_sub n2_end n1_start) n_one)]
- | (_,Odec) ->
- [GtEq((Expr l), Require, base, n1_start);
- GtEq((Expr l), Require, n1_start, n2_end);
- GtEq((Expr l), Require, n2_end, mk_add (mk_sub base length) n_one);
- Eq((Expr l), new_length, mk_add (mk_sub n1_start n2_end) n_one)]
- | _ -> typ_error l "A vector must be either increasing or decreasing to access a slice" in
- let nt = {t = Tapp("vector", [TA_nexp n1_start; TA_nexp new_length; TA_ord ord; TA_typ item_t]) } in
- let sub_effects = union_effects v_efs (union_effects ef (union_effects ef_i1 ef_i2)) in
- let (t,cs3,ef3,e') =
- type_coerce (Expr l) d_env Require false true b_env nt
- (E_aux(E_vector_subrange(vec',i1',i2'),(l,Base(([], nt),tag, cs_loc,v_efs, sub_effects,nob)))) expect_t in
- (e',t,t_env,cs3@cs@cs_i1@cs_i2@cs_loc,nob,union_effects ef3 sub_effects)
- | E_vector_update(vec,i,e) ->
- let base,rise,ord = new_n(),new_n(),new_o() in
- let min,m_rise = new_n(),new_n() in
- let item_t = match expect_t_actual.t with
- | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t
- | _ -> new_t() in
- let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t])} in
- let (vec',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t vt vec in
- let it = {t=Tapp("range",[TA_nexp min;TA_nexp m_rise])} in
- let (i', ti, _,cs_i,_,ef_i) = check_exp envs imp_param false false ret_t it i in
- let (e', te, _,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t item_t e in
- let cs_loc =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) ->
- [LtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_add base rise)]
- | (Odec,_) ->
- [GtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_sub base rise)]
- | (_,Oinc) ->
- [LtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise, mk_add base rise)]
- | (_,Odec) ->
- [GtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_sub base rise)]
- | _ -> typ_error l "A vector must be either increasing or decreasing to change a single element"
- in
- let nt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise; TA_ord ord;TA_typ item_t])} in
- let sub_effects = union_effects ef (union_effects ef_i ef_e) in
- let (t,cs3,ef3,e') =
- type_coerce (Expr l) d_env Require false false b_env nt
- (E_aux(E_vector_update(vec',i',e'),(l,constrained_annot_efr nt cs_loc sub_effects))) expect_t in
- (e',t,t_env,cs3@cs@cs_i@cs_e@cs_loc,nob,(union_effects ef3 sub_effects))
- | E_vector_update_subrange(vec,i1,i2,e) ->
- let base,rise,ord = new_n(),new_n(),new_o() in
- let min1,m_rise1 = new_n(),new_n() in
- let min2,m_rise2 = new_n(),new_n() in
- let item_t = match expect_t_actual.t with
- | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t
- | _ -> new_t() in
- let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t])} in
- let (vec',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t vt vec in
- let i1t = {t=Tapp("range",[TA_nexp min1;TA_nexp m_rise1])} in
- let (i1', ti1, _,cs_i1,_,ef_i1) = check_exp envs imp_param false false ret_t i1t i1 in
- let i2t = {t=Tapp("range",[TA_nexp min2;TA_nexp m_rise2])} in
- let (i2', ti2, _,cs_i2,_,ef_i2) = check_exp envs imp_param false false ret_t i2t i2 in
- let (e',item_t',_,cs_e,_,ef_e) =
- try check_exp envs imp_param true true ret_t item_t e with
- | _ ->
- let (base_e,rise_e) = new_n(),new_n() in
- let (e',ti',env_e,cs_e,bs_e,ef_e) =
- check_exp envs imp_param true true ret_t
- {t=Tapp("vector",[TA_nexp base_e;TA_nexp rise_e;TA_ord ord;TA_typ item_t])} e
- in
- let cs_add = [Eq((Expr l),base_e,min1);LtEq((Expr l),Guarantee,rise,m_rise2)] in
- (e',ti',env_e,cs_e@cs_add,bs_e,ef_e) in
- let cs_loc =
- match (ord.order,d_env.default_o.order) with
- | (Oinc,_) ->
- [LtEq((Expr l),Require,base,min1); LtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2);
- LtEq((Expr l),Require,mk_add min2 m_rise2,mk_add base rise);]
- | (Odec,_) ->
- [GtEq((Expr l),Require,base,mk_add min1 m_rise1);
- GtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2);
- GtEq((Expr l),Require,mk_add min2 m_rise2,mk_sub base rise);]
- | (_,Oinc) ->
- [LtEq((Expr l),Require,base,min1); LtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2);
- LtEq((Expr l),Require,mk_add min2 m_rise2,mk_add base rise);]
- | (_,Odec) ->
- [GtEq((Expr l),Require,base,mk_add min1 m_rise1);
- GtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2);
- GtEq((Expr l),Require,mk_add min2 m_rise2,mk_sub base rise);]
- | _ -> typ_error l "A vector must be either increasing or decreasing to modify a slice" in
- let nt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise; TA_ord ord;TA_typ item_t])} in
- let sub_effects = union_effects ef (union_effects ef_i1 (union_effects ef_i2 ef_e)) in
- let (t,cs3,ef3,e') =
- type_coerce (Expr l) d_env Require false false b_env nt
- (E_aux(E_vector_update_subrange(vec',i1',i2',e'),
- (l,constrained_annot_efr nt cs_loc sub_effects))) expect_t in
- (e',t,t_env,cs3@cs@cs_i1@cs_i2@cs_loc@cs_e,nob,(union_effects ef3 sub_effects))
- | E_vector_append(v1,v2) ->
- let item_t,ord = match expect_t_actual.t with
- | Tapp("vector",[_;_;TA_ord o;TA_typ i]) -> i,o
- | Tapp("range",_) -> bit_t,new_o ()
- | Tapp("atom",_) -> bit_t, new_o ()
- | _ -> new_t (),new_o () in
- let base1,rise1 = new_n(), new_n() in
- let base2,rise2 = new_n(),new_n() in
- let (v1',t1',_,cs_1,_,ef_1) =
- check_exp envs imp_param true true ret_t
- {t=Tapp("vector",[TA_nexp base1;TA_nexp rise1;TA_ord ord;TA_typ item_t])} v1 in
- let (v2',t2',_,cs_2,_,ef_2) =
- check_exp envs imp_param true true ret_t
- {t=Tapp("vector",[TA_nexp base2;TA_nexp rise2;TA_ord ord;TA_typ item_t])} v2 in
- let result_rise = mk_add rise1 rise2 in
- let result_base = match ord.order with
- | Odec -> mk_sub result_rise n_one
- | _ -> n_zero in
- let ti = {t=Tapp("vector",[TA_nexp result_base;TA_nexp result_rise;TA_ord ord; TA_typ item_t])} in
- let sub_effects = union_effects ef_1 ef_2 in
- let (t,cs_c,ef_c,e') =
- type_coerce (Expr l) d_env Require false true b_env ti
- (E_aux(E_vector_append(v1',v2'),(l,simple_annot_efr ti sub_effects))) expect_t in
- (e',t,t_env,cs_1@cs_2@cs_c,nob,(union_effects ef_c sub_effects))
- | E_list(es) ->
- let item_t = match expect_t_actual.t with
- | Tapp("list",[TA_typ i]) -> i
- | _ -> new_t() in
- let es,cs,effect,item_t =
- (List.fold_left (fun (es,cs,effect,_) (e,t,_,c,_,ef) -> (e::es),(c@cs),union_effects ef effect,t)
- ([],[],pure_e,item_t) (List.map (check_exp envs imp_param true true ret_t item_t) es) ) in
- let t = {t = Tapp("list",[TA_typ item_t])} in
- let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t
- (E_aux(E_list es,(l,simple_annot_efr t effect))) expect_t in
- (e',t',t_env,cs@cs',nob,union_effects ef' effect)
- | E_cons(i, ls) ->
- let item_t = match expect_t_actual.t with
- | Tapp("list",[TA_typ i]) -> i
- | _ -> new_t() in
- let lt = {t=Tapp("list",[TA_typ item_t])} in
- let (ls',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t lt ls in
- let (i', ti, _,cs_i,_,ef_i) = check_exp envs imp_param true true ret_t item_t i in
- let sub_effects = union_effects ef ef_i in
- let (t',cs',ef',e') =
- type_coerce (Expr l) d_env Require false false b_env lt
- (E_aux(E_cons(i',ls'),(l,simple_annot_efr lt sub_effects))) expect_t in
- (e',t',t_env,cs@cs'@cs_i,nob,union_effects ef' sub_effects)
- | E_record(FES_aux(FES_Fexps(fexps,_),l')) ->
- let u,_ = get_abbrev d_env expect_t in
- let u_actual = match u.t with | Tabbrev(_, u) -> u | _ -> u in
- let field_walker r subst_env bounds tag n =
- (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) (fexps,cons,ef') ->
- let i = id_to_string id in
- match lookup_field_type i r with
- | None ->
- typ_error l ("Expected a struct of type " ^ n ^ ", which should not have a field " ^ i)
- | Some(ft) ->
- let ft = typ_subst subst_env false ft in
- let (e,t',_,c,_,ef) = check_exp envs imp_param true true ret_t ft exp in
- (FE_aux(FE_Fexp(id,e),(l,Base(([],t'),tag,c,ef,ef,bounds)))::fexps,cons@c,union_effects ef ef')) in
- (match u_actual.t with
- | Tid(n) | Tapp(n,_)->
- (match lookup_record_typ n d_env.rec_env with
- | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- if (List.length fexps = List.length fields)
- then let fexps,cons,ef =
- List.fold_right (field_walker r subst_env bounds tag n) fexps ([],[],pure_e) in
- let e = E_aux(E_record(FES_aux(FES_Fexps(fexps,false),l')),(l,simple_annot_efr u ef)) in
- let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in
- (e',t',t_env,cs@cons@cs',nob,union_effects ef ef')
- else typ_error l ("Expected a struct of type " ^ n ^ ", which should have " ^
- string_of_int (List.length fields) ^ " fields")
- | Some(i,Register,tannot,fields) -> typ_error l ("Expected a value with register type, found a struct")
- | _ -> typ_error l ("Expected a value of type " ^ n ^ " but found a struct"))
- | Tuvar _ ->
- let field_names = List.map (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) -> id_to_string id) fexps in
- (match lookup_record_fields field_names d_env.rec_env with
- | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in
- let e = E_aux(E_record(FES_aux(FES_Fexps(fexps,false),l')),(l,simple_annot_efr ts ef)) in
- let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in
- (e',t',t_env,cs@cons@cs',nob,union_effects ef ef')
- | Some(i,Register,tannot,fields) -> typ_error l "Expected a value with register type, found a struct"
- | _ -> typ_error l "No struct type matches the set of fields given")
- | _ -> typ_error l ("Expected an expression of type " ^ t_to_string expect_t ^ " but found a struct"))
- | E_record_update(exp,FES_aux(FES_Fexps(fexps,_),l')) ->
- let (e',t',_,c,_,ef) = check_exp envs imp_param true true ret_t expect_t exp in
- let field_walker r subst_env bounds tag i =
- (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) (fexps,cons,ef') ->
- let fi = id_to_string id in
- match lookup_field_type fi r with
- | None -> typ_error l ("Expected a struct with type " ^ i ^ ", which does not have a field " ^ fi)
- | Some ft ->
- let ft = typ_subst subst_env false ft in
- let (e,t',_,c,_,ef) = check_exp envs imp_param true true ret_t ft exp in
- (FE_aux(FE_Fexp(id,e),(l,Base(([],t'),tag,c,pure_e,ef,bounds)))::fexps,cons@c,union_effects ef ef')) in
- (match t'.t with
- | Tid i | Tabbrev(_, {t=Tid i}) | Tapp(i,_) ->
- (match lookup_record_typ i d_env.rec_env with
- | Some((i,Register,tannot,fields)) ->
- typ_error l "Expected a struct for this update, instead found a register"
- | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) ->
- if (List.length fexps <= List.length fields)
- then
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in
- let e = E_aux(E_record_update(e',FES_aux(FES_Fexps(fexps,false),l')), (l,simple_annot_efr ts ef)) in
- let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in
- (e',t',t_env,cs@cons@cs',nob,union_effects ef ef')
- else typ_error l ("Expected fields from struct " ^ i ^ ", given more fields than struct includes")
- | _ ->
- typ_error l ("Expected a struct or register, instead found an expression with type " ^ i))
- | Tuvar _ ->
- let field_names = List.map (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) -> id_to_string id) fexps in
- (match lookup_possible_records field_names d_env.rec_env with
- | [] -> typ_error l "No struct matches the set of fields given for this struct update"
- | [(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r))] ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in
- let e = E_aux(E_record_update(e',FES_aux(FES_Fexps(fexps,false),l')), (l,simple_annot_efr ts ef)) in
- let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in
- (e',t',t_env,cs@cons@cs',nob,union_effects ef ef')
- | [(i,Register,tannot,fields)] -> typ_error l "Expected a value with register type, found a struct"
- | records -> typ_error l "Multiple structs contain this set of fields, try adding a cast")
- | _ -> typ_error l ("Expected a struct to update but found an expression of type " ^ t_to_string expect_t))
- | E_field(exp,id) ->
- let (e',t',env_sub,c_sub,bounds,ef_sub) = check_exp envs imp_param true true ret_t (new_t()) exp in
- let fi = id_to_string id in
- (match t'.t with
- | Tabbrev({t=Tid i}, _) | Tabbrev({t=Tapp(i,_)},_) | Tid i | Tapp(i,_) ->
- (match lookup_record_typ i d_env.rec_env with
- | Some(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- (match lookup_field_type fi r with
- | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi)
- | Some t ->
- let ft = typ_subst subst_env false t in
- let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee true ts t' in
- let (e',t',_,c_sub,_,ef_sub),ef_update =
- match rec_kind with
- | Register ->
- (check_exp envs imp_param true true ret_t (into_register_typ t') exp,
- add_effect (BE_aux(BE_rreg, l)) pure_e)
- | Record -> ((e',t',env_sub,c_sub,bounds,ef_sub), pure_e) in
- let (et',c',ef',acc) =
- type_coerce (Expr l) d_env Require false true b_env ft
- (E_aux(E_field(e',id),
- (l,Base(([],ft),
- tag,cs,union_effects eft ef_update,union_effects ef_sub ef_update,bounds))))
- expect_t in
- (acc,et',t_env,cs@c'@c_sub@cs_sub',nob,union_effects ef' (union_effects ef_update ef_sub)))
- | _ ->
- typ_error l ("Expected a struct or register, instead found an expression with type " ^ i))
- | Tuvar _ ->
- (match lookup_possible_records [fi] d_env.rec_env with
- | [] -> typ_error l ("No struct or register has a field " ^ fi)
- | [(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r))] ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- (match lookup_field_type fi r with
- | None ->
- raise
- (Reporting_basic.err_unreachable l "lookup_possible_records returned a record without the field")
- | Some t ->
- let ft = typ_subst subst_env false t in
- let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee false ts t' in
- let (e',t',_,c_sub,_,ef_sub),ef_update =
- match rec_kind with
- | Register ->
- (check_exp envs imp_param true true ret_t (into_register_typ t') exp,
- add_effect (BE_aux(BE_rreg, l)) pure_e)
- | Record -> ((e',t',env_sub,c_sub,bounds,ef_sub), pure_e) in
- let (et',c',ef',acc) =
- type_coerce (Expr l) d_env Require false false b_env ft
- (E_aux(E_field(e',id),
- (l,Base(([],ft),tag,
- cs,union_effects eft ef_update,union_effects ef_sub ef_update,bounds)))) expect_t in
- (acc,et',t_env,cs@c'@c_sub@cs_sub',nob,union_effects ef' (union_effects ef_update ef_sub)))
- | records ->
- typ_error l ("Multiple structs or registers contain field " ^ fi ^ ", try adding a cast to disambiguate"))
- | _ -> typ_error l ("Expected a struct or register but found an expression of type " ^ t_to_string t'))
- | E_case(exp,pexps) ->
- let (e',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t (new_t()) exp in
- (*let _ = Printf.eprintf "Type of pattern after expression check %s\n" (t_to_string t') in*)
- let t' =
- match t'.t with
- | Tapp("register",[TA_typ t]) -> t
- | _ -> t' in
- (*let _ = Printf.eprintf "Type of pattern after register check %s\n" (t_to_string t') in*)
- let (pexps',t,cs',ef') =
- check_cases envs imp_param ret_t t' expect_t (if (List.length pexps) = 1 then Solo else Switch) pexps in
- let effects = union_effects ef ef' in
- (E_aux(E_case(e',pexps'),(l,simple_annot_efr expect_t effects)),t,
- t_env,cs@[BranchCons(Expr l, None, cs')],nob,effects)
- | E_let(lbind,body) ->
- let (lb',t_env',cs,b_env',ef) = (check_lbind envs imp_param false (Some ret_t) Emp_local lbind) in
- let new_env =
- (Env(d_env,Envmap.union_merge (tannot_merge (Expr l) d_env false)
- t_env t_env', merge_bounds b_env' b_env,tp_env))
- in
- let (e,t,_,cs',_,ef') = check_exp new_env imp_param true true ret_t expect_t body in
- let effects = union_effects ef ef' in
- (E_aux(E_let(lb',e),(l,simple_annot_efr t effects)),t,t_env,cs@cs',nob,effects)
- | E_assign(lexp,exp) ->
- let (lexp',t',_,t_env',tag,cs,b_env',efl,efr) = check_lexp envs imp_param ret_t true lexp in
- let t' = match t'.t with | Tapp("reg",[TA_typ t]) | Tapp("register",[TA_typ t])
- | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t
- | _ -> t' in
- let (exp',t'',_,cs',_,efr') = check_exp envs imp_param true true ret_t t' exp in
- let (t',c') = type_consistent (Expr l) d_env Require false unit_t expect_t in
- let effects = union_effects efl (union_effects efr efr') in
- (E_aux(E_assign(lexp',exp'),(l,(Base(([],unit_t),tag,[],efl,effects,nob)))),
- unit_t,t_env',cs@cs'@c',b_env',effects)
- | E_exit e ->
- let (e',t',_,_,_,_) = check_exp envs imp_param true true ret_t (new_t ()) e in
- let efs = add_effect (BE_aux(BE_escape, l)) pure_e in
- (E_aux (E_exit e',(l,(simple_annot_efr expect_t efs))),expect_t,t_env,[],nob,efs)
- | E_return e ->
- let (e', t'',_,cs,_,efr) = check_exp envs imp_param true true ret_t ret_t e in
- let ers = add_effect (BE_aux (BE_lret,l)) pure_e in
- (E_aux (E_return e', (l, (simple_annot_efr ret_t ers))), ret_t, t_env,cs,nob,union_effects efr ers)
- | E_sizeof nexp ->
- let n = anexp_to_nexp envs nexp in
- let n_subst = subst_n_with_env tp_env n in
- let n_typ = mk_atom n_subst in
- let nannot = bounds_annot n_typ b_env in
- let e = E_aux (E_sizeof_internal (l, nannot), (l,nannot)) in
- let t',cs,ef,e' = type_coerce (Expr l) d_env Require false false b_env n_typ e expect_t in
- (e',t',t_env,cs,nob,ef)
- | E_assert(cond,msg) ->
- let (cond',t',_,_,_,_) = check_exp envs imp_param true true ret_t bit_t cond in
- let (msg',mt',_,_,_,_) = check_exp envs imp_param true true ret_t {t= Tapp("option",[TA_typ string_t])} msg in
- let (t',c') = type_consistent (Expr l) d_env Require false unit_t expect_t in
- (E_aux (E_assert(cond',msg'), (l, (simple_annot expect_t))), expect_t,t_env,c',nob,pure_e)
- | E_comment s ->
- (E_aux (E_comment s, (l, simple_annot unit_t)), expect_t,t_env,[],nob,pure_e)
- | E_comment_struc e ->
- (E_aux (E_comment_struc e, (l, simple_annot unit_t)), expect_t,t_env,[],nob,pure_e)
- | E_internal_cast _ | E_internal_exp _ | E_internal_exp_user _ | E_internal_let _
- | E_internal_plet _ | E_internal_return _ | E_sizeof_internal _ ->
- raise (Reporting_basic.err_unreachable l "Internal expression passed back into type checker")
-
-and recheck_for_register envs imp_param widen_num widen_vec ret_t expect_t exp =
- match check_exp envs imp_param widen_num widen_vec ret_t expect_t exp with
- | exp',t',_,cs,_,ef ->
- match exp' with
- | E_aux(_, (l, Base(_, _, _, leff, ceff, _))) ->
- if has_rreg_effect ceff
- then try let (exp',t',_,cs,_,ef) =
- check_exp envs imp_param widen_num widen_vec ret_t (into_register_typ t') exp in
- (exp',t',cs,ef),(add_effect (BE_aux(BE_rreg,l)) pure_e),External None
- with | _ -> (exp',t',cs,ef),pure_e, Emp_local
- else (exp',t',cs,ef),pure_e, Emp_local
- | _ -> (exp',t',cs,ef),pure_e, Emp_local
-
-and check_block envs imp_param ret_t expect_t exps:((tannot exp) list * tannot * nexp_range list * t * effect) =
- let Env(d_env,t_env,b_env,tp_env) = envs in
- match exps with
- | [] -> ([],NoTyp,[],unit_t,pure_e)
- | [e] ->
- let (E_aux(e',(l,annot)),t,envs,sc,_,ef) = check_exp envs imp_param true true ret_t expect_t e in
- ([E_aux(e',(l,annot))],annot,sc,t,ef)
- | e::exps ->
- let (e',t',t_env',sc,b_env',ef') = check_exp envs imp_param true true ret_t unit_t e in
- let (exps',annot',sc',t,ef) =
- check_block (Env(d_env,
- Envmap.union_merge (tannot_merge (Expr Parse_ast.Unknown) d_env false) t_env t_env',
- merge_bounds b_env' b_env, tp_env)) imp_param ret_t expect_t exps in
- let annot' = match annot' with
- | Base(pt,tag,cs,efl,efr,bounds) -> Base(pt,tag,cs,efl,union_effects efr ef',bounds)
- | _ -> annot' in
- ((e'::exps'),annot',sc@sc',t,union_effects ef ef')
-
-and check_cases envs imp_param ret_t check_t expect_t kind pexps
- : ((tannot pexp) list * typ * nexp_range list * effect) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match pexps with
- | [] -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "switch with no cases found")
- | [(Pat_aux(Pat_exp(pat,exp),(l,annot)))] ->
- let pat',env,cs_p,bounds,u = check_pattern envs Emp_local check_t pat in
- let e,t,_,cs_e,_,ef =
- check_exp (Env(d_env,
- Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env env,
- merge_bounds b_env bounds, tp_env)) imp_param true true ret_t expect_t exp in
- let cs = [CondCons(Expr l,kind,None, cs_p, cs_e)] in
- [Pat_aux(Pat_exp(pat',e),(l,cons_efs_annot t cs pure_e ef))],t,cs,ef
- | ((Pat_aux(Pat_exp(pat,exp),(l,annot)))::pexps) ->
- let pat',env,cs_p,bounds,u = check_pattern envs Emp_local check_t pat in
- let (e,t,_,cs_e,_,ef) =
- check_exp (Env(d_env,
- Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env env,
- merge_bounds b_env bounds, tp_env)) imp_param true true ret_t expect_t exp in
- let cs = CondCons(Expr l,kind,None,cs_p,cs_e) in
- let (pes,tl,csl,efl) = check_cases envs imp_param ret_t check_t expect_t kind pexps in
- ((Pat_aux(Pat_exp(pat',e),(l,cons_efs_annot t [cs] pure_e ef)))::pes,tl,cs::csl,union_effects efl ef)
-
-and check_lexp envs imp_param ret_t is_top (LEXP_aux(lexp,(l,annot)))
- : (tannot lexp * typ * bool * tannot emap * tag * nexp_range list * bounds_env * effect * effect ) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match lexp with
- | LEXP_id id ->
- let i = id_to_string id in
- (match Envmap.apply t_env i with
- | Some(Base((parms,t),Default,_,_,_,_)) ->
- let t = {t=Tapp("reg",[TA_typ t])} in
- let bounds = extract_bounds d_env i t in
- let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in
- (LEXP_aux(lexp,(l,tannot)),t,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e)
- | Some(Base(([],t),Alias alias_inf,_,_,_,_)) ->
- let ef = {effect = Eset[BE_aux(BE_wreg,l)]} in
- (match Envmap.apply d_env.alias_env i with
- | Some(OneReg(reg, (Base(([],t'),_,_,_,_,_)))) ->
- (LEXP_aux(lexp,(l,(Base(([],t'),Alias alias_inf,[],ef,ef,nob)))), t, false,
- Envmap.empty, External (Some reg),[],nob,ef,ef)
- | Some(TwoReg(reg1,reg2, (Base(([],t'),_,_,_,_,_)))) ->
- let u = match t.t with
- | Tapp("register", [TA_typ u]) -> u
- | _ -> raise (Reporting_basic.err_unreachable l "TwoReg didn't contain a register type") in
- (LEXP_aux(lexp,(l,Base(([],t'),Alias alias_inf,[],ef,ef,nob))),
- u, false, Envmap.empty, External None,[],nob,ef,ef)
- | _ -> assert false)
- | Some(Base((parms,t),tag,cs,_,_,b)) ->
- let t,cs,ef,_ =
- match tag with | External _ | Emp_global -> subst parms false false t cs pure_e
- | _ -> t,cs,{effect = Eset[BE_aux(BE_lset,l)]},Envmap.empty
+ { env with records = Bindings.add id (typq, fields) env.records;
+ accessors = List.fold_left fold_accessors env.accessors fields }
+ end
+
+ let get_accessor id env =
+ let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in
+ try freshen_bind (Bindings.find id env.accessors)
+ with
+ | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id id)
+
+ let is_mutable id env =
+ try
+ let (mut, _) = Bindings.find id env.locals in
+ match mut with
+ | Mutable -> true
+ | Immutable -> false
+ with
+ | Not_found -> typ_error (id_loc id) ("No local binding found for " ^ string_of_id id)
+
+ let string_of_mtyp (mut, typ) = match mut with
+ | Immutable -> string_of_typ typ
+ | Mutable -> "ref<" ^ string_of_typ typ ^ ">"
+
+ let add_local id mtyp env =
+ begin
+ wf_typ env (snd mtyp);
+ typ_print ("Adding local binding " ^ string_of_id id ^ " :: " ^ string_of_mtyp mtyp);
+ { env with locals = Bindings.add id mtyp env.locals }
+ end
+
+ let add_variant id variant env =
+ begin
+ typ_print ("Adding variant " ^ string_of_id id);
+ { env with variants = Bindings.add id variant env.variants }
+ end
+
+ let add_union_id id bind env =
+ begin
+ typ_print ("Adding union identifier binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind);
+ { env with union_ids = Bindings.add id bind env.union_ids }
+ end
+
+ let get_flow id env =
+ try Bindings.find id env.flow with
+ | Not_found -> fun typ -> typ
+
+ let add_flow id f env =
+ begin
+ typ_print ("Adding flow constraints for " ^ string_of_id id);
+ { env with flow = Bindings.add id (fun typ -> f (get_flow id env typ)) env.flow }
+ end
+
+ let get_register id env =
+ try Bindings.find id env.registers with
+ | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id)
+
+ let get_overloads id env =
+ try Bindings.find id env.overloads with
+ | Not_found -> []
+
+ let add_overloads id ids env =
+ typ_print ("Adding overloads for " ^ string_of_id id ^ " [" ^ string_of_list ", " string_of_id ids ^ "]");
+ { env with overloads = Bindings.add id ids env.overloads }
+
+ let get_casts env = env.casts
+
+ let check_index_range cmp f t (BF_aux (ir, l)) =
+ match ir with
+ | BF_single n ->
+ if cmp f n && cmp n t
+ then n
+ else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n; t])
+ | BF_range (n1, n2) ->
+ if cmp f n1 && cmp n1 n2 && cmp n2 t
+ then n2
+ else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n1; n2; t])
+ | BF_concat _ -> typ_error l "Index range concatenation currently unsupported"
+
+ let rec check_index_ranges ids cmp base top = function
+ | [] -> ()
+ | ((range, id) :: ranges) ->
+ if IdSet.mem id ids
+ then typ_error (id_loc id) ("Duplicate id " ^ string_of_id id ^ " in register typedef")
+ else
+ begin
+ let base' = check_index_range cmp base top range in
+ check_index_ranges (IdSet.add id ids) cmp base' top ranges
+ end
+
+ let add_register id typ env =
+ if Bindings.mem id env.registers
+ then typ_error (id_loc id) ("Register " ^ string_of_id id ^ " is already bound")
+ else
+ begin
+ typ_print ("Adding register binding " ^ string_of_id id ^ " :: " ^ string_of_typ typ);
+ { env with registers = Bindings.add id typ env.registers }
+ end
+
+ let add_regtyp id base top ranges env =
+ if Bindings.mem id env.regtyps
+ then typ_error (id_loc id) ("Register type " ^ string_of_id id ^ " is already bound")
+ else
+ begin
+ typ_print ("Adding register type " ^ string_of_id id);
+ if base > top
+ then check_index_ranges IdSet.empty (fun x y -> x > y) (base + 1) (top - 1) ranges
+ else check_index_ranges IdSet.empty (fun x y -> x < y) (base - 1) (top + 1) ranges;
+ { env with regtyps = Bindings.add id (base, top, ranges) env.regtyps }
+ end
+
+ let is_regtyp id env = Bindings.mem id env.regtyps
+
+ let get_regtyp id env =
+ try Bindings.find id env.regtyps with
+ | Not_found -> typ_error (id_loc id) (string_of_id id ^ " is not a register type")
+
+ let lookup_id id env =
+ try
+ let (mut, typ) = Bindings.find id env.locals in
+ let flow = get_flow id env in
+ Local (mut, flow typ)
+ with
+ | Not_found ->
+ begin
+ try Register (Bindings.find id env.registers) with
+ | Not_found ->
+ begin
+ try
+ let (enum, _) = List.find (fun (enum, ctors) -> IdSet.mem id ctors) (Bindings.bindings env.enums) in
+ Enum (mk_typ (Typ_id enum))
+ with
+ | Not_found ->
+ begin
+ try
+ let (typq, typ) = freshen_bind env (Bindings.find id env.union_ids) in
+ Union (typq, typ)
+ with
+ | Not_found -> Unbound
+ end
+ end
+ end
+
+ let add_typ_var kid k env =
+ if KBindings.mem kid env.typ_vars
+ then typ_error (kid_loc kid) ("Kind identifier " ^ string_of_kid kid ^ " is already bound")
+ else
+ begin
+ typ_debug ("Adding kind identifier binding " ^ string_of_kid kid ^ " :: " ^ string_of_base_kind_aux k);
+ { env with typ_vars = KBindings.add kid k env.typ_vars }
+ end
+
+ let rec wf_constraint env (NC_aux (nc, _)) =
+ match nc with
+ | NC_fixed (n1, n2) -> wf_nexp env n1; wf_nexp env n2
+ | NC_not_equal (n1, n2) -> wf_nexp env n1; wf_nexp env n2
+ | NC_bounded_ge (n1, n2) -> wf_nexp env n1; wf_nexp env n2
+ | NC_bounded_le (n1, n2) -> wf_nexp env n1; wf_nexp env n2
+ | NC_nat_set_bounded (kid, ints) -> () (* MAYBE: We could demand that ints are all unique here *)
+ | NC_or (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2
+ | NC_and (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2
+
+ let get_constraints env = env.constraints
+
+ let add_constraint (NC_aux (_, l) as constr) env =
+ wf_constraint env constr;
+ begin
+ typ_print ("Adding constraint " ^ string_of_n_constraint constr);
+ { env with constraints = constr :: env.constraints }
+ end
+
+ let get_ret_typ env = env.ret_typ
+
+ let add_ret_typ typ env = { env with ret_typ = Some typ }
+
+ let allow_casts env = env.allow_casts
+
+ let no_casts env = { env with allow_casts = false }
+ let enable_casts env = { env with allow_casts = true }
+
+ let add_cast cast env =
+ typ_print ("Adding cast " ^ string_of_id cast);
+ { env with casts = cast :: env.casts }
+
+ let add_typ_synonym id synonym env =
+ if Bindings.mem id env.typ_synonyms
+ then typ_error (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists")
+ else
+ begin
+ typ_print ("Adding type synonym " ^ string_of_id id);
+ { env with typ_synonyms = Bindings.add id synonym env.typ_synonyms }
+ end
+
+ let get_typ_synonym id env = Bindings.find id env.typ_synonyms
+
+ let rec expand_synonyms env (Typ_aux (typ, l) as t) =
+ match typ with
+ | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l)
+ | Typ_fn (typ1, typ2, effs) -> Typ_aux (Typ_fn (expand_synonyms env typ1, expand_synonyms env typ2, effs), l)
+ | Typ_app (id, args) ->
+ begin
+ try
+ let synonym = Bindings.find id env.typ_synonyms in
+ expand_synonyms env (synonym args)
+ with
+ | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l)
+ end
+ | Typ_id id ->
+ begin
+ try
+ let synonym = Bindings.find id env.typ_synonyms in
+ expand_synonyms env (synonym [])
+ with
+ | Not_found -> Typ_aux (Typ_id id, l)
+ end
+ | typ -> Typ_aux (typ, l)
+ and expand_synonyms_arg env (Typ_arg_aux (typ_arg, l)) =
+ match typ_arg with
+ | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (expand_synonyms env typ), l)
+ | arg -> Typ_arg_aux (arg, l)
+
+ let base_typ_of env typ =
+ let rec aux (Typ_aux (t,a)) =
+ let rewrap t = Typ_aux (t,a) in
+ match t with
+ | Typ_fn (t1, t2, eff) ->
+ rewrap (Typ_fn (aux t1, aux t2, eff))
+ | Typ_tup ts ->
+ rewrap (Typ_tup (List.map aux ts))
+ | Typ_app (register, [Typ_arg_aux (Typ_arg_typ rtyp,_)])
+ when string_of_id register = "register" ->
+ aux rtyp
+ | Typ_app (id, targs) ->
+ rewrap (Typ_app (id, List.map aux_arg targs))
+ | t -> rewrap t
+ and aux_arg (Typ_arg_aux (targ,a)) =
+ let rewrap targ = Typ_arg_aux (targ,a) in
+ match targ with
+ | Typ_arg_typ typ -> rewrap (Typ_arg_typ (aux typ))
+ | targ -> rewrap targ in
+ aux (expand_synonyms env typ)
+
+ let get_default_order env =
+ match env.default_order with
+ | None -> typ_error Parse_ast.Unknown ("No default order has been set")
+ | Some ord -> ord
+
+ let set_default_order o env =
+ match env.default_order with
+ | None -> { env with default_order = Some (Ord_aux (o, Parse_ast.Unknown)) }
+ | Some _ -> typ_error Parse_ast.Unknown ("Cannot change default order once already set")
+
+ let set_default_order_inc = set_default_order Ord_inc
+ let set_default_order_dec = set_default_order Ord_dec
+
+end
+
+
+let add_typquant (quant : typquant) (env : Env.t) : Env.t =
+ let rec add_quant_item env = function
+ | QI_aux (qi, _) -> add_quant_item_aux env qi
+ and add_quant_item_aux env = function
+ | QI_const constr -> Env.add_constraint constr env
+ | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var kid BK_nat env
+ | QI_id (KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (k, _)], _), kid), _)) -> Env.add_typ_var kid k env
+ | QI_id (KOpt_aux (_, l)) -> typ_error l "Type variable had non base kinds!"
+ in
+ match quant with
+ | TypQ_aux (TypQ_no_forall, _) -> env
+ | TypQ_aux (TypQ_tq quants, _) -> List.fold_left add_quant_item env quants
+
+(* Create vectors with the default order from the environment *)
+
+let dvector_typ env n m typ = vector_typ n m (Env.get_default_order env) typ
+
+let lvector_typ env l typ =
+ match Env.get_default_order env with
+ | Ord_aux (Ord_inc, _) as ord ->
+ vector_typ (nconstant 0) l ord typ
+ | Ord_aux (Ord_dec, _) as ord ->
+ vector_typ (nminus l (nconstant 1)) l ord typ
+
+let initial_env =
+ Env.empty
+ |> Env.add_typ_synonym (mk_id "atom") (fun args -> mk_typ (Typ_app (mk_id "range", args @ args)))
+
+(**************************************************************************)
+(* 3. Subtyping and constraint solving *)
+(**************************************************************************)
+
+let order_eq (Ord_aux (ord_aux1, _)) (Ord_aux (ord_aux2, _)) =
+ match ord_aux1, ord_aux2 with
+ | Ord_inc, Ord_inc -> true
+ | Ord_dec, Ord_dec -> true
+ | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0
+ | _, _ -> false
+
+let rec props_subst sv subst props =
+ match props with
+ | [] -> []
+ | ((nexp1, nexp2) :: props) -> (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) :: props_subst sv subst props
+
+type tnf =
+ | Tnf_wild
+ | Tnf_id of id
+ | Tnf_var of kid
+ | Tnf_tup of tnf list
+ | Tnf_index_sort of index_sort
+ | Tnf_app of id * tnf_arg list
+and tnf_arg =
+ | Tnf_arg_nexp of nexp
+ | Tnf_arg_typ of tnf
+ | Tnf_arg_order of order
+ | Tnf_arg_effect of effect
+
+let rec string_of_tnf = function
+ | Tnf_wild -> "_"
+ | Tnf_id id -> string_of_id id
+ | Tnf_var kid -> string_of_kid kid
+ | Tnf_tup tnfs -> "(" ^ string_of_list ", " string_of_tnf tnfs ^ ")"
+ | Tnf_app (id, args) -> string_of_id id ^ "<" ^ string_of_list ", " string_of_tnf_arg args ^ ">"
+ | Tnf_index_sort IS_int -> "INT"
+ | Tnf_index_sort (IS_prop (kid, props)) ->
+ "{" ^ string_of_kid kid ^ " | " ^ string_of_list " & " (fun (n1, n2) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2) props ^ "}"
+and string_of_tnf_arg = function
+ | Tnf_arg_nexp n -> string_of_nexp n
+ | Tnf_arg_typ tnf -> string_of_tnf tnf
+ | Tnf_arg_order o -> string_of_order o
+ | Tnf_arg_effect eff -> string_of_effect eff
+
+let rec normalize_typ env (Typ_aux (typ, l)) =
+ match typ with
+ | Typ_wild -> Tnf_wild
+ | Typ_id (Id_aux (Id "int", _)) -> Tnf_index_sort IS_int
+ | Typ_id (Id_aux (Id "nat", _)) ->
+ let kid = Env.fresh_kid env in Tnf_index_sort (IS_prop (kid, [(nconstant 0, nvar kid)]))
+ | Typ_id v ->
+ begin
+ try normalize_typ env (Env.get_typ_synonym v env []) with
+ | Not_found -> Tnf_id v
+ end
+ | Typ_var kid -> Tnf_var kid
+ | Typ_tup typs -> Tnf_tup (List.map (normalize_typ env) typs)
+ | Typ_app (f, []) -> normalize_typ env (Typ_aux (Typ_id f, l))
+ | Typ_app (Id_aux (Id "range", _), [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]) ->
+ let kid = Env.fresh_kid env in
+ Tnf_index_sort (IS_prop (kid, [(n1, nvar kid); (nvar kid, n2)]))
+ | Typ_app ((Id_aux (Id "vector", _) as vector), args) ->
+ Tnf_app (vector, List.map (normalize_typ_arg env) args)
+ | Typ_app (id, args) ->
+ begin
+ try normalize_typ env (Env.get_typ_synonym id env args) with
+ | Not_found -> Tnf_app (id, List.map (normalize_typ_arg env) args)
+ end
+ | Typ_fn _ -> typ_error l ("Cannot normalize function type " ^ string_of_typ (Typ_aux (typ, l)))
+and normalize_typ_arg env (Typ_arg_aux (typ_arg, _)) =
+ match typ_arg with
+ | Typ_arg_nexp n -> Tnf_arg_nexp n
+ | Typ_arg_typ typ -> Tnf_arg_typ (normalize_typ env typ)
+ | Typ_arg_order o -> Tnf_arg_order o
+ | Typ_arg_effect e -> Tnf_arg_effect e
+
+(* Here's how the constraint generation works for subtyping
+
+X(b,c...) --> {a. Y(a,b,c...)} \subseteq {a. Z(a,b,c...)}
+
+this is equivalent to
+
+\forall b c. X(b,c) --> \forall a. Y(a,b,c) --> Z(a,b,c)
+
+\forall b c. X(b,c) --> \forall a. !Y(a,b,c) \/ !Z^-1(a,b,c)
+
+\forall b c. X(b,c) --> !\exists a. Y(a,b,c) /\ Z^-1(a,b,c)
+
+\forall b c. !X(b,c) \/ !\exists a. Y(a,b,c) /\ Z^-1(a,b,c)
+
+!\exists b c. X(b,c) /\ \exists a. Y(a,b,c) /\ Z^-1(a,b,c)
+
+!\exists a b c. X(b,c) /\ Y(a,b,c) /\ Z^-1(a,b,c)
+
+which is then a problem we can feed to the constraint solver expecting unsat.
+ *)
+
+let rec nexp_constraint var_of (Nexp_aux (nexp, l)) =
+ match nexp with
+ | Nexp_id v -> typ_error l "Unimplemented: Cannot generate constraint from Nexp_id"
+ | Nexp_var kid -> Constraint.variable (var_of kid)
+ | Nexp_constant c -> Constraint.constant (big_int_of_int c)
+ | Nexp_times (nexp1, nexp2) -> Constraint.mult (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint var_of nexp)
+ | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint var_of nexp)
+
+let rec nc_constraint var_of (NC_aux (nc, l)) =
+ match nc with
+ | NC_fixed (nexp1, nexp2) -> Constraint.eq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | NC_not_equal (nexp1, nexp2) -> Constraint.neq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | NC_bounded_ge (nexp1, nexp2) -> Constraint.gteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | NC_bounded_le (nexp1, nexp2) -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | NC_nat_set_bounded (_, []) -> Constraint.literal false
+ | NC_nat_set_bounded (kid, (int :: ints)) ->
+ List.fold_left Constraint.disj
+ (Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int int)))
+ (List.map (fun i -> Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int i))) ints)
+ | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint var_of nc1) (nc_constraint var_of nc2)
+ | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint var_of nc1) (nc_constraint var_of nc2)
+
+let rec nc_constraints var_of ncs =
+ match ncs with
+ | [] -> Constraint.literal true
+ | [nc] -> nc_constraint var_of nc
+ | (nc :: ncs) ->
+ Constraint.conj (nc_constraint var_of nc) (nc_constraints var_of ncs)
+
+let prove_z3 env nc =
+ typ_print ("Prove " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc);
+ let module Bindings = Map.Make(Kid) in
+ let bindings = ref Bindings.empty in
+ let fresh_var kid =
+ let n = Bindings.cardinal !bindings in
+ bindings := Bindings.add kid n !bindings;
+ n
+ in
+ let var_of kid =
+ try Bindings.find kid !bindings with
+ | Not_found -> fresh_var kid
+ in
+ let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.negate (nc_constraint var_of nc)) in
+ match Constraint.call_z3 constr with
+ | Constraint.Unsat _ -> typ_debug "unsat"; true
+ | Constraint.Unknown [] -> typ_debug "sat"; false
+ | Constraint.Unknown _ -> typ_debug "unknown"; false
+
+let prove env (NC_aux (nc_aux, _) as nc) =
+ let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) =
+ match n1, n2 with
+ | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true
+ | _, _ -> false
+ in
+ match nc_aux with
+ | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 = c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
+ | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
+ | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 >= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
+ | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <> c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
+ | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 > c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
+ | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 < c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
+ | _ -> prove_z3 env nc
+
+let rec subtyp_tnf env tnf1 tnf2 =
+ typ_print ("Subset " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_tnf tnf1 ^ " " ^ string_of_tnf tnf2);
+ let module Bindings = Map.Make(Kid) in
+ let bindings = ref Bindings.empty in
+ let fresh_var kid =
+ let n = Bindings.cardinal !bindings in
+ bindings := Bindings.add kid n !bindings;
+ n
+ in
+ let var_of kid =
+ try Bindings.find kid !bindings with
+ | Not_found -> fresh_var kid
+ in
+ let rec neg_props props =
+ match props with
+ | [] -> Constraint.literal false
+ | [(nexp1, nexp2)] -> Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | ((nexp1, nexp2) :: props) ->
+ Constraint.disj (Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (neg_props props)
+ in
+ let rec pos_props props =
+ match props with
+ | [] -> Constraint.literal true
+ | [(nexp1, nexp2)] -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
+ | ((nexp1, nexp2) :: props) ->
+ Constraint.conj (Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (pos_props props)
+ in
+ match (tnf1, tnf2) with
+ | Tnf_wild, Tnf_wild -> true
+ | Tnf_id v1, Tnf_id v2 -> Id.compare v1 v2 = 0
+ | Tnf_var kid1, Tnf_var kid2 -> Kid.compare kid1 kid2 = 0
+ | Tnf_tup tnfs1, Tnf_tup tnfs2 ->
+ begin
+ try List.for_all2 (subtyp_tnf env) tnfs1 tnfs2 with
+ | Invalid_argument _ -> false
+ end
+ | Tnf_app (v1, args1), Tnf_app (v2, args2) -> Id.compare v1 v2 = 0 && List.for_all2 (tnf_args_eq env) args1 args2
+ | Tnf_index_sort IS_int, Tnf_index_sort IS_int -> true
+ | Tnf_index_sort (IS_prop _), Tnf_index_sort IS_int -> true
+ | Tnf_index_sort (IS_prop (kid1, prop1)), Tnf_index_sort (IS_prop (kid2, prop2)) ->
+ begin
+ let kid3 = Env.fresh_kid env in
+ let (prop1, prop2) = props_subst kid1 (Nexp_var kid3) prop1, props_subst kid2 (Nexp_var kid3) prop2 in
+ let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.conj (pos_props prop1) (neg_props prop2)) in
+ match Constraint.call_z3 constr with
+ | Constraint.Unsat _ -> typ_debug "unsat"; true
+ | Constraint.Unknown [] -> typ_debug "sat"; false
+ | Constraint.Unknown _ -> typ_debug "unknown"; false
+ end
+ | _, _ -> false
+
+and tnf_args_eq env arg1 arg2 =
+ match arg1, arg2 with
+ | Tnf_arg_nexp n1, Tnf_arg_nexp n2 -> prove env (NC_aux (NC_fixed (n1, n2), Parse_ast.Unknown))
+ | Tnf_arg_order ord1, Tnf_arg_order ord2 -> order_eq ord1 ord2
+ | Tnf_arg_typ tnf1, Tnf_arg_typ tnf2 -> subtyp_tnf env tnf1 tnf2 && subtyp_tnf env tnf2 tnf1
+ | _, _ -> assert false
+
+let subtyp l env typ1 typ2 =
+ if subtyp_tnf env (normalize_typ env typ1) (normalize_typ env typ2)
+ then ()
+ else typ_error l (string_of_typ typ1
+ ^ " is not a subtype of " ^ string_of_typ typ2
+ ^ " in context " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env))
+
+let typ_equality l env typ1 typ2 =
+ subtyp l env typ1 typ2; subtyp l env typ2 typ1
+
+(**************************************************************************)
+(* 4. Unification *)
+(**************************************************************************)
+
+let rec nexp_frees (Nexp_aux (nexp, l)) =
+ match nexp with
+ | Nexp_id _ -> typ_error l "Unimplemented Nexp_id in nexp_frees"
+ | Nexp_var kid -> KidSet.singleton kid
+ | Nexp_constant _ -> KidSet.empty
+ | Nexp_times (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
+ | Nexp_sum (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
+ | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
+ | Nexp_exp n -> nexp_frees n
+ | Nexp_neg n -> nexp_frees n
+
+let order_frees (Ord_aux (ord_aux, l)) =
+ match ord_aux with
+ | Ord_var kid -> KidSet.singleton kid
+ | _ -> KidSet.empty
+
+let rec typ_frees (Typ_aux (typ_aux, l)) =
+ match typ_aux with
+ | Typ_wild -> KidSet.empty
+ | Typ_id v -> KidSet.empty
+ | Typ_var kid -> KidSet.singleton kid
+ | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map typ_frees typs)
+ | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map typ_arg_frees args)
+and typ_arg_frees (Typ_arg_aux (typ_arg_aux, l)) =
+ match typ_arg_aux with
+ | Typ_arg_nexp n -> nexp_frees n
+ | Typ_arg_typ typ -> typ_frees typ
+ | Typ_arg_order ord -> order_frees ord
+ | Typ_arg_effect _ -> assert false
+
+let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) =
+ match nexp1, nexp2 with
+ | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0
+ | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 = 0
+ | Nexp_constant c1, Nexp_constant c2 -> c1 = c2
+ | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
+ | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
+ | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
+ | Nexp_exp n1, Nexp_exp n2 -> nexp_identical n1 n2
+ | Nexp_neg n1, Nexp_neg n2 -> nexp_identical n1 n2
+ | _, _ -> false
+
+let ord_identical (Ord_aux (ord1, _)) (Ord_aux (ord2, _)) =
+ match ord1, ord2 with
+ | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0
+ | Ord_inc, Ord_inc -> true
+ | Ord_dec, Ord_dec -> true
+ | _, _ -> false
+
+let rec typ_identical (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) =
+ match typ1, typ2 with
+ | Typ_wild, Typ_wild -> true
+ | Typ_id v1, Typ_id v2 -> Id.compare v1 v2 = 0
+ | Typ_var kid1, Typ_var kid2 -> Kid.compare kid1 kid2 = 0
+ | Typ_tup typs1, Typ_tup typs2 ->
+ begin
+ try List.for_all2 typ_identical typs1 typs2 with
+ | Invalid_argument _ -> false
+ end
+ | Typ_app (f1, args1), Typ_app (f2, args2) ->
+ begin
+ try Id.compare f1 f2 = 0 && List.for_all2 typ_arg_identical args1 args2 with
+ | Invalid_argument _ -> false
+ end
+ | _, _ -> false
+and typ_arg_identical (Typ_arg_aux (arg1, _)) (Typ_arg_aux (arg2, _)) =
+ match arg1, arg2 with
+ | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2
+ | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical typ1 typ2
+ | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2
+ | Typ_arg_effect _, Typ_arg_effect _ -> assert false
+
+type uvar =
+ | U_nexp of nexp
+ | U_order of order
+ | U_effect of effect
+ | U_typ of typ
+
+exception Unification_error of l * string;;
+
+let unify_error l str = raise (Unification_error (l, str))
+
+let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) =
+ typ_debug ("UNIFYING NEXPS " ^ string_of_nexp nexp1 ^ " AND " ^ string_of_nexp nexp2 ^ " FOR GOALS " ^ string_of_list ", " string_of_kid (KidSet.elements goals));
+ if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals)
+ then
+ begin
+ if prove env (NC_aux (NC_fixed (nexp1, nexp2), Parse_ast.Unknown))
+ then None
+ else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal")
+ end
+ else
+ match nexp_aux1 with
+ | Nexp_id v -> unify_error l "Unimplemented Nexp_id in unify nexp"
+ | Nexp_var kid when KidSet.mem kid goals -> Some (kid, nexp2)
+ | Nexp_constant c1 ->
+ begin
+ match nexp_aux2 with
+ | Nexp_constant c2 -> if c1 = c2 then None else unify_error l "Constants are not the same"
+ | _ -> unify_error l "Unification error"
+ end
+ | Nexp_sum (n1a, n1b) ->
+ if KidSet.is_empty (nexp_frees n1b)
+ then unify_nexps l env goals n1a (nminus nexp2 n1b)
+ else
+ if KidSet.is_empty (nexp_frees n1a)
+ then unify_nexps l env goals n1b (nminus nexp2 n1a)
+ else unify_error l ("Both sides of Nat expression " ^ string_of_nexp nexp1
+ ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2)
+ | Nexp_minus (n1a, n1b) ->
+ if KidSet.is_empty (nexp_frees n1b)
+ then unify_nexps l env goals n1a (nsum nexp2 n1b)
+ else unify_error l ("Cannot unify minus Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
+ | Nexp_times (n1a, n1b) ->
+ if KidSet.is_empty (nexp_frees n1a)
+ then
+ begin
+ match nexp_aux2 with
+ | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1a, n2a), Parse_ast.Unknown)) ->
+ unify_nexps l env goals n1b n2b
+ | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
+ end
+ else if KidSet.is_empty (nexp_frees n1b)
+ then
+ begin
+ match nexp_aux2 with
+ | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1b, n2b), Parse_ast.Unknown)) ->
+ unify_nexps l env goals n1a n2a
+ | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
+ end
+ else unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
+ | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
+
+let string_of_uvar = function
+ | U_nexp n -> string_of_nexp n
+ | U_order o -> string_of_order o
+ | U_effect eff -> string_of_effect eff
+ | U_typ typ -> string_of_typ typ
+
+let unify_order l (Ord_aux (ord_aux1, _) as ord1) (Ord_aux (ord_aux2, _) as ord2) =
+ typ_debug ("UNIFYING ORDERS " ^ string_of_order ord1 ^ " AND " ^ string_of_order ord2);
+ match ord_aux1, ord_aux2 with
+ | Ord_var kid, _ -> KBindings.singleton kid (U_order ord2)
+ | Ord_inc, Ord_inc -> KBindings.empty
+ | Ord_dec, Ord_dec -> KBindings.empty
+ | _, _ -> unify_error l (string_of_order ord1 ^ " cannot be unified with " ^ string_of_order ord2)
+
+let subst_unifiers unifiers typ =
+ let subst_unifier typ (kid, uvar) =
+ match uvar with
+ | U_nexp nexp -> typ_subst_nexp kid (unaux_nexp nexp) typ
+ | U_order ord -> typ_subst_order kid (unaux_order ord) typ
+ | U_typ subst -> typ_subst_typ kid (unaux_typ subst) typ
+ | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier"
+ in
+ List.fold_left subst_unifier typ (KBindings.bindings unifiers)
+
+let subst_args_unifiers unifiers typ_args =
+ let subst_unifier typ_args (kid, uvar) =
+ match uvar with
+ | U_nexp nexp -> List.map (typ_subst_arg_nexp kid (unaux_nexp nexp)) typ_args
+ | U_order ord -> List.map (typ_subst_arg_order kid (unaux_order ord)) typ_args
+ | U_typ subst -> List.map (typ_subst_arg_typ kid (unaux_typ subst)) typ_args
+ | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier"
+ in
+ List.fold_left subst_unifier typ_args (KBindings.bindings unifiers)
+
+let unify l env typ1 typ2 =
+ typ_print ("Unify " ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2);
+ let goals = KidSet.inter (KidSet.diff (typ_frees typ1) (typ_frees typ2)) (typ_frees typ1) in
+ let merge_unifiers l kid uvar1 uvar2 =
+ match uvar1, uvar2 with
+ | Some (U_nexp n1), Some (U_nexp n2) ->
+ if nexp_identical n1 n2 then Some (U_nexp n1)
+ else unify_error l ("Multiple non-identical unifiers for " ^ string_of_kid kid
+ ^ ": " ^ string_of_nexp n1 ^ " and " ^ string_of_nexp n2)
+ | Some _, Some _ -> unify_error l "Multiple non-identical non-nexp unifiers"
+ | None, Some u2 -> Some u2
+ | Some u1, None -> Some u1
+ | None, None -> None
+ in
+ let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) =
+ typ_debug ("UNIFYING TYPES " ^ string_of_typ typ1 ^ " AND " ^ string_of_typ typ2);
+ match typ1_aux, typ2_aux with
+ | Typ_wild, Typ_wild -> KBindings.empty
+ | Typ_id v1, Typ_id v2 ->
+ if Id.compare v1 v2 = 0 then KBindings.empty
+ else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
+ | Typ_id v1, Typ_app (f2, []) ->
+ if Id.compare v1 f2 = 0 then KBindings.empty
+ else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
+ | Typ_app (f1, []), Typ_id v2 ->
+ if Id.compare f1 v2 = 0 then KBindings.empty
+ else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
+ | Typ_var kid, _ when KidSet.mem kid goals -> KBindings.singleton kid (U_typ typ2)
+ | Typ_var kid1, Typ_var kid2 when Kid.compare kid1 kid2 = 0 -> KBindings.empty
+ | Typ_tup typs1, Typ_tup typs2 ->
+ begin
+ try List.fold_left (KBindings.merge (merge_unifiers l)) KBindings.empty (List.map2 (unify_typ l) typs1 typs2) with
+ | Invalid_argument _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2
+ ^ " tuple type is of different length")
+ end
+ | Typ_app (f1, args1), Typ_app (f2, args2) when Id.compare f1 f2 = 0 ->
+ unify_typ_arg_list 0 KBindings.empty [] [] args1 args2
+ | _, _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
+
+ and unify_typ_arg_list unified acc uargs1 uargs2 args1 args2 =
+ match args1, args2 with
+ | [], [] when unified = 0 && List.length uargs1 > 0 ->
+ unify_error l "Could not unify arg lists" (*FIXME improve error *)
+ | [], [] when unified > 0 && List.length uargs1 > 0 -> unify_typ_arg_list 0 acc [] [] uargs1 uargs2
+ | [], [] when List.length uargs1 = 0 -> acc
+ | (a1 :: a1s), (a2 :: a2s) ->
+ begin
+ let unifiers, success =
+ try unify_typ_args l a1 a2, true with
+ | Unification_error _ -> KBindings.empty, false
+ in
+ let a1s = subst_args_unifiers unifiers a1s in
+ let a2s = subst_args_unifiers unifiers a2s in
+ let uargs1 = subst_args_unifiers unifiers uargs1 in
+ let uargs2 = subst_args_unifiers unifiers uargs2 in
+ if success
+ then unify_typ_arg_list (unified + 1) (KBindings.merge (merge_unifiers l) unifiers acc) uargs1 uargs2 a1s a2s
+ else unify_typ_arg_list unified acc (a1 :: uargs1) (a2 :: uargs2) a1s a2s
+ end
+ | _, _ -> unify_error l "Cannot unify type lists of different length"
+
+ and unify_typ_args l (Typ_arg_aux (typ_arg_aux1, _) as typ_arg1) (Typ_arg_aux (typ_arg_aux2, _) as typ_arg2) =
+ match typ_arg_aux1, typ_arg_aux2 with
+ | Typ_arg_nexp n1, Typ_arg_nexp n2 ->
+ begin
+ match unify_nexps l env goals (nexp_simp n1) (nexp_simp n2) with
+ | Some (kid, unifier) -> KBindings.singleton kid (U_nexp unifier)
+ | None -> KBindings.empty
+ end
+ | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l typ1 typ2
+ | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l ord1 ord2
+ | Typ_arg_effect _, Typ_arg_effect _ -> assert false
+ | _, _ -> unify_error l (string_of_typ_arg typ_arg1 ^ " cannot be unified with type argument " ^ string_of_typ_arg typ_arg2)
+ in
+ let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in
+ unify_typ l typ1 typ2
+
+(**************************************************************************)
+(* 5. Type checking expressions *)
+(**************************************************************************)
+
+(* The type checker produces a fully annoted AST - tannot is the type
+ of these type annotations. *)
+type tannot = (Env.t * typ * effect) option
+
+let infer_lit env (L_aux (lit_aux, l) as lit) =
+ match lit_aux with
+ | L_unit -> unit_typ
+ | L_zero -> bit_typ
+ | L_one -> bit_typ
+ | L_num n -> atom_typ (nconstant n)
+ | L_true -> bool_typ
+ | L_false -> bool_typ
+ | L_string _ -> string_typ
+ | L_real _ -> real_typ
+ | L_bin str ->
+ begin
+ match Env.get_default_order env with
+ | Ord_aux (Ord_inc, _) ->
+ dvector_typ env (nconstant 0) (nconstant (String.length str)) (mk_typ (Typ_id (mk_id "bit")))
+ | Ord_aux (Ord_dec, _) ->
+ dvector_typ env
+ (nconstant (String.length str - 1))
+ (nconstant (String.length str))
+ (mk_typ (Typ_id (mk_id "bit")))
+ end
+ | L_hex str ->
+ begin
+ match Env.get_default_order env with
+ | Ord_aux (Ord_inc, _) ->
+ dvector_typ env (nconstant 0) (nconstant (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit")))
+ | Ord_aux (Ord_dec, _) ->
+ dvector_typ env
+ (nconstant (String.length str * 4 - 1))
+ (nconstant (String.length str * 4))
+ (mk_typ (Typ_id (mk_id "bit")))
+ end
+ | L_undef -> typ_error l "Cannot infer the type of undefined"
+
+let quant_items : typquant -> quant_item list = function
+ | TypQ_aux (TypQ_tq qis, _) -> qis
+ | TypQ_aux (TypQ_no_forall, _) -> []
+
+let is_nat_kid kid = function
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid'), _) -> Kid.compare kid kid' = 0
+ | KOpt_aux (KOpt_none kid', _) -> Kid.compare kid kid' = 0
+ | _ -> false
+
+let is_order_kid kid = function
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid'), _) -> Kid.compare kid kid' = 0
+ | _ -> false
+
+let is_typ_kid kid = function
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid'), _) -> Kid.compare kid kid' = 0
+ | _ -> false
+
+let rec instantiate_quants quants kid uvar = match quants with
+ | [] -> []
+ | ((QI_aux (QI_id kinded_id, _) as quant) :: quants) ->
+ typ_debug ("instantiating quant " ^ string_of_quant_item quant);
+ begin
+ match uvar with
+ | U_nexp nexp ->
+ if is_nat_kid kid kinded_id
+ then instantiate_quants quants kid uvar
+ else quant :: instantiate_quants quants kid uvar
+ | U_order ord ->
+ if is_order_kid kid kinded_id
+ then instantiate_quants quants kid uvar
+ else quant :: instantiate_quants quants kid uvar
+ | U_typ typ ->
+ if is_typ_kid kid kinded_id
+ then instantiate_quants quants kid uvar
+ else quant :: instantiate_quants quants kid uvar
+ | _ -> typ_error Parse_ast.Unknown "Cannot instantiate quantifier"
+ end
+ | ((QI_aux (QI_const nc, l)) :: quants) ->
+ begin
+ match uvar with
+ | U_nexp nexp ->
+ QI_aux (QI_const (nc_subst_nexp kid (unaux_nexp nexp) nc), l) :: instantiate_quants quants kid uvar
+ | _ -> (QI_aux (QI_const nc, l)) :: instantiate_quants quants kid uvar
+ end
+
+let destructure_vec_typ l env typ =
+ let destructure_vec_typ' l = function
+ | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _);
+ Typ_arg_aux (Typ_arg_nexp n2, _);
+ Typ_arg_aux (Typ_arg_order o, _);
+ Typ_arg_aux (Typ_arg_typ vtyp, _)]
+ ), _) when string_of_id id = "vector" -> (n1, n2, o, vtyp)
+ | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ)
+ in
+ destructure_vec_typ' l (Env.expand_synonyms env typ)
+
+let typ_of_annot (l, tannot) = match tannot with
+ | Some (_, typ, _) -> typ
+ | None -> raise (Reporting_basic.err_unreachable l "no type annotation")
+
+let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
+
+let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
+
+(* Flow typing *)
+
+let destructure_atom (Typ_aux (typ_aux, _)) =
+ match typ_aux with
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c, _)), _)])
+ when string_of_id f = "atom" -> c
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c1, _)), _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)])
+ when string_of_id f = "range" && c1 = c2 -> c1
+ | _ -> assert false
+
+let destructure_atom_nexp (Typ_aux (typ_aux, _)) =
+ match typ_aux with
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)])
+ when string_of_id f = "atom" -> n
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_nexp _, _)])
+ when string_of_id f = "range" -> n
+ | _ -> assert false
+
+let restrict_range_upper c1 (Typ_aux (typ_aux, l) as typ) =
+ match typ_aux with
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp, _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)])
+ when string_of_id f = "range" ->
+ range_typ nexp (nconstant (min c1 c2))
+ | _ -> typ
+
+let restrict_range_lower c1 (Typ_aux (typ_aux, l) as typ) =
+ match typ_aux with
+ | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _); Typ_arg_aux (Typ_arg_nexp nexp, _)])
+ when string_of_id f = "range" ->
+ range_typ (nconstant (max c1 c2)) nexp
+ | _ -> typ
+
+type flow_constraint =
+ | Flow_lteq of int
+ | Flow_gteq of int
+
+let apply_flow_constraint = function
+ | Flow_lteq c -> (restrict_range_upper c, restrict_range_lower (c + 1))
+ | Flow_gteq c -> (restrict_range_lower c, restrict_range_upper (c - 1))
+
+let rec infer_flow env (E_aux (exp_aux, (l, _))) =
+ match exp_aux with
+ | E_app (f, [x; y]) when string_of_id f = "lteq_atom_atom" ->
+ let n1 = destructure_atom_nexp (typ_of x) in
+ let n2 = destructure_atom_nexp (typ_of y) in
+ [], [nc_lteq n1 n2]
+ | E_app (f, [x; y]) when string_of_id f = "gteq_atom_atom" ->
+ let n1 = destructure_atom_nexp (typ_of x) in
+ let n2 = destructure_atom_nexp (typ_of y) in
+ [], [nc_gteq n1 n2]
+ | E_app (f, [x; y]) when string_of_id f = "lt_atom_atom" ->
+ let n1 = destructure_atom_nexp (typ_of x) in
+ let n2 = destructure_atom_nexp (typ_of y) in
+ [], [nc_lt n1 n2]
+ | E_app (f, [x; y]) when string_of_id f = "gt_atom_atom" ->
+ let n1 = destructure_atom_nexp (typ_of x) in
+ let n2 = destructure_atom_nexp (typ_of y) in
+ [], [nc_gt n1 n2]
+ | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lt_range_atom" ->
+ let kid = Env.fresh_kid env in
+ let c = destructure_atom (typ_of y) in
+ [(v, Flow_lteq (c - 1))], []
+ | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" ->
+ let kid = Env.fresh_kid env in
+ let c = destructure_atom (typ_of y) in
+ [(v, Flow_lteq c)], []
+ | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gt_range_atom" ->
+ let kid = Env.fresh_kid env in
+ let c = destructure_atom (typ_of y) in
+ [(v, Flow_gteq (c + 1))], []
+ | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" ->
+ let kid = Env.fresh_kid env in
+ let c = destructure_atom (typ_of y) in
+ [(v, Flow_gteq c)], []
+ | _ -> [], []
+
+let rec add_flows b flows env =
+ match flows with
+ | [] -> env
+ | (id, flow) :: flows when b -> add_flows true flows (Env.add_flow id (fst (apply_flow_constraint flow)) env)
+ | (id, flow) :: flows -> add_flows false flows (Env.add_flow id (snd (apply_flow_constraint flow)) env)
+
+let rec add_constraints constrs env =
+ List.fold_left (fun env constr -> Env.add_constraint constr env) env constrs
+
+(* When doing implicit type coercion, for performance reasons we want
+ to filter out the possible casts to only those that could
+ reasonably apply. We don't mind if we try some coercions that are
+ impossible, but we should be careful to never rule out a possible
+ cast - match_typ and filter_casts implement this logic. It must be
+ the case that if two types unify, then they match. *)
+let rec match_typ (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) =
+ match typ1, typ2 with
+ | Typ_wild, Typ_wild -> true
+ | _, Typ_var kid2 -> true
+ | Typ_id v1, Typ_id v2 when Id.compare v1 v2 = 0 -> true
+ | Typ_id v1, Typ_id v2 when string_of_id v1 = "int" && string_of_id v2 = "nat" -> true
+ | Typ_tup typs1, Typ_tup typs2 -> List.for_all2 match_typ typs1 typs2
+ | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "atom" -> true
+ | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "atom" -> true
+ | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "range" -> true
+ | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "range" -> true
+ | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "range" && string_of_id f2 = "atom" -> true
+ | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "atom" && string_of_id f2 = "range" -> true
+ | Typ_app (f1, _), Typ_app (f2, _) when Id.compare f1 f2 = 0 -> true
+ | Typ_id v1, Typ_app (f2, _) when Id.compare v1 f2 = 0 -> true
+ | Typ_app (f1, _), Typ_id v2 when Id.compare f1 v2 = 0 -> true
+ | _, _ -> false
+
+let rec filter_casts env from_typ to_typ casts =
+ match casts with
+ | (cast :: casts) ->
+ begin
+ let (quant, cast_typ) = Env.get_val_spec cast env in
+ match cast_typ with
+ | Typ_aux (Typ_fn (cast_from_typ, cast_to_typ, _), _)
+ when match_typ from_typ cast_from_typ && match_typ to_typ cast_to_typ ->
+ typ_print ("Considering cast " ^ string_of_typ cast_typ ^ " for " ^ string_of_typ from_typ ^ " to " ^ string_of_typ to_typ);
+ cast :: filter_casts env from_typ to_typ casts
+ | _ -> filter_casts env from_typ to_typ casts
+ end
+ | [] -> []
+
+let is_union_id id env =
+ match Env.lookup_id id env with
+ | Union (_, _) -> true
+ | _ -> false
+
+let crule r env exp typ =
+ incr depth;
+ typ_print ("Check " ^ string_of_exp exp ^ " <= " ^ string_of_typ typ);
+ try
+ let checked_exp = r env exp typ in
+ decr depth; checked_exp
+ with
+ | Type_error (l, m) -> decr depth; typ_error l m
+
+let irule r env exp =
+ incr depth;
+ try
+ let inferred_exp = r env exp in
+ typ_print ("Infer " ^ string_of_exp exp ^ " => " ^ string_of_typ (typ_of inferred_exp));
+ decr depth;
+ inferred_exp
+ with
+ | Type_error (l, m) -> decr depth; typ_error l m
+
+let strip_exp : 'a exp -> unit exp = function exp -> map_exp_annot (fun (l, _) -> (l, ())) exp
+let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) -> (l, ())) pat
+
+let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp =
+ let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
+ let annot_exp exp typ = annot_exp_effect exp typ no_effect in
+ match (exp_aux, typ_aux) with
+ | E_block exps, _ ->
+ begin
+ let rec check_block l env exps typ = match exps with
+ | [] -> typ_error l "Empty block found"
+ | [exp] -> [crule check_exp env exp typ]
+ | (E_aux (E_assign (lexp, bind), _) :: exps) ->
+ let texp, env = bind_assignment env lexp bind in
+ texp :: check_block l env exps typ
+ | ((E_aux (E_assert (E_aux (E_constraint nc, _), assert_msg), _) as exp) :: exps) ->
+ typ_print ("Adding constraint " ^ string_of_n_constraint nc ^ " for assert");
+ let inferred_exp = irule infer_exp env exp in
+ inferred_exp :: check_block l (Env.add_constraint nc env) exps typ
+ | (exp :: exps) ->
+ let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
+ texp :: check_block l env exps typ
+ in
+ annot_exp (E_block (check_block l env exps typ)) typ
+ end
+ | E_case (exp, cases), _ ->
+ let inferred_exp = irule infer_exp env exp in
+ let check_case pat typ = match pat with
+ | Pat_aux (Pat_exp (pat, case), (l, _)) ->
+ let tpat, env = bind_pat env pat (typ_of inferred_exp) in
+ Pat_aux (Pat_exp (tpat, crule check_exp env case typ), (l, None))
+ | Pat_aux (Pat_when (pat, guard, case), (l, _)) ->
+ let tpat, env = bind_pat env pat (typ_of inferred_exp) in
+ let checked_guard = check_exp env guard bool_typ in
+ Pat_aux (Pat_when (tpat, checked_guard, crule check_exp env case typ), (l, None))
+ in
+ annot_exp (E_case (inferred_exp, List.map (fun case -> check_case case typ) cases)) typ
+ | E_let (LB_aux (letbind, (let_loc, _)), exp), _ ->
+ begin
+ match letbind with
+ | LB_val_explicit (typschm, pat, bind) -> assert false
+ | LB_val_implicit (P_aux (P_typ (ptyp, _), _) as pat, bind) ->
+ let checked_bind = crule check_exp env bind ptyp in
+ let tpat, env = bind_pat env pat (typ_of checked_bind) in
+ annot_exp (E_let (LB_aux (LB_val_implicit (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ
+ | LB_val_implicit (pat, bind) ->
+ let inferred_bind = irule infer_exp env bind in
+ let tpat, env = bind_pat env pat (typ_of inferred_bind) in
+ annot_exp (E_let (LB_aux (LB_val_implicit (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ
+ end
+ | E_app_infix (x, op, y), _ when List.length (Env.get_overloads (deinfix op) env) > 0 ->
+ check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ
+ | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_prove") = 0 ->
+ if prove env nc
+ then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
+ else typ_error l ("Cannot prove " ^ string_of_n_constraint nc)
+ | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 ->
+ let rec try_overload = function
+ | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp)
+ | (f :: fs) -> begin
+ typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")");
+ try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with
+ | Type_error (_, m) -> typ_print ("Error : " ^ m); try_overload fs
+ end
+ in
+ try_overload (Env.get_overloads f env)
+ | E_app (f, xs), _ ->
+ let inferred_exp = infer_funapp l env f xs (Some typ) in
+ type_coercion env inferred_exp typ
+ | E_if (cond, then_branch, else_branch), _ ->
+ let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
+ let flows, constrs = infer_flow env cond' in
+ let then_branch' = crule check_exp (add_constraints constrs (add_flows true flows env)) then_branch typ in
+ let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch typ in
+ annot_exp (E_if (cond', then_branch', else_branch')) typ
+ | E_exit exp, _ ->
+ let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
+ annot_exp_effect (E_exit checked_exp) typ (mk_effect [BE_escape])
+ | E_vector vec, _ ->
+ begin
+ let (start, len, ord, vtyp) = destructure_vec_typ l env typ in
+ let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in
+ match len with
+ | Nexp_aux (Nexp_constant lenc, _) ->
+ if List.length vec = lenc then annot_exp (E_vector checked_items) typ
+ else typ_error l "List length didn't match" (* FIXME: improve error message *)
+ | _ -> typ_error l "Cannot check list constant against non-constant length vector type"
+ end
+ | E_lit (L_aux (L_undef, _) as lit), _ ->
+ annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef])
+ (* This rule allows registers of type t to be passed by name with type register<t>*)
+ | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "register" ->
+ let rtyp = Env.get_register reg env in
+ subtyp l env rtyp typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *)
+ | E_id id, _ when is_union_id id env ->
+ begin
+ match Env.lookup_id id env with
+ | Union (typq, ctor_typ) ->
+ let inferred_exp = infer_funapp' l env id (typq, mk_typ (Typ_fn (unit_typ, ctor_typ, no_effect))) [mk_lit L_unit] (Some typ) in
+ annot_exp (E_id id) (typ_of inferred_exp)
+ | _ -> assert false (* Unreachble due to guard *)
+ end
+ | _, _ ->
+ let inferred_exp = irule infer_exp env exp in
+ type_coercion env inferred_exp typ
+
+(* type_coercion env exp typ takes a fully annoted (i.e. already type
+ checked) expression exp, and attempts to cast (coerce) it to the
+ type typ by inserting a coercion function that transforms the
+ annotated expression into the correct type. Returns an annoted
+ expression consisting of a type coercion function applied to exp,
+ or throws a type error if the coercion cannot be performed. *)
+and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
+ let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
+ let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in
+ let rec try_casts m = function
+ | [] -> typ_error l ("No valid casts:\n" ^ m)
+ | (cast :: casts) -> begin
+ typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ);
+ try
+ let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in
+ annot_exp (E_cast (typ, checked_cast)) typ
+ with
+ | Type_error (_, m) -> try_casts m casts
+ end
+ in
+ begin
+ try
+ typ_debug "PERFORMING TYPE COERCION";
+ subtyp l env (typ_of annotated_exp) typ; annotated_exp
+ with
+ | Type_error (_, m) when Env.allow_casts env ->
+ let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
+ try_casts "" casts
+ | Type_error (l, m) -> typ_error l ("Subtype error " ^ m)
+ end
+
+(* type_coercion_unify env exp typ attempts to coerce exp to a type
+ exp_typ in the same way as type_coercion, except it is only
+ required that exp_typ unifies with typ. Returns the annotated
+ coercion as with type_coercion and also a set of unifiers, or
+ throws a unification error *)
+and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ =
+ let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
+ let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in
+ let rec try_casts m = function
+ | [] -> unify_error l ("No valid casts resulted in unification:\n" ^ m)
+ | (cast :: casts) -> begin
+ typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification");
+ try
+ let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
+ let ityp = typ_of inferred_cast in
+ annot_exp (E_cast (ityp, inferred_cast)) ityp, unify l env typ ityp
+ with
+ | Type_error (_, m) -> try_casts m casts
+ | Unification_error (_, m) -> try_casts m casts
+ end
+ in
+ begin
+ try
+ typ_debug "PERFORMING COERCING UNIFICATION";
+ annotated_exp, unify l env typ (typ_of annotated_exp)
+ with
+ | Unification_error (_, m) when Env.allow_casts env ->
+ let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
+ try_casts "" casts
+ end
+
+and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
+ typ_print ("Binding " ^ string_of_typ typ);
+ let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in
+ let switch_typ (P_aux (pat_aux, (l, Some (env, _, eff)))) typ = P_aux (pat_aux, (l, Some (env, typ, eff))) in
+ let bind_tuple_pat (tpats, env) pat typ =
+ let tpat, env = bind_pat env pat typ in tpat :: tpats, env
+ in
+ match pat_aux with
+ | P_id v ->
+ begin
+ match Env.lookup_id v env with
+ | Local (Immutable, _) | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env
+ | Local (Mutable, _) | Register _ ->
+ typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
+ | Enum enum -> subtyp l env enum typ; annot_pat (P_id v) typ, env
+ | Union (typq, ctor_typ) ->
+ begin
+ try
+ let _ = unify l env ctor_typ typ in
+ annot_pat (P_id v) typ, env
+ with
+ | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m)
+ end
+ end
+ | P_wild -> annot_pat P_wild typ, env
+ | P_tup pats ->
+ begin
+ match typ_aux with
+ | Typ_tup typs ->
+ let tpats, env =
+ try List.fold_left2 bind_tuple_pat ([], env) pats typs with
+ | Invalid_argument _ -> typ_error l "Tuple pattern and tuple type have different length"
in
- let t,cs' = get_abbrev d_env t in
- let t_actual = match t.t with | Tabbrev(i,t) -> t | _ -> t in
- let cs_o = cs@cs' in
- (*let _ = Printf.eprintf "Assigning to %s, t is %s\n" i (t_to_string t_actual) in*)
- (match t_actual.t,is_top with
- | Tapp("register",[TA_typ u]),true ->
- let ef = {effect=Eset[BE_aux(BE_wreg,l)]} in
- (LEXP_aux(lexp,(l,(Base(([],t),External (Some i),cs_o,ef,pure_e,nob)))),u,false,
- Envmap.empty,External (Some i),[],nob,ef,ef)
- | Tapp("register",[TA_typ u]),false ->
- (LEXP_aux(lexp,(l,(Base(([],t), Emp_global, cs_o, pure_e,pure_e,nob)))), t,false,
- Envmap.empty, Emp_global, [],nob,pure_e,pure_e)
- | Tapp("reg",[TA_typ u]),_ ->
- (LEXP_aux(lexp,(l,(Base(([],t),Emp_set,cs_o,ef,ef,b)))),u,false,Envmap.empty,Emp_set,[],nob,ef,ef)
- | Tapp("vector",_),false ->
- (LEXP_aux(lexp,(l,(Base(([],t),tag,cs_o,ef,ef,b)))),t,true,Envmap.empty,Emp_set,[],nob,ef,ef)
- | (Tfn _ ,_) ->
- (match tag with
- | External _ | Spec | Emp_global ->
- let u = new_t() in
- let t = {t = Tapp("reg",[TA_typ u])} in
- let bounds = extract_bounds d_env i t in
- let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in
- (LEXP_aux(lexp,(l,tannot)),u,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e)
- | _ ->
- typ_error l ("Cannot assign to " ^ i ^" with type " ^ t_to_string t ^
- ". Assignment must be to registers or non-parameter, non-let-bound local variables."))
- | _,_ ->
- if is_top
- then
- typ_error l ("Cannot assign to " ^ i ^" with type " ^ t_to_string t ^
- ". Assignment must be to registers or non-parameter, non-let-bound local variables.")
- else
- (LEXP_aux(lexp,(l,constrained_annot t cs_o)),t,true,Envmap.empty,Emp_local,[],nob,pure_e,pure_e))
- | _ ->
- let u = new_t() in
- let t = {t=Tapp("reg",[TA_typ u])} in
- let bounds = extract_bounds d_env i u in
- let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in
- (LEXP_aux(lexp,(l,tannot)),u,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e))
- | LEXP_memory(id,exps) ->
- let i = id_to_string id in
- (match Envmap.apply t_env i with
- | Some(Base((parms,t),tag,cs,ef,_,_)) ->
- let t,cs,ef,_ = subst parms false false t cs ef in
- (match t.t with
- | Tfn(apps,out,_,ef') ->
- (match ef'.effect with
- | Eset effects ->
- let mem_write = List.exists (fun (BE_aux(b,_)) ->
- match b with | BE_wmem -> true | _ -> false) effects in
- let memv_write = List.exists (fun (BE_aux(b,_)) ->
- match b with |BE_wmv -> true | _ -> false) effects in
- let reg_write = List.exists (fun (BE_aux(b,_)) ->
- match b with | BE_wreg -> true | _ -> false) effects in
- if (mem_write || memv_write || reg_write)
- then
- let app,cs_a = get_abbrev d_env apps in
- let out,cs_o = get_abbrev d_env out in
- let cs_call = cs@cs_o@cs_a in
- (match app.t with
- | Ttup ts | Tabbrev(_,{t=Ttup ts}) ->
- let (args,item_t) = ((fun ts -> (List.rev (List.tl ts), List.hd ts)) (List.rev ts)) in
- let args_t = {t = Ttup args} in
- let (es, cs_es, ef_es) =
- match args,exps with
- | [],[] -> ([],[],pure_e)
- | [],[e] -> let (e',_,_,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t unit_t e
- in ([e'],cs_e,ef_e)
- | [],es -> typ_error l ("Expected no arguments for assignment function " ^ i)
- | args,[] ->
- typ_error l ("Expected arguments with types " ^ (t_to_string args_t) ^
- "for assignment function " ^ i)
- | args,es ->
- (match check_exp envs imp_param true true ret_t args_t
- (E_aux (E_tuple exps,(l,NoTyp))) with
- | (E_aux(E_tuple es,(l',tannot)),_,_,cs_e,_,ef_e) -> (es,cs_e,ef_e)
- | _ ->
- raise (Reporting_basic.err_unreachable l
- "Gave check_exp a tuple, didn't get a tuple back"))
- in
- let ef_all = union_effects ef' ef_es in
- (LEXP_aux(LEXP_memory(id,es),(l,Base(([],out),tag,cs_call,ef',ef_all,nob))),
- item_t,false,Envmap.empty,tag,cs_call@cs_es,nob,ef',ef_all)
- | _ ->
- let e = match exps with
- | [] -> E_aux(E_lit(L_aux(L_unit,l)),(l,NoTyp))
- | [(E_aux(E_lit(L_aux(L_unit,_)),(_,NoTyp)) as e)] -> e
- | es -> typ_error l ("Expected no arguments for assignment function " ^ i) in
- let (e,_,_,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t apps e in
- let ef_all = union_effects ef ef_e in
- (LEXP_aux(LEXP_memory(id,[e]),(l,Base(([],out),tag,cs_call,ef,ef_all,nob))),
- app,false,Envmap.empty,tag,cs_call@cs_e,nob,ef,ef_all))
- else typ_error l ("Assignments require functions with a wmem, wmv, or wreg effect")
- | _ -> typ_error l ("Assignments require functions with a wmem, wmv, or wreg effect"))
- | _ ->
- typ_error l ("Assignments require a function here, found " ^ i ^ " which has type " ^ (t_to_string t)))
- | _ -> typ_error l ("Unbound identifier " ^ i))
- | LEXP_cast(typ,id) ->
- let i = id_to_string id in
- let ty = typ_to_t envs false false typ in
- let ty = typ_subst tp_env false ty in
- let new_bounds = extract_bounds d_env i ty in
- (match Envmap.apply t_env i with
- | Some(Base((parms,t),tag,cs,_,_,bounds)) ->
- let t,cs,ef,_ =
- match tag with | External _ | Emp_global -> subst parms false false t cs pure_e
- | _ -> t,cs,{effect=Eset[BE_aux(BE_lset,l)]},Envmap.empty
+ annot_pat (P_tup (List.rev tpats)) typ, env
+ | _ -> typ_error l "Cannot bind tuple pattern against non tuple type"
+ end
+ | P_app (f, pats) when Env.is_union_constructor f env ->
+ begin
+ let (typq, ctor_typ) = Env.get_val_spec f env in
+ let quants = quant_items typq in
+ let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with
+ | Typ_tup typs -> typs
+ | _ -> [typ]
+ in
+ match Env.expand_synonyms env ctor_typ with
+ | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) ->
+ begin
+ try
+ typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for pattern " ^ string_of_typ typ);
+ let unifiers = unify l env ret_typ typ in
+ typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
+ let arg_typ' = subst_unifiers unifiers arg_typ in
+ let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
+ if (match quants' with [] -> false | _ -> true)
+ then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
+ else ();
+ let ret_typ' = subst_unifiers unifiers ret_typ in
+ let tpats, env =
+ try List.fold_left2 bind_tuple_pat ([], env) pats (untuple arg_typ') with
+ | Invalid_argument _ -> typ_error l "Union constructor pattern arguments have incorrect length"
+ in
+ annot_pat (P_app (f, List.rev tpats)) typ, env
+ with
+ | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m)
+ end
+ | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f)
+ end
+ | P_app (f, _) when not (Env.is_union_constructor f env) ->
+ typ_error l (string_of_id f ^ " is not a union constructor in pattern " ^ string_of_pat pat)
+ | _ ->
+ let (inferred_pat, env) = infer_pat env pat in
+ subtyp l env (pat_typ_of inferred_pat) typ;
+ switch_typ inferred_pat typ, env
+
+and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
+ let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in
+ match pat_aux with
+ | P_id v ->
+ begin
+ match Env.lookup_id v env with
+ | Local (Immutable, _) | Unbound ->
+ typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation")
+ | Local (Mutable, _) | Register _ ->
+ typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
+ | Enum enum -> annot_pat (P_id v) enum, env
+ end
+ | P_typ (typ_annot, pat) ->
+ let (typed_pat, env) = bind_pat env pat typ_annot in
+ annot_pat (P_typ (typ_annot, typed_pat)) typ_annot, env
+ | P_lit lit ->
+ annot_pat (P_lit lit) (infer_lit env lit), env
+ | P_vector_concat (pat :: pats) ->
+ let fold_pats (pats, env) pat =
+ let inferred_pat, env = infer_pat env pat in
+ pats @ [inferred_pat], env
+ in
+ let (inferred_pat :: inferred_pats), env = List.fold_left fold_pats ([], env) (pat :: pats) in
+ let (_, len, _, vtyp) = destructure_vec_typ l env (pat_typ_of inferred_pat) in
+ let fold_len len pat =
+ let (_, len', _, vtyp') = destructure_vec_typ l env (pat_typ_of pat) in
+ typ_equality l env vtyp vtyp';
+ nsum len len'
+ in
+ let len = nexp_simp (List.fold_left fold_len len inferred_pats) in
+ annot_pat (P_vector_concat (inferred_pat :: inferred_pats)) (lvector_typ env len vtyp), env
+ | _ -> typ_error l ("Couldn't infer type of pattern " ^ string_of_pat pat)
+
+and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) =
+ let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, Some (env, mk_typ (Typ_id (mk_id "unit")), no_effect))) in
+ let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in
+ let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
+ let has_typ v env =
+ match Env.lookup_id v env with
+ | Local (Mutable, _) | Register _ -> true
+ | _ -> false
+ in
+ match lexp_aux with
+ | LEXP_field (LEXP_aux (flexp, _), field) ->
+ begin
+ let infer_flexp = function
+ | LEXP_id v ->
+ begin match Env.lookup_id v env with
+ | Register typ -> typ, LEXP_id v
+ | _ -> typ_error l "l-expression field is not a register"
+ end
+ | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) ->
+ begin
+ (* Check: is this ok if the vector is immutable? *)
+ let is_immutable, vtyp = match Env.lookup_id v env with
+ | Unbound -> typ_error l "Cannot assign to element of unbound vector"
+ | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
+ | Local (Immutable, vtyp) -> true, vtyp
+ | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
+ in
+ let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in
+ let E_aux (E_app (_, [_; inferred_exp]), _) = access in
+ typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp)
+ end
+ in
+ let regtyp, inferred_flexp = infer_flexp flexp in
+ match Env.expand_synonyms env regtyp with
+ | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env ->
+ let base, top, ranges = Env.get_regtyp regtyp_id env in
+ let range, _ =
+ try List.find (fun (_, id) -> Id.compare id field = 0) ranges with
+ | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp_id)
in
- let t,cs' = get_abbrev d_env t in
- let t_actual = match t.t with | Tabbrev(_,t) -> t | _ -> t in
- let bs = merge_bounds bounds new_bounds in
- (match t_actual.t,is_top with
- | Tapp("register",[TA_typ u]),true ->
- let t',cs = type_consistent (Expr l) d_env Require false ty u in
- let ef = {effect=Eset[BE_aux(BE_wreg,l)]} in
- (LEXP_aux(lexp,(l,(Base(([],t),External (Some i),cs,ef,pure_e,nob)))),ty,false,
- Envmap.empty,External (Some i),[],nob,ef,ef)
- | Tapp("register",[TA_typ u]),false ->
- (LEXP_aux(lexp,(l,(Base(([],t), Emp_global, cs', pure_e,pure_e,nob)))), t,false,
- Envmap.empty, Emp_global, [],nob,pure_e,pure_e)
- | Tapp("reg",[TA_typ u]),_ ->
- let t',cs = type_consistent (Expr l) d_env Require false ty u in
- (LEXP_aux(lexp,(l,(Base(([],t),Emp_set,cs,ef,pure_e,bs)))),ty,false,
- Envmap.empty,Emp_set,[],bs,ef,ef)
- | Tapp("vector",_),false ->
- (LEXP_aux(lexp,(l,(Base(([],t),tag,cs,ef,pure_e,bs)))),ty,true,Envmap.empty,Emp_set,[],bs,ef,ef)
- | Tuvar _,_ ->
- let u' = {t=Tapp("reg",[TA_typ ty])} in
- equate_t t u';
- (LEXP_aux(lexp,(l,(Base((([],u'),Emp_set,cs,ef,pure_e,bs))))),
- ty,false,Envmap.empty,Emp_set,[],bs,ef,ef)
- | (Tfn _ ,_) ->
- (match tag with
- | External _ | Spec | Emp_global ->
- let u' = {t=Tapp("reg",[TA_typ ty])} in
- let tannot = (Base(([],u'),Emp_intro,[],pure_e,pure_e,new_bounds)) in
- (LEXP_aux(lexp,(l,tannot)),u',
- false,Envmap.from_list [i,tannot],Emp_intro,[],new_bounds,pure_e,pure_e)
- | _ ->
- typ_error l ("Cannot assign to " ^ i ^ " with type " ^ t_to_string t))
- | _,_ ->
- if is_top
- then typ_error l
- ("Cannot assign to " ^ i ^ " with type " ^ t_to_string t ^
- ". May only assign to registers, and non-paremeter, non-let bound local variables")
- else
- (* TODO, make sure this is a record *)
- (LEXP_aux(lexp,(l,(Base(([],t),Emp_local,cs,pure_e,pure_e,nob)))),
- ty,false,Envmap.empty,Emp_local,[],nob,pure_e,pure_e))
- | _ ->
- let t = {t=Tapp("reg",[TA_typ ty])} in
- let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,new_bounds)) in
- (LEXP_aux(lexp,(l,tannot)),ty,false,Envmap.from_list [i,tannot],Emp_intro,[],new_bounds,pure_e,pure_e))
- | LEXP_tup tuples ->
- if is_top
- then
- if tuples = []
- then typ_error l "Attempt to set an empty tuple, which is not allowed"
- else
- let tuple_checks = List.map (check_lexp envs imp_param ret_t true) tuples in
- let tuple_vs = List.map (fun (le,_,_,_,_,_,_,_,_) -> le) tuple_checks in
- let tuple_typs = List.map (fun (_,le_t,_,_,_,_,_,_,_) -> le_t) tuple_checks in
- let tuple_tags = List.map (fun (_,_,_,_,tag,_,_,_,_) -> tag) tuple_checks in
- let env = List.fold_right (fun (_,_,_,env,_,_,_,_,_) envf -> Envmap.union env envf)
- tuple_checks Envmap.empty in
- let cs = List.fold_right (fun (_,_,_,_,_,cs,_,_,_) csf -> cs @csf) tuple_checks [] in
- let bounds = List.fold_right (fun (_,_,_,_,_,_,bs,_,_) bf -> merge_bounds bs bf) tuple_checks nob in
- let efr = List.fold_right (fun (_,_,_,_,_,_,_,_,efr) efrf -> union_effects efr efrf) tuple_checks pure_e in
- let ty = mk_tup tuple_typs in
- let tag = Tuple_assign tuple_tags in
- let tannot = (Base(([],ty),tag,[],pure_e,efr,bounds)) in
- (LEXP_aux (LEXP_tup tuple_vs, (l,tannot)), ty,false,env, tag,cs,bounds,pure_e,efr)
- else typ_error l "Tuples in assignments may only be at the top level or within other tuples"
- | LEXP_vector(vec,acc) ->
- let (vec',vec_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in
- let vec_t,cs' = get_abbrev d_env vec_t in
- let vec_actual,writing_reg_bit = match vec_t.t with
- | Tapp("register",[TA_typ {t=Tabbrev(_,t)}]) | Tapp("register",[TA_typ t])
- | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true
- | Tabbrev(_,t) -> t,false | _ -> vec_t,false in
- (match vec_actual.t with
- | Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t]) ->
- let acc_n = new_n () in
- let acc_t,cs_t = match ord.order with
- | Oinc -> mk_atom acc_n, [LtEq(Specc l, Require, base, acc_n);
- LtEq(Specc l, Require, acc_n, (mk_sub (mk_add base rise) n_one))]
- | Odec -> mk_atom acc_n, [GtEq(Specc l, Require, base, acc_n);
- GtEq(Specc l, Require, acc_n, (mk_sub (mk_add base n_one) rise))]
- | _ -> typ_error l ("Assignment to one vector element requires a non-polymorphic order")
+ let vec_typ = match range, Env.get_default_order env with
+ | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) ->
+ dvector_typ env (nconstant n) (nconstant 1) (mk_typ (Typ_id (mk_id "bit")))
+ | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) ->
+ dvector_typ env (nconstant n) (nconstant (n - m + 1)) (mk_typ (Typ_id (mk_id "bit")))
+ | _, _ -> typ_error l "Not implemented this register field type yet..."
in
- let (e,acc_t',_,cs',_,ef_e) = check_exp envs imp_param false false ret_t acc_t acc in
- let item_t_act,_ = get_abbrev d_env item_t in
- let item_t,add_reg_write,reg_still_required =
- match item_t_act.t with
- | Tapp("register",[TA_typ t]) | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true,false
- | Tapp("reg",[TA_typ t]) -> t,false,false
- | _ -> item_t,false,not(writing_reg_bit) in
- let efl,tag = if add_reg_write || writing_reg_bit then (add_effect (BE_aux(BE_wreg,l)) efl,External None)
- else match tag with | External _ -> (efl,Emp_local) | _ -> (efl,tag) in
- let efr = union_effects efl (union_effects efr ef_e) in
- if is_top && reg_still_required && reg_required && not(writing_reg_bit)
- then typ_error l "Assignment expected a register or non-parameter non-letbound identifier to mutate"
- else
- (LEXP_aux(LEXP_vector(vec',e),(l,Base(([],item_t_act),tag,csi,efl,efr,nob))),
- item_t_act,reg_required && reg_still_required,
- env,tag,csi@cs'@cs_t,bounds,efl,efr)
- | Tuvar _ ->
- typ_error l "Assignment expected a vector with a known order, try adding an annotation."
- | _ -> typ_error l ("Assignment expected vector, found assignment to type " ^ (t_to_string vec_t)))
- | LEXP_vector_range(vec,e1,e2)->
- let (vec',vec_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in
- let vec_t,cs = get_abbrev d_env vec_t in
- let vec_actual,writing_reg_bits = match vec_t.t with
- | Tapp("register",[TA_typ {t=Tabbrev(_,t)}]) | Tapp("register",[TA_typ t])
- | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true
- | Tabbrev(_,t) -> t,false | _ -> vec_t,false in
- let vec_actual,add_reg_write,reg_still_required,cs =
- match vec_actual.t,is_top with
- | Tapp("register",[TA_typ t]),true ->
- (match get_abbrev d_env t with | {t=Tabbrev(_,t)},cs' | t,cs' -> t,true,false,cs@cs')
- | Tapp("register",[TA_typ t]),false -> vec_actual,false,false,cs
- | Tapp("reg",[TA_typ t]),_ ->
- (match get_abbrev d_env t with | {t=Tabbrev(_,t)},cs' | t,cs' -> t,false,false,cs@cs')
- | _ -> vec_actual,false,true,cs in
- (match vec_actual.t with
- | Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ t])
- | Tapp("register", [TA_typ {t= Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ t])}]) ->
- let size_e1,size_e2 = new_n(),new_n() in
- let e1_t = {t=Tapp("atom",[TA_nexp size_e1])} in
- let e2_t = {t=Tapp("atom",[TA_nexp size_e2])} in
- let (e1',e1_t',_,cs1,_,ef_e) = check_exp envs imp_param false false ret_t e1_t e1 in
- let (e2',e2_t',_,cs2,_,ef_e') = check_exp envs imp_param false false ret_t e2_t e2 in
- let len = new_n() in
- let needs_reg = match t.t with
- | Tapp("reg",_) -> false
- | Tapp("register",_) -> false
- | _ -> true in
- let cs_t,res_t = match ord.order with
- | Oinc -> ([LtEq((Expr l),Require,base,size_e1);
- LtEq((Expr l),Require,size_e1, size_e2);
- LtEq((Expr l),Require,size_e2, rise);
- Eq((Expr l),len, mk_add (mk_sub size_e2 size_e1) n_one)],
- if is_top
- then {t=Tapp("vector",[TA_nexp size_e1;TA_nexp len;TA_ord ord;TA_typ t])}
- else vec_actual)
- | Odec -> ([GtEq((Expr l),Require,base,size_e1);
- GtEq((Expr l),Require,size_e1,size_e2);
- GtEq((Expr l),Require,size_e2,mk_sub base rise);
- Eq((Expr l),len, mk_add (mk_sub size_e1 size_e2) n_one)],
- if is_top
- then {t=Tapp("vector",[TA_nexp size_e1;TA_nexp len;TA_ord ord; TA_typ t])}
- else vec_actual)
- | _ -> typ_error l ("Assignment to a range of vector elements requires either inc or dec order")
+ let checked_exp = crule check_exp env exp vec_typ in
+ annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp (mk_effect [BE_wreg]), field)) vec_typ) checked_exp, env
+ | _ -> typ_error l "Field l-expression has invalid type"
+ end
+ | LEXP_memory (f, xs) ->
+ check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env
+ | LEXP_cast (typ_annot, v) ->
+ let checked_exp = crule check_exp env exp typ_annot in
+ let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in
+ annot_assign tlexp checked_exp, env'
+ | LEXP_id v when has_typ v env ->
+ begin match Env.lookup_id v env with
+ | Local (Mutable, vtyp) | Register vtyp ->
+ let checked_exp = crule check_exp env exp vtyp in
+ let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in
+ annot_assign tlexp checked_exp, env'
+ | _ -> assert false
+ end
+ | _ ->
+ let inferred_exp = irule infer_exp env exp in
+ let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in
+ annot_assign tlexp inferred_exp, env'
+
+and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
+ let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in
+ let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
+ match lexp_aux with
+ | LEXP_id v ->
+ begin match Env.lookup_id v env with
+ | Local (Immutable, _) | Enum _ ->
+ typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
+ | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env
+ | Register vtyp -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ (mk_effect [BE_wreg]), env
+ | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env
+ end
+ | LEXP_cast (typ_annot, v) ->
+ begin
+ match Env.lookup_id v env with
+ | Local (Immutable, _) | Enum _ ->
+ typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
+ | Local (Mutable, vtyp) ->
+ begin
+ subtyp l env typ typ_annot;
+ subtyp l env typ_annot vtyp;
+ annot_lexp (LEXP_cast (typ_annot, v)) typ, env
+ end
+ | Register vtyp ->
+ begin
+ subtyp l env typ typ_annot;
+ subtyp l env typ_annot vtyp;
+ annot_lexp_effect (LEXP_cast (typ_annot, v)) typ (mk_effect [BE_wreg]), env
+ end
+ | Unbound ->
+ begin
+ subtyp l env typ typ_annot;
+ annot_lexp (LEXP_cast (typ_annot, v)) typ, Env.add_local v (Mutable, typ_annot) env
+ end
+ end
+ | LEXP_tup lexps ->
+ begin
+ let (Typ_aux (typ_aux, _)) = typ in
+ match typ_aux with
+ | Typ_tup typs ->
+ let bind_tuple_lexp (tlexps, env) lexp typ =
+ let tlexp, env = bind_lexp env lexp typ in tlexp :: tlexps, env
in
- let efl,tag =
- if add_reg_write || writing_reg_bits
- then (add_effect (BE_aux(BE_wreg,l)) efl,External None)
- else match tag with | External _ -> (efl,Emp_local) | _ -> (efl,tag) in
- let cs = cs_t@cs@cs1@cs2 in
- let ef = union_effects efl (union_effects efr (union_effects ef_e ef_e')) in
- if is_top && reg_required && reg_still_required && needs_reg && not(writing_reg_bits)
- then typ_error l "Assignment requires a register or a non-parameter, non-letbound local identifier"
- else (LEXP_aux(LEXP_vector_range(vec',e1',e2'),(l,Base(([],res_t),tag,cs,efl,ef,nob))),
- res_t,reg_required&&reg_still_required && needs_reg,env,tag,cs,bounds,efl,ef)
- | Tuvar _ ->
- typ_error l
- "Assignement to a range of items requires a vector with a known order, try adding an annotation."
- | _ -> typ_error l ("Assignment expected vector, found assignment to type " ^ (t_to_string vec_t)))
- | LEXP_field(vec,id)->
- let (vec',item_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in
- let vec_t = match vec' with
- | LEXP_aux(_,(l',Base((parms,t),_,_,_,_,_))) -> t
- | _ -> item_t in
- let fi = id_to_string id in
- (match vec_t.t with
- | Tid i | Tabbrev({t=Tid i},_) | Tabbrev({t=Tapp(i,_)},_) | Tapp(i,_)->
- (match lookup_record_typ i d_env.rec_env with
- | Some(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) ->
- let (ts,cs,eft,subst_env) = subst params false false t cs eft in
- (match lookup_field_type fi r with
- | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi)
- | Some t ->
- let eft = if rec_kind = Register then add_effect (BE_aux(BE_wreg, l)) eft else eft in
- let efr = union_effects eft efr in
- let ft = typ_subst subst_env false t in
- let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee false ts vec_t in
- (LEXP_aux(LEXP_field(vec',id),(l,(Base(([],ft),tag,csi@cs,eft,efr,nob)))),
- ft,false,env,tag,csi@cs@cs_sub',bounds,eft,efr))
- | _ ->
- typ_error l
- ("Expected a register or struct for this update, instead found an expression with type " ^ i))
- | _ -> typ_error l ("Expected a register binding here, found " ^ (t_to_string item_t)))
-
-and check_lbind envs imp_param is_top_level opt_ret_t emp_tag (LB_aux(lbind,(l,annot)))
- : tannot letbind * tannot emap * nexp_range list * bounds_env * effect =
- let Env(d_env,t_env,b_env,tp_env) = envs in
- match lbind with
- | LB_val_explicit(typ,pat,e) ->
- let tan = typschm_to_tannot envs false false typ emp_tag in
- (match tan with
- | Base((params,t),tag,cs,ef,_,b) ->
- let t,cs,ef,tp_env' = subst params false true t cs ef in
- let envs' = (Env(d_env,t_env,b_env,Envmap.union tp_env tp_env')) in
- let (pat',env,cs1,bounds,u) = check_pattern envs' emp_tag t pat in
- let ret_t = match opt_ret_t with Some t -> t | None -> t in
- let (e,t,_,cs2,_,ef2) = check_exp envs' imp_param true true ret_t t e in
- let (cs,map) = if is_top_level then resolve_constraints (cs@cs1@cs2) else (cs@cs1@cs2,None) in
- let ef = union_effects ef ef2 in
- (*let _ = Printf.eprintf "checking tannot in let1\n" in*)
- let tannot =
- if is_top_level
- then check_tannot l (Base((params,t),tag,cs,ef,pure_e,
- match map with | None -> bounds | Some m -> add_map_to_bounds m bounds))
- None cs ef (*in top level, must be pure_e*)
- else (Base ((params,t),tag,cs,pure_e,ef,bounds))
- in
- (*let _ = Printf.eprintf "done checking tannot in let1\n" in*)
- (LB_aux (LB_val_explicit(typ,pat',e),(l,tannot)),env,cs,merge_bounds b_env bounds,ef)
- | NoTyp | Overload _ -> raise (Reporting_basic.err_unreachable l "typschm_to_tannot failed to produce a Base"))
- | LB_val_implicit(pat,e) ->
- let (pat',env,cs1,bounds,u) = check_pattern envs emp_tag (new_t ()) pat in
- let ret_t = match opt_ret_t with Some t -> t | None -> u in
- let (e,t',_,cs2,_,ef) = check_exp envs imp_param true true ret_t u e in
- let (cs,map) = if is_top_level then resolve_constraints (cs1@cs2) else (cs1@cs2),None in
- (*let _ = Printf.eprintf "checking tannot in let2\n" in*)
- let tannot =
- if is_top_level
- then check_tannot l (Base(([],t'),emp_tag,cs,ef,pure_e,
- match map with | None -> bounds | Some m -> add_map_to_bounds m bounds))
- None cs ef (* see above *)
- else (Base (([],t'),emp_tag,cs,pure_e,ef,merge_bounds bounds b_env))
- in
- (*let _ = Printf.eprintf "done checking tannot in let2\n" in*)
- (LB_aux (LB_val_implicit(pat',e),(l,tannot)), env,cs,merge_bounds bounds b_env,ef)
-
-let check_record_typ envs (id: string) (typq : typquant) (fields : (Ast.typ * id) list)
- : (tannot * (string * typ) list) =
- let (params,typarms,constraints) = typq_to_params envs typq in
- let ty = match typarms with | [] -> {t = Tid id} | parms -> {t = Tapp(id,parms)} in
- let tyannot = Base((params,ty),Emp_global,constraints,pure_e,pure_e,nob) in
- let fields' = List.map (fun (ty,i)->(id_to_string i),(typ_to_t envs false false ty)) fields in
- (tyannot, fields')
-
-let check_variant_typ envs (id: string) typq arms =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- let (params,typarms,constraints) = typq_to_params envs typq in
- let num_arms = List.length arms in
- let ty = match params with
- | [] -> {t=Tid id}
- | params -> {t = Tapp(id, typarms) }in
- let tyannot = Base((params,ty),Constructor num_arms,constraints,pure_e,pure_e,nob) in
- let arm_t input = Base((params,{t=Tfn(input,ty,IP_none,pure_e)}),Constructor num_arms,constraints,pure_e,pure_e,nob) in
- let arms' = List.map
- (fun (Tu_aux(tu,l')) ->
- match tu with
- | Tu_id i -> ((id_to_string i),(arm_t unit_t))
- | Tu_ty_id(typ,i)-> ((id_to_string i),(arm_t (typ_to_t envs false false typ))))
- arms in
- let t_env = List.fold_right (fun (id,tann) t_env -> Envmap.insert t_env (id,tann)) arms' t_env in
- tyannot, t_env
-
-let check_enum_type envs (id: string) ids =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- let ids' = List.map id_to_string ids in
- let max = (List.length ids') -1 in
- let ty = Base (([],{t = Tid id }),Enum max,[],pure_e,pure_e,nob) in
- let t_env = List.fold_right (fun id t_env -> Envmap.insert t_env (id,ty)) ids' t_env in
- let enum_env = Envmap.insert d_env.enum_env (id,ids') in
- ty, t_env, enum_env
-
-let check_register_type envs l (id: string) base top ranges =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- let basei = normalize_nexp(anexp_to_nexp envs base) in
- let topi = normalize_nexp(anexp_to_nexp envs top) in
- match basei.nexp,topi.nexp with
- | Nconst b, Nconst t ->
- if (le_big_int b t) then (
- let ty = {t = Tapp("vector",[TA_nexp basei; TA_nexp (mk_c(add_big_int (sub_big_int t b) (big_int_of_int 1)));
- TA_ord({order = Oinc}); TA_typ({t = Tid "bit"});])} in
- let rec range_to_type_inc (BF_aux(idx,l)) =
- (match idx with
- | BF_single i ->
- if (le_big_int b (big_int_of_int i)) && (le_big_int (big_int_of_int i) t)
- then {t = Tid "bit"}, i, 1
- else typ_error l
- ("register type declaration " ^ id ^
- " contains a field specification outside of the declared register size")
- | BF_range(i1,i2) ->
- if i1<i2
- then
- if (le_big_int b (big_int_of_int i1)) && (le_big_int (big_int_of_int i2) t)
- then let size = i2 - i1 + 1 in
- ({t=Tapp("vector",[TA_nexp (mk_c_int i1); TA_nexp (mk_c_int size);
- TA_ord({order=Oinc}); TA_typ {t=Tid "bit"}])}, i1, size)
- else typ_error l ("register type declaration " ^ id
- ^ " contains a field specification outside of the declared register size")
- else typ_error l ("register type declaration " ^ id ^ " is not consistently increasing")
- | BF_concat(bf1, bf2) ->
- (match (range_to_type_inc bf1, range_to_type_inc bf2) with
- | ({t = Tid "bit"}, start, size1),({t= Tid "bit"}, start2, size2)
- | (({t = Tid "bit"}, start, size1), ({t= Tapp("vector", _)}, start2, size2))
- | (({t=Tapp("vector", _)}, start, size1), ({t=Tid "bit"}, start2, size2))
- | (({t=Tapp("vector",_)}, start, size1), ({t=Tapp("vector",_)}, start2, size2)) ->
- if start < start2
- then let size = size1 + size2 in
- ({t=Tapp("vector", [TA_nexp (mk_c_int start); TA_nexp (mk_c_int size);
- TA_ord({order = Oinc}); TA_typ {t=Tid"bit"}])}, start, size)
- else typ_error l ("register type declaration " ^ id ^ " is not consistently increasing")
- | _ -> raise (Reporting_basic.err_unreachable l "range_to_type returned something odd")))
- in
- let franges =
- List.map
- (fun (bf,id) ->
- let (bf_t, _, _) = range_to_type_inc bf in ((id_to_string id),bf_t))
- ranges
- in
- let tannot = into_register d_env (Base(([],ty),External None,[],pure_e,pure_e,nob)) in
- tannot, franges)
- else (
- let ty = {t = Tapp("vector",[TA_nexp basei; TA_nexp (mk_c(add_big_int (sub_big_int b t) one));
- TA_ord({order = Odec}); TA_typ({t = Tid "bit"});])} in
- let rec range_to_type_dec (BF_aux(idx,l)) =
- (match idx with
- | BF_single i ->
- if (ge_big_int b (big_int_of_int i)) && (ge_big_int (big_int_of_int i) t)
- then {t = Tid "bit"}, i, 1
- else typ_error l
- ("register type declaration " ^ id ^
- " contains a field specification outside of the declared register size")
- | BF_range(i1,i2) ->
- if i1>i2
- then
- if (ge_big_int b (big_int_of_int i1)) && (ge_big_int (big_int_of_int i2) t)
- then let size = (i1 - i2) + 1 in
- ({t=Tapp("vector",[TA_nexp (mk_c_int i1); TA_nexp (mk_c_int size);
- TA_ord({order=Odec}); TA_typ {t=Tid "bit"}])}, i1, size)
- else typ_error l ("register type declaration " ^ id
- ^ " contains a field specification outside of the declared register size")
- else typ_error l ("register type declaration " ^ id ^ " is not consistently decreasing")
- | BF_concat(bf1, bf2) ->
- (match (range_to_type_dec bf1, range_to_type_dec bf2) with
- | ({t = Tid "bit"}, start, size1),({t= Tid "bit"}, start2, size2)
- | (({t = Tid "bit"}, start, size1), ({t= Tapp("vector", _)}, start2, size2))
- | (({t=Tapp("vector", _)}, start, size1), ({t=Tid "bit"}, start2, size2))
- | (({t=Tapp("vector",_)}, start, size1), ({t=Tapp("vector",_)}, start2, size2)) ->
- if start > start2
- then let size = size1 + size2 in
- ({t=Tapp("vector", [TA_nexp (mk_c_int start); TA_nexp (mk_c_int size);
- TA_ord({order = Oinc}); TA_typ {t=Tid"bit"}])}, start, size)
- else typ_error l ("register type declaration " ^ id ^ " is not consistently decreasing")
- | _ -> raise (Reporting_basic.err_unreachable l "range_to_type has returned something odd")))
- in
- let franges =
- List.map
- (fun (bf,id) -> let (bf_t, _, _) = range_to_type_dec bf in (id_to_string id, bf_t))
- ranges
- in
- let tannot = into_register d_env (Base(([],ty),External None,[],pure_e,pure_e,nob)) in
- tannot, franges)
- | _,_ -> raise (Reporting_basic.err_unreachable l "Nexps in register declaration do not evaluate to constants")
-
-(*val check_type_def : envs -> (tannot type_def) -> (tannot type_def) envs_out*)
-let check_type_def envs (TD_aux(td,(l,annot))) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match td with
- | TD_abbrev(id,nmscm,typschm) ->
- let tan = typschm_to_tannot envs false false typschm Emp_global in
- (TD_aux(td,(l,tan)),
- Env( { d_env with abbrevs = Envmap.insert d_env.abbrevs ((id_to_string id),tan)},t_env,b_env,tp_env))
- | TD_record(id,nmscm,typq,fields,_) ->
- let id' = id_to_string id in
- let (tyannot, fields') = check_record_typ envs id' typq fields in
- (TD_aux(td,(l,tyannot)),
- Env({d_env with rec_env = (id',Record,tyannot,fields')::d_env.rec_env},t_env,b_env,tp_env))
- | TD_variant(id,nmscm,typq,arms,_) ->
- let id' = id_to_string id in
- let tyannot, t_env = check_variant_typ envs id' typq arms in
- (TD_aux(td,(l,tyannot)),(Env (d_env,t_env,b_env,tp_env)))
- | TD_enum(id,nmscm,ids,_) ->
- let id' = id_to_string id in
- let ty,t_env,enum_env = check_enum_type envs id' ids in
- (TD_aux(td,(l,ty)),Env({d_env with enum_env = enum_env;},t_env,b_env,tp_env))
- | TD_register(id,base,top,ranges) ->
- let id' = id_to_string id in
- let (tannot, franges) = check_register_type envs l id' base top ranges in
- (TD_aux(td,(l,tannot)),
- Env({d_env with rec_env = ((id',Register,tannot,franges)::d_env.rec_env);
- abbrevs = Envmap.insert d_env.abbrevs (id',tannot)},t_env,b_env,tp_env))
-
-(*val check_kind_def : envs -> (tannot kind_def) -> (tannot kind_def) envs_out*)
-let check_kind_def envs (KD_aux(kd,(l,annot))) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match kd with
- | KD_nabbrev(kind,id,nmscm,n) ->
- let id' = id_to_string id in
- let n = normalize_nexp (anexp_to_nexp envs n) in
- (KD_aux(kd,(l,annot)),
- Env( { d_env with nabbrevs = Envmap.insert d_env.nabbrevs (id', (mk_nid id' n))},t_env,b_env,tp_env))
- | KD_abbrev(kind,id,nmscm,typschm) ->
- let tan = typschm_to_tannot envs false false typschm Emp_global in
- (KD_aux(kd,(l,tan)),
- Env( { d_env with abbrevs = Envmap.insert d_env.abbrevs ((id_to_string id),tan)},t_env,b_env,tp_env))
- | KD_record(kind,id,nmscm,typq,fields,_) ->
- let id' = id_to_string id in
- let (tyannot, fields') = check_record_typ envs id' typq fields in
- (KD_aux(kd,(l,tyannot)),Env({d_env with rec_env = (id',Record,tyannot,fields')::d_env.rec_env},t_env,b_env,tp_env))
- | KD_variant(kind,id,nmscm,typq,arms,_) ->
- let id' = id_to_string id in
- let tyannot, t_env = check_variant_typ envs id' typq arms in
- (KD_aux(kd,(l,tyannot)),(Env (d_env,t_env,b_env,tp_env)))
- | KD_enum(kind,id,nmscm,ids,_) ->
- let id' = id_to_string id in
- let ty,t_env,enum_env = check_enum_type envs id' ids in
- (KD_aux(kd,(l,ty)),Env({d_env with enum_env = enum_env;},t_env,b_env,tp_env))
- | KD_register(kind,id,base,top,ranges) ->
- let id' = id_to_string id in
- let (tannot, franges) = check_register_type envs l id' base top ranges in
- (KD_aux(kd,(l,tannot)),
- Env({d_env with rec_env = ((id',Register,tannot,franges)::d_env.rec_env);
- abbrevs = Envmap.insert d_env.abbrevs (id',tannot)},t_env,b_env,tp_env))
-
-let check_val_spec envs (VS_aux(vs,(l,annot))) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match vs with
- | VS_val_spec(typs,id) ->
- let tannot = typschm_to_tannot envs true true typs Spec in
- (VS_aux(vs,(l,tannot)),
- (*Should maybe add to bounds here*)
- Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env))
- | VS_extern_no_rename(typs,id) ->
- let tannot = typschm_to_tannot envs true true typs (External None) in
- (VS_aux(vs,(l,tannot)),
- Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env))
- | VS_cast_spec(typs,id) ->
- let tannot = typschm_to_tannot envs true true typs (External None) in
- (VS_aux(VS_val_spec(typs,id),(l,tannot)),
- Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env))
- | VS_extern_spec(typs,id,s) ->
- let tannot = typschm_to_tannot envs true true typs (External (Some s)) in
- (VS_aux(vs,(l,tannot)),
- Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)), b_env,tp_env))
-
-let check_default envs (DT_aux(ds,l)) =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- match ds with
- | DT_kind _ -> ((DT_aux(ds,l)),envs)
- | DT_order ord -> (DT_aux(ds,l), Env({d_env with default_o = (aorder_to_ord ord)},t_env,b_env,tp_env))
- | DT_typ(typs,id) ->
- let tannot = typschm_to_tannot envs false false typs Default in
- (DT_aux(ds,l),
- Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env))
-
-let check_fundef envs (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,annot))) =
- (*let _ = Printf.eprintf "checking fundef\n" in*)
- let Env(d_env,t_env,b_env,tp_env) = envs in
- let _ = reset_fresh () in
- let is_rec = match recopt with
- | Rec_aux(Rec_nonrec,_) -> false
- | Rec_aux(Rec_rec,_) -> true in
- let id = match (List.fold_right
- (fun (FCL_aux((FCL_Funcl(id,pat,exp)),(l,annot))) id' ->
- match id' with
- | Some(id') -> if id' = id_to_string id then Some(id')
- else typ_error l ("Function declaration expects all definitions to have the same name, "
- ^ id_to_string id ^ " differs from other definitions of " ^ id')
- | None -> Some(id_to_string id)) funcls None) with
- | Some id -> id
- | None -> raise (Reporting_basic.err_unreachable l "funcl list might be empty") in
- let in_env = Envmap.apply t_env id in
- let (typ_params,has_spec) = match in_env with
- | Some(Base( (params,u),Spec,constraints,eft,_,_)) -> params,true
- | _ -> [],false in
- let ret_t,param_t,tannot,t_param_env = match tannotopt with
- | Typ_annot_opt_aux(Typ_annot_opt_some(typq,typ),l') ->
- let (ids,_,constraints) = typq_to_params envs typq in
- let t = typ_to_t envs false false typ in
- (*TODO add check that ids == typ_params when has_spec*)
- let t,constraints,_,t_param_env =
- subst (if has_spec then typ_params else ids) true true t constraints pure_e in
- let p_t = new_t () in
- let ef = new_e () in
- t,p_t,Base((ids,{t=Tfn(p_t,t,IP_none,ef)}),Emp_global,constraints,ef,pure_e,nob),t_param_env in
- let cond_kind = if (List.length funcls) = 1 then Solo else Switch in
- let check t_env tp_env imp_param =
- List.split
- (List.map (fun (FCL_aux((FCL_Funcl(id,pat,exp)),(l,_))) ->
- (*let _ = Printf.eprintf "checking function %s : %s -> %s\n"
- (id_to_string id) (t_to_string param_t) (t_to_string ret_t) in*)
- let (pat',t_env',cs_p,b_env',t') = check_pattern (Env(d_env,t_env,b_env,tp_env)) Emp_local param_t pat in
- let _, _ = type_consistent (Patt l) d_env Require false param_t t' in
- let exp',_,_,cs_e,_,ef =
- check_exp (Env(d_env,Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env t_env',
- merge_bounds b_env b_env',tp_env)) imp_param true true ret_t ret_t exp in
- (*let _ = Printf.eprintf "checked function %s : %s -> %s\n"
- (id_to_string id) (t_to_string param_t) (t_to_string ret_t) in
- let _ = Printf.eprintf "constraints were pattern: %s\n expression: %s\n"
- (constraints_to_string cs_p) (constraints_to_string cs_e) in*)
- let cs = CondCons(Fun l,cond_kind,None,cs_p,cs_e) in
- (FCL_aux((FCL_Funcl(id,pat',exp')),(l,(Base(([],ret_t),Emp_global,[cs],ef,pure_e,nob)))),(cs,ef))) funcls) in
- let check_pattern_after_constraints (FCL_aux ((FCL_Funcl (_, pat, _)), _)) =
- check_pattern_after_constraint_res (Env(d_env,t_env,b_env,tp_env)) false param_t pat in
- let update_pattern var (FCL_aux ((FCL_Funcl(id,(P_aux(pat,t)),exp)),annot)) =
- let pat' = match pat with
- | P_lit (L_aux (L_unit,l')) -> P_aux(P_id (Id_aux (Id var, l')), t)
- | P_tup pats -> P_aux(P_tup ((P_aux (P_id (Id_aux (Id var, l)), t))::pats), t)
- | _ -> P_aux(P_tup [(P_aux (P_id (Id_aux (Id var,l)), t));(P_aux(pat,t))], t)
- in (FCL_aux ((FCL_Funcl(id,pat',exp)),annot))
+ let tlexps, env =
+ try List.fold_left2 bind_tuple_lexp ([], env) lexps typs with
+ | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length"
+ in
+ annot_lexp (LEXP_tup tlexps) typ, env
+ | _ -> typ_error l "Cannot bind tuple l-expression against non tuple type"
+ end
+ | LEXP_vector_range (LEXP_aux (LEXP_id v, _), exp1, exp2) ->
+ begin
+ let is_immutable, vtyp = match Env.lookup_id v env with
+ | Unbound -> typ_error l "Cannot assign to element of unbound vector"
+ | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
+ | Local (Immutable, vtyp) -> true, vtyp
+ | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
+ in
+ let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_subrange", [E_aux (E_id v, (l, ())); exp1; exp2]), (l, ()))) in
+ let E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) = access in
+ match typ_of access with
+ | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" ->
+ subtyp l env typ deref_typ;
+ annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env
+ | _ when not is_immutable ->
+ subtyp l env typ (typ_of access);
+ annot_lexp (LEXP_vector_range (annot_lexp (LEXP_id v) vtyp, inferred_exp1, inferred_exp2)) typ, env
+ | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp)
+ end
+ (* Not sure about this case... can the left lexp be anything other than an identifier? *)
+ | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) ->
+ begin
+ let is_immutable, vtyp = match Env.lookup_id v env with
+ | Unbound -> typ_error l "Cannot assign to element of unbound vector"
+ | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
+ | Local (Immutable, vtyp) -> true, vtyp
+ | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
+ in
+ let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in
+ let E_aux (E_app (_, [_; inferred_exp]), _) = access in
+ match typ_of access with
+ | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" ->
+ subtyp l env typ deref_typ;
+ annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env
+ | _ when not is_immutable ->
+ subtyp l env typ (typ_of access);
+ annot_lexp (LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp)) typ, env
+ | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp)
+ end
+ | _ -> typ_error l ("Unhandled l-expression")
+
+and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
+ let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
+ let annot_exp exp typ = annot_exp_effect exp typ no_effect in
+ match exp_aux with
+ | E_nondet exps ->
+ annot_exp (E_nondet (List.map (fun exp -> crule check_exp env exp unit_typ) exps)) unit_typ
+ | E_id v ->
+ begin
+ match Env.lookup_id v env with
+ | Local (_, typ) | Enum typ -> annot_exp (E_id v) typ
+ | Register typ -> annot_exp_effect (E_id v) typ (mk_effect [BE_rreg])
+ | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound")
+ | Union (typq, typ) ->
+ if quant_items typq = []
+ then annot_exp (E_id v) typ
+ else typ_error l ("Cannot infer the type of polymorphic union indentifier " ^ string_of_id v)
+ end
+ | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
+ | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)])))
+ | E_constraint nc ->
+ annot_exp (E_constraint nc) bool_typ
+ | E_return exp ->
+ begin
+ match Env.get_ret_typ env with
+ | Some typ -> annot_exp (E_return (crule check_exp env exp typ)) (mk_typ (Typ_id (mk_id "unit")))
+ | None -> typ_error l "Return found in non-function environment"
+ end
+ | E_field (exp, field) ->
+ begin
+ let inferred_exp = irule infer_exp env exp in
+ match Env.expand_synonyms env (typ_of inferred_exp) with
+ (* Accessing a (bit) field of a register *)
+ | Typ_aux (Typ_id regtyp, _) when Env.is_regtyp regtyp env ->
+ let base, top, ranges = Env.get_regtyp regtyp env in
+ let range, _ =
+ try List.find (fun (_, id) -> Id.compare id field = 0) ranges with
+ | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp)
+ in
+ begin
+ match range, Env.get_default_order env with
+ | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) ->
+ let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in
+ annot_exp (E_field (inferred_exp, field)) vec_typ
+ | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) ->
+ let vec_typ = dvector_typ env (nconstant n) (nconstant (n - m + 1)) bit_typ in
+ annot_exp (E_field (inferred_exp, field)) vec_typ
+ | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) ->
+ let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in
+ annot_exp (E_field (inferred_exp, field)) vec_typ
+ | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) ->
+ let vec_typ = dvector_typ env (nconstant n) (nconstant (m - n + 1)) bit_typ in
+ annot_exp (E_field (inferred_exp, field)) vec_typ
+ | _, _ -> typ_error l "Invalid register field type"
+ end
+ (* Accessing a field of a record *)
+ | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env ->
+ begin
+ let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor field env) [strip_exp inferred_exp] None in
+ match inferred_acc with
+ | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc)
+ | _ -> assert false (* Unreachable *)
+ end
+ | _ -> typ_error l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid")
+ end
+ | E_tuple exps ->
+ let inferred_exps = List.map (irule infer_exp env) exps in
+ annot_exp (E_tuple inferred_exps) (mk_typ (Typ_tup (List.map typ_of inferred_exps)))
+ | E_assign (lexp, bind) ->
+ fst (bind_assignment env lexp bind)
+ | E_cast (typ, exp) ->
+ let checked_exp = crule check_exp env exp typ in
+ annot_exp (E_cast (typ, checked_exp)) typ
+ | E_app_infix (x, op, y) when List.length (Env.get_overloads (deinfix op) env) > 0 -> infer_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ())))
+ | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 ->
+ let rec try_overload = function
+ | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp)
+ | (f :: fs) -> begin
+ typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")");
+ try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with
+ | Type_error (_, m) -> typ_print ("Error: " ^ m); try_overload fs
+ end
+ in
+ try_overload (Env.get_overloads f env)
+ | E_app (f, xs) -> infer_funapp l env f xs None
+ | E_for (v, f, t, step, ord, body) ->
+ begin
+ let f, t = match ord with
+ | Ord_aux (Ord_inc, _) -> f, t
+ | Ord_aux (Ord_dec, _) -> t, f (* reverse direction for downto loop *)
+ in
+ let inferred_f = irule infer_exp env f in
+ let inferred_t = irule infer_exp env t in
+ let checked_step = crule check_exp env step int_typ in
+ match is_range (typ_of inferred_f), is_range (typ_of inferred_t) with
+ | None, _ -> typ_error l ("Type of " ^ string_of_exp f ^ " in foreach must be a range")
+ | _, None -> typ_error l ("Type of " ^ string_of_exp t ^ " in foreach must be a range")
+ | Some (l1, l2), Some (u1, u2) when prove env (nc_lteq l2 u1) ->
+ let checked_body = crule check_exp (Env.add_local v (Immutable, range_typ l1 u2) env) body unit_typ in
+ annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ
+ | _, _ -> typ_error l "Ranges in foreach overlap"
+ end
+ | E_if (cond, then_branch, else_branch) ->
+ let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
+ let flows, constrs = infer_flow env cond' in
+ let then_branch' = irule infer_exp (add_constraints constrs (add_flows true flows env)) then_branch in
+ let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch (typ_of then_branch') in
+ annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch')
+ | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ())))
+ | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "vector_append", [v1; v2]), (l, ())))
+ | E_vector_subrange (v, n, m) -> infer_exp env (E_aux (E_app (mk_id "vector_subrange", [v; n; m]), (l, ())))
+ | E_vector [] -> typ_error l "Cannot infer type of empty vector"
+ | E_vector ((item :: items) as vec) ->
+ let inferred_item = irule infer_exp env item in
+ let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in
+ let vec_typ = match Env.get_default_order env with
+ | Ord_aux (Ord_inc, _) ->
+ mk_typ (Typ_app (mk_id "vector",
+ [mk_typ_arg (Typ_arg_nexp (nconstant 0));
+ mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec)));
+ mk_typ_arg (Typ_arg_order (Env.get_default_order env));
+ mk_typ_arg (Typ_arg_typ (typ_of inferred_item))]))
+ | Ord_aux (Ord_dec, _) ->
+ mk_typ (Typ_app (mk_id "vector",
+ [mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec - 1)));
+ mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec)));
+ mk_typ_arg (Typ_arg_order (Env.get_default_order env));
+ mk_typ_arg (Typ_arg_typ (typ_of inferred_item))]))
+ in
+ annot_exp (E_vector (inferred_item :: checked_items)) vec_typ
+ | E_assert (test, msg) ->
+ let checked_test = crule check_exp env test bool_typ in
+ let checked_msg = crule check_exp env msg string_typ in
+ annot_exp (E_assert (checked_test, checked_msg)) unit_typ
+ | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp)
+
+and infer_funapp l env f xs ret_ctx_typ = infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ
+
+and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ =
+ let annot_exp exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
+ let rec number n = function
+ | [] -> []
+ | (x :: xs) -> (n, x) :: number (n + 1) xs
+ in
+ let solve_quant = function
+ | QI_aux (QI_id _, _) -> false
+ | QI_aux (QI_const nc, _) -> prove env nc
in
- match (in_env,tannot) with
- | Some(Base( (params,u),Spec,constraints,eft,_,_)), Base( (p',t),_,c',eft',_,_) ->
- (*let _ = Printf.eprintf "Function %s is in env\n" id in*)
- let u,constraints,eft,t_param_env = subst_with_env t_param_env true u constraints eft in
- let _,cs_decs = type_consistent (Specc l) d_env Require false t u in
- (*let _ = Printf.eprintf "valspec consistent with type for %s, %s ~< %s with %s deriveds and %s stated\n"
- id (t_to_string t) (t_to_string u) (constraints_to_string cs_decs)
- (constraints_to_string (constraints@c')) in*)
- let imp_param = match u.t with
- | Tfn(_,_,IP_user n,_) -> Some n
- | _ -> None in
- let (t_env,orig_env) = if is_rec then (t_env,t_env) else (Envmap.remove t_env id,t_env) in
- let funcls,cs_ef = check t_env t_param_env imp_param in
- let cses,ef = ((fun (cses,efses) ->
- cses,(List.fold_right union_effects efses pure_e)) (List.split cs_ef)) in
- let cs = if List.length funcls = 1 then cses else [BranchCons(Fun l,None, cses)] in
- let cs',map = resolve_constraints (cs@cs_decs@constraints@c') in
- let tannot =
- check_tannot l (match map with | None -> tannot | Some m -> add_map_tannot m tannot) imp_param cs' ef in
- (*let _ = Printf.eprintf "remaining constraints are: %s\n" (constraints_to_string cs') in
- let _ = Printf.eprintf "check_tannot ok for %s val type %s derived type %s \n"
- id (t_to_string u) (t_to_string t) in*)
- let _ = List.map check_pattern_after_constraints funcls in
- let funcls = match imp_param with
- | Some {nexp = Nvar i} -> List.map (update_pattern i) funcls
- | _ -> funcls
- in
- (*let _ = Printf.eprintf "done funcheck case 1 of %s\n%!" id in*)
- (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,tannot))),
- Env(d_env,orig_env (*Envmap.insert t_env (id,tannot)*),b_env,tp_env)
- | _ , _->
- (*let _ = Printf.eprintf "checking %s, not in env\n%!" id in*)
- (*let t_env = if is_rec then Envmap.insert t_env (id,tannot) else t_env in*)
- let funcls,cs_ef = check t_env t_param_env None in
- let cses,ef =
- ((fun (cses,efses) -> (cses,(List.fold_right union_effects efses pure_e))) (List.split cs_ef)) in
- let cs = if List.length funcls = 1 then cses else [BranchCons(Fun l, None, cses)] in
- (*let _ = Printf.eprintf "unresolved constraints are %s\n%!" (constraints_to_string cs) in*)
- let (cs',map) = resolve_constraints cs in
- (*let _ = Printf.eprintf "checking tannot for %s 2 remaining constraints are %s\n"
- id (constraints_to_string cs') in*)
- let tannot = check_tannot l
- (match map with | None -> tannot | Some m -> add_map_tannot m tannot)
- None cs' ef in
- let _ = List.map check_pattern_after_constraints funcls in
- (*let _ = Printf.eprintf "done funcheck case2\n" in*)
- (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,tannot))),
- Env(d_env,(if is_rec then t_env else Envmap.insert t_env (id,tannot)),b_env,tp_env)
-
-(*TODO Only works for inc vectors, need to add support for dec*)
-let check_alias_spec envs alias (AL_aux(al,(l,annot))) e_typ =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
- let check_reg (RI_aux ((RI_id (Id_aux(_,l) as id)), _)) : (string * tannot reg_id * typ * typ) =
- let i = id_to_string id in
- (match Envmap.apply t_env i with
- | Some(Base(([],t), External (Some j), [], _,_,_)) ->
- let t,_ = get_abbrev d_env t in
- let t_actual,t_id = match t.t with
- | Tabbrev(i,t) -> t,i
- | _ -> t,t in
- (match t_actual.t with
- | Tapp("register",[TA_typ t']) ->
- if i = j then (i,(RI_aux (RI_id id, (l,Base(([],t),External (Some j), [], pure_e,pure_e,nob)))),t_id,t')
- else assert false
- | _ -> typ_error l
- ("register alias " ^ alias ^ " to " ^ i ^ " expected a register, found " ^ (t_to_string t)))
- | _ -> typ_error l ("register alias " ^ alias ^ " to " ^ i ^ " exepcted a register.")) in
- match al with
- | AL_subreg(reg_a,subreg) ->
- let (reg,reg_a,reg_t,t) = check_reg reg_a in
- (match reg_t.t with
- | Tid i ->
- (match lookup_record_typ i d_env.rec_env with
- | None -> typ_error l ("Expected a register with bit fields, given " ^ i)
- | Some(((i,rec_kind,tannot,fields) as r)) ->
- let fi = id_to_string subreg in
- (match lookup_field_type fi r with
- | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi)
- | Some et ->
- let tannot = Base(([],et),Alias (Alias_field(reg,fi)),[],pure_e,pure_e,nob) in
- let d_env = {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in
- (AL_aux(AL_subreg(reg_a,subreg),(l,tannot)),tannot,d_env)))
- | _ -> typ_error l ("Expected a register with fields, given " ^ (t_to_string reg_t)))
- | AL_bit(reg_a,bit) ->
- let (reg,reg_a,reg_t,t) = check_reg reg_a in
- let (E_aux(bit,(le,eannot)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) bit in
- (match t.t with
- | Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord order;TA_typ item_t]) ->
- (match (base.nexp,len.nexp,order.order, bit) with
- | (Nconst i,Nconst j,Oinc, E_lit (L_aux((L_num k), ll))) ->
- if (int_of_big_int i) <= k && ((int_of_big_int i) + (int_of_big_int j)) >= k
- then let tannot = Base(([],item_t),Alias (Alias_extract(reg, k,k)),[],pure_e,pure_e,nob) in
- let d_env =
- {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in
- (AL_aux(AL_bit(reg_a,(E_aux(bit,(le,eannot)))), (l,tannot)), tannot,d_env)
- else typ_error ll ("Alias bit lookup must be in the range of the vector in the register")
- | _ -> typ_error l ("Alias bit lookup must have a constant index"))
- | _ -> typ_error l ("Alias bit lookup must refer to a register with type vector, found " ^ (t_to_string t)))
- | AL_slice(reg_a,sl1,sl2) ->
- let (reg,reg_a,reg_t,t) = check_reg reg_a in
- let (E_aux(sl1,(le1,eannot1)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) sl1 in
- let (E_aux(sl2,(le2,eannot2)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) sl2 in
- (match t.t with
- | Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord order;TA_typ item_t]) ->
- (match (base.nexp,len.nexp,order.order, sl1,sl2) with
- | (Nconst i,Nconst j,Oinc, E_lit (L_aux((L_num k), ll)),E_lit (L_aux((L_num k2), ll2))) ->
- if (int_of_big_int i) <= k && ((int_of_big_int i) + (int_of_big_int j)) >= k2 && k < k2
- then let t = {t = Tapp("vector",[TA_nexp (int_to_nexp k);TA_nexp (int_to_nexp ((k2-k) +1));
- TA_ord order; TA_typ item_t])} in
- let tannot = Base(([],t),Alias (Alias_extract(reg, k, k2)),[],pure_e,pure_e,nob) in
- let d_env =
- {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in
- (AL_aux(AL_slice(reg_a,(E_aux(sl1,(le1,eannot1))),(E_aux(sl2,(le2,eannot2)))),
- (l,tannot)), tannot,d_env)
- else typ_error ll ("Alias slices must be in the range of the vector in the register")
- | _ -> typ_error l ("Alias slices must have constant slices"))
- | _ -> typ_error l ("Alias slices must point to a register with a vector type: found " ^ (t_to_string t)))
- | AL_concat(reg1_a,reg2_a) ->
- let (reg1,reg1_a,reg_t,t1) = check_reg reg1_a in
- let (reg2,reg2_a,reg_t,t2) = check_reg reg2_a in
- (match (t1.t,t2.t) with
- | (Tapp("vector",[TA_nexp b1;TA_nexp r; TA_ord {order = Oinc}; TA_typ item_t]),
- Tapp("vector",[TA_nexp _ ;TA_nexp r2; TA_ord {order = Oinc}; TA_typ item_t2])) ->
- let _ = type_consistent (Specc l) d_env Guarantee false item_t item_t2 in
- let t = {t= Tapp("register",
- [TA_typ {t= Tapp("vector",[TA_nexp b1; TA_nexp (mk_add r r2);
- TA_ord {order = Oinc}; TA_typ item_t])}])} in
- let tannot = Base(([],t),Alias (Alias_pair(reg1,reg2)),[],pure_e,pure_e,nob) in
- let d_env = {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, TwoReg(reg1,reg2,tannot))} in
- (AL_aux (AL_concat(reg1_a,reg2_a), (l,tannot)), tannot, d_env)
- | _ -> typ_error l
- ("Alias concatentaion must connect two registers with vector type, found " ^ t_to_string t1 ^ " and " ^ t_to_string t2))
-
-(*val check_def : envs -> tannot def -> (tannot def) envs_out*)
-let check_def envs def =
- let (Env(d_env,t_env,b_env,tp_env)) = envs in
+ let rec instantiate quants typs ret_typ args =
+ match typs, args with
+ | (utyps, []), (uargs, []) ->
+ begin
+ typ_debug ("Got unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs);
+ if List.for_all solve_quant quants
+ then
+ let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in
+ (iuargs, ret_typ)
+ else typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants
+ ^ " not resolved during application of " ^ string_of_id f)
+ end
+ | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) when KidSet.is_empty (typ_frees typ) ->
+ begin
+ let carg = crule check_exp env arg typ in
+ let (iargs, ret_typ') = instantiate quants (utyps, typs) ret_typ (uargs, args) in
+ ((n, carg) :: iargs, ret_typ')
+ end
+ | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) ->
+ begin
+ typ_debug ("INSTANTIATE: " ^ string_of_exp arg ^ " with " ^ string_of_typ typ ^ " NF " ^ string_of_tnf (normalize_typ env typ));
+ let iarg = irule infer_exp env arg in
+ typ_debug ("INFER: " ^ string_of_exp arg ^ " type " ^ string_of_typ (typ_of iarg) ^ " NF " ^ string_of_tnf (normalize_typ env (typ_of iarg)));
+ try
+ let iarg, unifiers = type_coercion_unify env iarg typ in
+ typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
+ let utyps' = List.map (subst_unifiers unifiers) utyps in
+ let typs' = List.map (subst_unifiers unifiers) typs in
+ let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
+ let ret_typ' = subst_unifiers unifiers ret_typ in
+ let (iargs, ret_typ'') = instantiate quants' (utyps', typs') ret_typ' (uargs, args) in
+ ((n, iarg) :: iargs, ret_typ'')
+ with
+ | Unification_error (l, str) ->
+ typ_debug ("Unification error: " ^ str);
+ instantiate quants (typ :: utyps, typs) ret_typ ((n, arg) :: uargs, args)
+ end
+ | (_, []), _ -> typ_error l ("Function " ^ string_of_id f ^ " applied to too many arguments")
+ | _, (_, []) -> typ_error l ("Function " ^ string_of_id f ^ " not applied to enough arguments")
+ in
+ let instantiate_ret quants typs ret_typ =
+ match ret_ctx_typ with
+ | None -> (quants, typs, ret_typ)
+ | Some rct ->
+ begin
+ typ_debug ("RCT is " ^ string_of_typ rct);
+ typ_debug ("INSTANTIATE RETURN:" ^ string_of_typ ret_typ);
+ let unifiers = try unify l env ret_typ rct with Unification_error _ -> typ_debug "UERROR"; KBindings.empty in
+ typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
+ let typs' = List.map (subst_unifiers unifiers) typs in
+ let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
+ let ret_typ' = subst_unifiers unifiers ret_typ in
+ (quants', typs', ret_typ')
+ end
+ in
+ let exp =
+ match Env.expand_synonyms env f_typ with
+ | Typ_aux (Typ_fn (Typ_aux (Typ_tup typ_args, _), typ_ret, eff), _) ->
+ let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) typ_args typ_ret in
+ let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in
+ let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in
+ annot_exp (E_app (f, xs_reordered)) typ_ret eff
+ | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) ->
+ let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) [typ_arg] typ_ret in
+ let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in
+ let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in
+ annot_exp (E_app (f, xs_reordered)) typ_ret eff
+ | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type")
+ in
+ match ret_ctx_typ with
+ | None -> exp
+ | Some rct -> type_coercion env exp rct
+
+(**************************************************************************)
+(* 6. Effect system *)
+(**************************************************************************)
+
+let effect_of_annot = function
+| Some (_, _, eff) -> eff
+| None -> no_effect
+
+let effect_of (E_aux (exp, (l, annot))) = effect_of_annot annot
+
+let add_effect (E_aux (exp, (l, annot))) eff1 =
+ match annot with
+ | Some (env, typ, eff2) -> E_aux (exp, (l, Some (env, typ, union_effects eff1 eff2)))
+ | None -> assert false
+
+let effect_of_lexp (LEXP_aux (exp, (l, annot))) = effect_of_annot annot
+
+let add_effect_lexp (LEXP_aux (lexp, (l, annot))) eff1 =
+ match annot with
+ | Some (env, typ, eff2) -> LEXP_aux (lexp, (l, Some (env, typ, union_effects eff1 eff2)))
+ | None -> assert false
+
+let effect_of_pat (P_aux (exp, (l, annot))) = effect_of_annot annot
+
+let add_effect_pat (P_aux (pat, (l, annot))) eff1 =
+ match annot with
+ | Some (env, typ, eff2) -> P_aux (pat, (l, Some (env, typ, union_effects eff1 eff2)))
+ | None -> assert false
+
+let collect_effects xs = List.fold_left union_effects no_effect (List.map effect_of xs)
+
+let collect_effects_lexp xs = List.fold_left union_effects no_effect (List.map effect_of_lexp xs)
+
+let collect_effects_pat xs = List.fold_left union_effects no_effect (List.map effect_of_pat xs)
+
+(* Traversal that propagates effects upwards through expressions *)
+
+let rec propagate_exp_effect (E_aux (exp, annot)) =
+ let propagated_exp, eff = propagate_exp_effect_aux exp in
+ add_effect (E_aux (propagated_exp, annot)) eff
+and propagate_exp_effect_aux = function
+ | E_block xs ->
+ let propagated_xs = List.map propagate_exp_effect xs in
+ E_block propagated_xs, collect_effects propagated_xs
+ | E_nondet xs ->
+ let propagated_xs = List.map propagate_exp_effect xs in
+ E_nondet propagated_xs, collect_effects propagated_xs
+ | E_id id -> E_id id, no_effect
+ | E_lit lit -> E_lit lit, no_effect
+ | E_cast (typ, exp) ->
+ let propagated_exp = propagate_exp_effect exp in
+ E_cast (typ, propagated_exp), effect_of propagated_exp
+ | E_app (id, xs) ->
+ let propagated_xs = List.map propagate_exp_effect xs in
+ E_app (id, propagated_xs), collect_effects propagated_xs
+ | E_vector xs ->
+ let propagated_xs = List.map propagate_exp_effect xs in
+ E_vector propagated_xs, collect_effects propagated_xs
+ | E_tuple xs ->
+ let propagated_xs = List.map propagate_exp_effect xs in
+ E_tuple propagated_xs, collect_effects propagated_xs
+ | E_if (cond, t, e) ->
+ let propagated_cond = propagate_exp_effect cond in
+ let propagated_t = propagate_exp_effect t in
+ let propagated_e = propagate_exp_effect e in
+ E_if (propagated_cond, propagated_t, propagated_e), collect_effects [propagated_cond; propagated_t; propagated_e]
+ | E_case (exp, cases) ->
+ let propagated_exp = propagate_exp_effect exp in
+ let propagated_cases = List.map propagate_pexp_effect cases in
+ let case_eff = List.fold_left union_effects no_effect (List.map snd propagated_cases) in
+ E_case (propagated_exp, List.map fst propagated_cases), union_effects (effect_of propagated_exp) case_eff
+ | E_for (v, f, t, step, ord, body) ->
+ let propagated_f = propagate_exp_effect f in
+ let propagated_t = propagate_exp_effect t in
+ let propagated_step = propagate_exp_effect step in
+ let propagated_body = propagate_exp_effect body in
+ E_for (v, propagated_f, propagated_t, propagated_step, ord, propagated_body),
+ collect_effects [propagated_f; propagated_t; propagated_step; propagated_body]
+ | E_let (letbind, exp) ->
+ let propagated_lb, eff = propagate_letbind_effect letbind in
+ let propagated_exp = propagate_exp_effect exp in
+ E_let (propagated_lb, propagated_exp), union_effects (effect_of propagated_exp) eff
+ | E_assign (lexp, exp) ->
+ let propagated_lexp = propagate_lexp_effect lexp in
+ let propagated_exp = propagate_exp_effect exp in
+ E_assign (propagated_lexp, propagated_exp), union_effects (effect_of propagated_exp) (effect_of_lexp propagated_lexp)
+ | E_sizeof nexp -> E_sizeof nexp, no_effect
+ | E_constraint nc -> E_constraint nc, no_effect
+ | E_exit exp ->
+ let propagated_exp = propagate_exp_effect exp in
+ E_exit propagated_exp, effect_of propagated_exp
+ | E_return exp ->
+ let propagated_exp = propagate_exp_effect exp in
+ E_return propagated_exp, effect_of propagated_exp
+ | E_assert (test, msg) ->
+ let propagated_test = propagate_exp_effect test in
+ let propagated_msg = propagate_exp_effect msg in
+ E_assert (propagated_test, propagated_msg), collect_effects [propagated_test; propagated_msg]
+ | E_field (exp, id) ->
+ let propagated_exp = propagate_exp_effect exp in
+ E_field (propagated_exp, id), effect_of propagated_exp
+ | exp_aux -> typ_error Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression "
+ ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))))
+
+and propagate_pexp_effect = function
+ | Pat_aux (Pat_exp (pat, exp), (l, annot)) ->
+ begin
+ let propagated_pat = propagate_pat_effect pat in
+ let propagated_exp = propagate_exp_effect exp in
+ let propagated_eff = union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp) in
+ match annot with
+ | Some (typq, typ, eff) ->
+ Pat_aux (Pat_exp (propagated_pat, propagated_exp), (l, Some (typq, typ, union_effects eff propagated_eff))),
+ union_effects eff propagated_eff
+ | None -> Pat_aux (Pat_exp (propagated_pat, propagated_exp), (l, None)), propagated_eff
+ end
+ | Pat_aux (Pat_when (pat, guard, exp), (l, annot)) ->
+ begin
+ let propagated_pat = propagate_pat_effect pat in
+ let propagated_guard = propagate_exp_effect guard in
+ let propagated_exp = propagate_exp_effect exp in
+ let propagated_eff = union_effects (effect_of_pat propagated_pat)
+ (union_effects (effect_of propagated_guard) (effect_of propagated_exp))
+ in
+ match annot with
+ | Some (typq, typ, eff) ->
+ Pat_aux (Pat_when (propagated_pat, propagated_guard, propagated_exp), (l, Some (typq, typ, union_effects eff propagated_eff))),
+ union_effects eff propagated_eff
+ | None -> Pat_aux (Pat_when (propagated_pat, propagated_guard, propagated_exp), (l, None)), propagated_eff
+ end
+
+and propagate_pat_effect (P_aux (pat, annot)) =
+ let propagated_pat, eff = propagate_pat_effect_aux pat in
+ add_effect_pat (P_aux (propagated_pat, annot)) eff
+and propagate_pat_effect_aux = function
+ | P_lit lit -> P_lit lit, no_effect
+ | P_wild -> P_wild, no_effect
+ | P_as (pat, id) ->
+ let propagated_pat = propagate_pat_effect pat in
+ P_as (propagated_pat, id), effect_of_pat propagated_pat
+ | P_typ (typ, pat) ->
+ let propagated_pat = propagate_pat_effect pat in
+ P_typ (typ, propagated_pat), effect_of_pat propagated_pat
+ | P_id id -> P_id id, no_effect
+ | P_app (id, pats) ->
+ let propagated_pats = List.map propagate_pat_effect pats in
+ P_app (id, propagated_pats), collect_effects_pat propagated_pats
+ | P_tup pats ->
+ let propagated_pats = List.map propagate_pat_effect pats in
+ P_tup propagated_pats, collect_effects_pat propagated_pats
+ | P_list pats ->
+ let propagated_pats = List.map propagate_pat_effect pats in
+ P_list propagated_pats, collect_effects_pat propagated_pats
+ | P_vector_concat pats ->
+ let propagated_pats = List.map propagate_pat_effect pats in
+ P_vector_concat propagated_pats, collect_effects_pat propagated_pats
+ | P_vector pats ->
+ let propagated_pats = List.map propagate_pat_effect pats in
+ P_vector propagated_pats, collect_effects_pat propagated_pats
+ | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat"
+
+and propagate_letbind_effect (LB_aux (lb, (l, annot))) =
+ let propagated_lb, eff = propagate_letbind_effect_aux lb in
+ match annot with
+ | Some (typq, typ, eff) -> LB_aux (propagated_lb, (l, Some (typq, typ, eff))), eff
+ | None -> LB_aux (propagated_lb, (l, None)), eff
+and propagate_letbind_effect_aux = function
+ | LB_val_explicit (typschm, pat, exp) ->
+ let propagated_pat = propagate_pat_effect pat in
+ let propagated_exp = propagate_exp_effect exp in
+ LB_val_explicit (typschm, propagated_pat, propagated_exp),
+ union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp)
+ | LB_val_implicit (pat, exp) ->
+ let propagated_pat = propagate_pat_effect pat in
+ let propagated_exp = propagate_exp_effect exp in
+ LB_val_implicit (propagated_pat, propagated_exp),
+ union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp)
+
+and propagate_lexp_effect (LEXP_aux (lexp, annot)) =
+ let propagated_lexp, eff = propagate_lexp_effect_aux lexp in
+ add_effect_lexp (LEXP_aux (propagated_lexp, annot)) eff
+and propagate_lexp_effect_aux = function
+ | LEXP_id id -> LEXP_id id, no_effect
+ | LEXP_memory (id, exps) ->
+ let propagated_exps = List.map propagate_exp_effect exps in
+ LEXP_memory (id, propagated_exps), collect_effects propagated_exps
+ | LEXP_cast (typ, id) -> LEXP_cast (typ, id), no_effect
+ | LEXP_tup lexps ->
+ let propagated_lexps = List.map propagate_lexp_effect lexps in
+ LEXP_tup propagated_lexps, collect_effects_lexp propagated_lexps
+ | LEXP_vector (lexp, exp) ->
+ let propagated_lexp = propagate_lexp_effect lexp in
+ let propagated_exp = propagate_exp_effect exp in
+ LEXP_vector (propagated_lexp, propagated_exp), union_effects (effect_of propagated_exp) (effect_of_lexp propagated_lexp)
+ | LEXP_vector_range (lexp, exp1, exp2) ->
+ let propagated_lexp = propagate_lexp_effect lexp in
+ let propagated_exp1 = propagate_exp_effect exp1 in
+ let propagated_exp2 = propagate_exp_effect exp2 in
+ LEXP_vector_range (propagated_lexp, propagated_exp1, propagated_exp2),
+ union_effects (collect_effects [propagated_exp1; propagated_exp2]) (effect_of_lexp propagated_lexp)
+ | LEXP_field (lexp, id) ->
+ let propagated_lexp = propagate_lexp_effect lexp in
+ LEXP_field (propagated_lexp, id),effect_of_lexp propagated_lexp
+ | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in lexp"
+
+(**************************************************************************)
+(* 6. Checking toplevel definitions *)
+(**************************************************************************)
+
+let check_letdef env (LB_aux (letbind, (l, _))) =
+ begin
+ match letbind with
+ | LB_val_explicit (typschm, pat, bind) -> assert false
+ | LB_val_implicit (P_aux (P_typ (typ_annot, pat), _), bind) ->
+ let checked_bind = crule check_exp env (strip_exp bind) typ_annot in
+ let tpat, env = bind_pat env (strip_pat pat) typ_annot in
+ [DEF_val (LB_aux (LB_val_implicit (P_aux (P_typ (typ_annot, tpat), (l, Some (env, typ_annot, no_effect))), checked_bind), (l, None)))], env
+ | LB_val_implicit (pat, bind) ->
+ let inferred_bind = irule infer_exp env (strip_exp bind) in
+ let tpat, env = bind_pat env (strip_pat pat) (typ_of inferred_bind) in
+ [DEF_val (LB_aux (LB_val_implicit (tpat, inferred_bind), (l, None)))], env
+ end
+
+let check_funcl env (FCL_aux (FCL_Funcl (id, pat, exp), (l, _))) typ =
+ match typ with
+ | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) ->
+ begin
+ let typed_pat, env = bind_pat env (strip_pat pat) typ_arg in
+ let env = Env.add_ret_typ typ_ret env in
+ let exp = propagate_exp_effect (crule check_exp env (strip_exp exp) typ_ret) in
+ FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, Some (env, typ, effect_of exp)))
+ end
+ | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")
+
+let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, annot))) =
+ match annot with
+ | Some (_, _, eff) -> eff
+ | None -> no_effect (* Maybe could be assert false. This should never happen *)
+
+let infer_funtyp l env tannotopt funcls =
+ match tannotopt with
+ | Typ_annot_opt_aux (Typ_annot_opt_some (quant, ret_typ), _) ->
+ begin
+ let rec typ_from_pat (P_aux (pat_aux, (l, _)) as pat) =
+ match pat_aux with
+ | P_lit lit -> infer_lit env lit
+ | P_typ (typ, _) -> typ
+ | P_tup pats -> mk_typ (Typ_tup (List.map typ_from_pat pats))
+ | _ -> typ_error l ("Cannot infer type from pattern " ^ string_of_pat pat)
+ in
+ match funcls with
+ | [FCL_aux (FCL_Funcl (_, pat, _), _)] ->
+ let arg_typ = typ_from_pat pat in
+ let fn_typ = mk_typ (Typ_fn (arg_typ, ret_typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in
+ (quant, fn_typ)
+ | _ -> typ_error l "Cannot infer function type for function with multiple clauses"
+ end
+ | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error l "Cannot infer function type for unannotated function"
+
+let mk_val_spec typq typ id = DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id), (Parse_ast.Unknown, None)))
+
+let check_tannotopt typq ret_typ = function
+ | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> ()
+ | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_ret_typ), l) ->
+ if typ_identical ret_typ annot_ret_typ
+ then ()
+ else typ_error l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec")
+
+let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, _)) as fd_aux) =
+ let id =
+ match (List.fold_right
+ (fun (FCL_aux (FCL_Funcl (id, _, _), _)) id' ->
+ match id' with
+ | Some id' -> if string_of_id id' = string_of_id id then Some id'
+ else typ_error l ("Function declaration expects all definitions to have the same name, "
+ ^ string_of_id id ^ " differs from other definitions of " ^ string_of_id id')
+ | None -> Some id) funcls None)
+ with
+ | Some id -> id
+ | None -> typ_error l "funcl list is empty"
+ in
+ typ_print ("\nChecking function " ^ string_of_id id);
+ let have_val_spec, (quant, (Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) as typ)), env =
+ try true, Env.get_val_spec id env, env with
+ | Type_error (l, _) ->
+ let (quant, typ) = infer_funtyp l env tannotopt funcls in
+ false, (quant, typ), env
+ in
+ check_tannotopt quant vtyp_ret tannotopt;
+ typ_debug ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ));
+ let funcl_env = add_typquant quant env in
+ let funcls = List.map (fun funcl -> check_funcl funcl_env funcl typ) funcls in
+ let eff = List.fold_left union_effects no_effect (List.map funcl_effect funcls) in
+ let vs_def, env, declared_eff =
+ if not have_val_spec
+ then
+ let typ = Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, eff), vl) in
+ [mk_val_spec quant typ id], Env.add_val_spec id (quant, typ) env, eff
+ else [], env, declared_eff
+ in
+ if equal_effects eff declared_eff
+ then
+ vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env
+ else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found")
+
+(* Checking a val spec simply adds the type as a binding in the
+ context. We have to destructure the various kinds of val specs, but
+ the difference is irrelevant for the typechecker. *)
+let check_val_spec env (VS_aux (vs, (l, _))) =
+ let (id, quants, typ, env) = match vs with
+ | VS_val_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env)
+ | VS_cast_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, Env.add_cast id env)
+ | VS_extern_no_rename (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env)
+ | VS_extern_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id, _) -> (id, quants, typ, env) in
+ [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, typ) env
+
+let check_default env (DT_aux (ds, l)) =
+ match ds with
+ | DT_kind _ -> [DEF_default (DT_aux (ds,l))], env (* Check: Is this supposed to do nothing? *)
+ | DT_order (Ord_aux (Ord_inc, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_inc env
+ | DT_order (Ord_aux (Ord_dec, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_dec env
+ | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order"
+ (* This branch allows us to write something like: default forall Nat 'n. [|'n|] name... what does this even mean?! *)
+ | DT_typ (typschm, id) -> typ_error l ("Unsupported default construct")
+
+let check_register env id base top ranges =
+ match base, top with
+ | Nexp_aux (Nexp_constant basec, _), Nexp_aux (Nexp_constant topc, _) ->
+ let no_typq = TypQ_aux (TypQ_tq [], Parse_ast.Unknown) (* Maybe could be TypQ_no_forall? *) in
+ (* FIXME: wrong for default Order inc? *)
+ let vec_typ = dvector_typ env base (nconstant ((basec - topc) + 1)) bit_typ in
+ let cast_typ = mk_typ (Typ_fn (mk_id_typ id, vec_typ, no_effect)) in
+ let cast_to_typ = mk_typ (Typ_fn (vec_typ, mk_id_typ id, no_effect)) in
+ env
+ |> Env.add_regtyp id basec topc ranges
+ (* |> Env.add_typ_synonym id (fun _ -> vec_typ) *)
+ |> Env.add_val_spec (mk_id ("cast_" ^ string_of_id id)) (no_typq, cast_typ)
+ |> Env.add_cast (mk_id ("cast_" ^ string_of_id id))
+ |> Env.add_val_spec (mk_id ("cast_to_" ^ string_of_id id)) (no_typq, cast_to_typ)
+ |> Env.add_cast (mk_id ("cast_to_" ^ string_of_id id))
+ | _, _ -> typ_error (id_loc id) "Num expressions in register type declaration do not evaluate to constants"
+
+let kinded_id_arg kind_id =
+ let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in
+ match kind_id with
+ | KOpt_aux (KOpt_none kid, _) -> typ_arg (Typ_arg_nexp (nvar kid))
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid))
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid), _) ->
+ typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown)))
+ | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) ->
+ typ_arg (Typ_arg_typ (mk_typ (Typ_var kid)))
+
+let fold_union_quant quants (QI_aux (qi, l)) =
+ match qi with
+ | QI_id kind_id -> quants @ [kinded_id_arg kind_id]
+ | _ -> quants
+
+let check_type_union env variant typq (Tu_aux (tu, l)) =
+ let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in
+ match tu with
+ | Tu_id v -> Env.add_union_id v (typq, ret_typ) env
+ | Tu_ty_id (typ, v) -> Env.add_val_spec v (typq, mk_typ (Typ_fn (typ, ret_typ, no_effect))) env
+
+let check_typedef env (TD_aux (tdef, (l, _))) =
+ let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Typedef") in
+ match tdef with
+ | TD_abbrev(id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) ->
+ [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (fun _ -> typ) env
+ | TD_record(id, nmscm, typq, fields, _) ->
+ [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env
+ | TD_variant(id, nmscm, typq, arms, _) ->
+ let env =
+ env
+ |> Env.add_variant id (typq, arms)
+ |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms)
+ in
+ [DEF_type (TD_aux (tdef, (l, None)))], env
+ | TD_enum(id, nmscm, ids, _) ->
+ [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env
+ | TD_register(id, base, top, ranges) -> [DEF_type (TD_aux (tdef, (l, None)))], check_register env id base top ranges
+
+let rec check_def env def =
+ let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Case") in
match def with
- | DEF_kind kdef ->
- (*let _ = Printf.eprintf "checking kind def\n" in*)
- let kd,envs = check_kind_def envs kdef in
- (*let _ = Printf.eprintf "checked kind def\n" in*)
- (DEF_kind kd,envs)
- | DEF_type tdef ->
- (*let _ = Printf.eprintf "checking type def\n" in*)
- let td,envs = check_type_def envs tdef in
- (*let _ = Printf.eprintf "checked type def\n" in*)
- (DEF_type td,envs)
- | DEF_fundef fdef ->
- (*let _ = Printf.eprintf "checking fun def\n" in*)
- let fd,envs = check_fundef envs fdef in
- (*let _ = Printf.eprintf "checked fun def\n" in*)
- (DEF_fundef fd,envs)
- | DEF_val letdef ->
- (*let _ = Printf.eprintf "checking letdef\n" in*)
- let (letbind,t_env_let,_,b_env_let,eft) = check_lbind envs None true None Emp_global letdef in
- (*let _ = Printf.eprintf "checked letdef\n" in*)
- (DEF_val letbind,Env(d_env,Envmap.union t_env t_env_let, merge_bounds b_env b_env_let, tp_env))
- | DEF_spec spec ->
- (*let _ = Printf.eprintf "checking spec\n" in*)
- let vs,envs = check_val_spec envs spec in
- (*let _ = Printf.eprintf "checked spec\n" in*)
- (DEF_spec vs, envs)
- | DEF_default default -> let ds,envs = check_default envs default in
- (DEF_default ds,envs)
- | DEF_reg_dec(DEC_aux(DEC_reg(typ,id), (l,annot))) ->
- (*let _ = Printf.eprintf "checking reg dec\n" in *)
- let t = (typ_to_t envs false false typ) in
- let i = id_to_string id in
- let tannot = into_register d_env (Base(([],t),External (Some i),[],pure_e,pure_e,nob)) in
- (*let _ = Printf.eprintf "done checking reg dec\n" in*)
- (DEF_reg_dec(DEC_aux(DEC_reg(typ,id),(l,tannot))),(Env(d_env,Envmap.insert t_env (i,tannot),b_env, tp_env)))
- | DEF_reg_dec(DEC_aux(DEC_alias(id,aspec), (l,annot))) ->
- (*let _ = Printf.eprintf "checking reg dec b\n" in*)
- let i = id_to_string id in
- let (aspec,tannot,d_env) = check_alias_spec envs i aspec None in
- (*let _ = Printf.eprintf "done checking reg dec b\n" in *)
- (DEF_reg_dec(DEC_aux(DEC_alias(id,aspec),(l,tannot))),(Env(d_env, Envmap.insert t_env (i,tannot),b_env,tp_env)))
- | DEF_reg_dec(DEC_aux(DEC_typ_alias(typ,id,aspec),(l,tannot))) ->
- (*let _ = Printf.eprintf "checking reg dec c\n" in*)
- let i = id_to_string id in
- let t = typ_to_t envs false false typ in
- let (aspec,tannot,d_env) = check_alias_spec envs i aspec (Some t) in
- (*let _ = Printf.eprintf "done checking reg dec c\n" in*)
- (DEF_reg_dec(DEC_aux(DEC_typ_alias(typ,id,aspec),(l,tannot))),(Env(d_env,Envmap.insert t_env (i,tannot),b_env,tp_env)))
+ | DEF_kind kdef -> cd_err ()
+ | DEF_type tdef -> check_typedef env tdef
+ | DEF_fundef fdef -> check_fundef env fdef
+ | DEF_val letdef -> check_letdef env letdef
+ | DEF_spec vs -> check_val_spec env vs
+ | DEF_default default -> check_default env default
+ | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
+ | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) ->
+ [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, None)))], Env.add_register id typ env
+ | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err ()
+ | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err ()
| DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Scattered given to type checker")
- | _ -> def,envs (*Else a comment, so skip but keep*)
+ | DEF_comm (DC_comm str) -> [DEF_comm (DC_comm str)], env
+ | DEF_comm (DC_comm_struct def) ->
+ let defs, env = check_def env def
+ in List.map (fun def -> DEF_comm (DC_comm_struct def)) defs, env
+let rec check' env (Defs defs) =
+ match defs with
+ | [] -> (Defs []), env
+ | def :: defs ->
+ let (def, env) = check_def env def in
+ let (Defs defs, env) = check' env (Defs defs) in
+ (Defs (def @ defs)), env
-(*val check : envs -> tannot defs -> tannot defs*)
-let rec check envs (Defs defs) =
- match defs with
- | [] -> (Defs []),envs
- | (DEF_overload (_, _)::defs) -> check envs (Defs defs)
- | def::defs -> let (def, envs) = check_def envs def in
- let (Defs defs, envs) = check envs (Defs defs) in
- (Defs (def::defs)), envs
+let check env defs =
+ try check' env defs with
+ | Type_error (l, m) -> raise (Reporting_basic.err_typ l m)
diff --git a/src/type_check.mli b/src/type_check.mli
index 4f78dd03..723f796a 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -9,6 +9,7 @@
(* Robert Norton-Wright *)
(* Christopher Pulte *)
(* Peter Sewell *)
+(* Alasdair Armstrong *)
(* *)
(* All rights reserved. *)
(* *)
@@ -41,14 +42,176 @@
(**************************************************************************)
open Ast
-open Type_internal
-type kind = Type_internal.kind
-type typ = Type_internal.t
-type 'a emap = 'a Envmap.t
+open Ast_util
-type envs = Env of def_envs * tannot emap * bounds_env * t_arg emap
-type 'a envs_out = 'a * envs
+val opt_tc_debug : int ref
+exception Type_error of l * string;;
-val check : envs -> tannot defs -> tannot defs * envs
-val typ_to_t : envs -> bool -> bool -> Ast.typ -> t
+type mut = Immutable | Mutable
+
+type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound
+
+module Env : sig
+ (* Env.t is the type of environments *)
+ type t
+
+ (* Note: Most get_ functions assume the identifiers exist, and throw type
+ errors if it doesn't. *)
+
+ val get_val_spec : id -> t -> typquant * typ
+
+ val get_register : id -> t -> typ
+
+ val get_regtyp : id -> t -> int * int * (index_range * id) list
+
+ (* Return all the identifiers in an enumeration. Throws a type error
+ if the enumeration doesn't exist. *)
+ val get_enum : id -> t -> id list
+
+ (* Returns true if id is a register type, false otherwise *)
+ val is_regtyp : id -> t -> bool
+
+ (* Check if a local variable is mutable. Throws Type_error if it
+ isn't a local variable. Probably best to use Env.lookup_id
+ instead *)
+ val is_mutable : id -> t -> bool
+
+ (* Get the current set of constraints. *)
+ val get_constraints : t -> n_constraint list
+
+ val get_typ_var : kid -> t -> base_kind_aux
+
+ val get_typ_vars : t -> base_kind_aux KBindings.t
+
+ val is_record : id -> t -> bool
+
+ val get_accessor : id -> t -> typquant * typ
+
+ (* If the environment is checking a function, then this will get the
+ expected return type of the function. It's useful for checking or
+ inserting early returns. Returns an option type and won't throw
+ any exceptions. *)
+ val get_ret_typ : t -> typ option
+
+ val get_typ_synonym : id -> t -> typ_arg list -> typ
+
+ val get_overloads : id -> t -> id list
+
+ (* Lookup id searchs for a specified id in the environment, and
+ returns it's type and what kind of identifier it is, using the
+ lvar type. Returns Unbound if the identifier is unbound, and
+ won't throw any exceptions. *)
+ val lookup_id : id -> t -> lvar
+
+ (* Return a fresh kind identifier that doesn't exist in the environment *)
+ val fresh_kid : t -> kid
+
+ val expand_synonyms : t -> typ -> typ
+
+ (* Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *)
+ val base_typ_of : t -> typ -> typ
+
+ (* no_casts removes all the implicit type casts/coercions from the
+ environment, so checking a term with such an environment will
+ guarantee not to insert any casts. Not that this is only about
+ the implicit casting and has nothing to do with the E_cast AST
+ node. *)
+ val no_casts : t -> t
+
+ (* Is casting allowed by the environment? *)
+ val allow_casts : t -> bool
+
+ val empty : t
+
+end
+
+val add_typquant : typquant -> Env.t -> Env.t
+
+(* Some handy utility functions for constructing types. *)
+val mk_typ : typ_aux -> typ
+val mk_typ_arg : typ_arg_aux -> typ_arg
+val mk_id : string -> id
+val mk_id_typ : id -> typ
+
+val no_effect : effect
+val mk_effect : base_effect_aux list -> effect
+
+val union_effects : effect -> effect -> effect
+val equal_effects : effect -> effect -> bool
+
+val nconstant : int -> nexp
+val nminus : nexp -> nexp -> nexp
+val nsum : nexp -> nexp -> nexp
+val ntimes : nexp -> nexp -> nexp
+val npow2 : nexp -> nexp
+val nvar : kid -> nexp
+
+(* Sail builtin types. *)
+val int_typ : typ
+val nat_typ : typ
+val atom_typ : nexp -> typ
+val range_typ : nexp -> nexp -> typ
+val bit_typ : typ
+val bool_typ : typ
+val unit_typ : typ
+val string_typ : typ
+val real_typ : typ
+val vector_typ : nexp -> nexp -> order -> typ -> typ
+
+val inc_ord : order
+val dec_ord : order
+
+(* Vector with default order. *)
+val dvector_typ : Env.t -> nexp -> nexp -> typ -> typ
+
+(* Vector of specific length with default order, i.e. lvector_typ env n bit_typ = bit[n]. *)
+val lvector_typ : Env.t -> nexp -> typ -> typ
+
+type tannot = (Env.t * typ * effect) option
+
+(* Strip the type annotations from an expression. *)
+val strip_exp : 'a exp -> unit exp
+val strip_pat : 'a pat -> unit pat
+
+(* Check an expression has some type. Returns a fully annotated
+ version of the expression, where each subexpression is annotated
+ with it's type and the Environment used while checking it. The can
+ be used to re-start the typechecking process on any
+ sub-expression. so local modifications to the AST can be
+ re-checked. *)
+val check_exp : Env.t -> unit exp -> typ -> tannot exp
+
+(* Partial functions: The expressions and patterns passed to these
+ functions must be guaranteed to have tannots of the form Some (env,
+ typ) for these to work. *)
+val typ_of : tannot exp -> typ
+val typ_of_annot : Ast.l * tannot -> typ
+
+val pat_typ_of : tannot pat -> typ
+
+val effect_of : tannot exp -> effect
+val effect_of_annot : tannot -> effect
+
+val propagate_exp_effect : tannot exp -> tannot exp
+
+(* Fully type-check an AST
+
+Some invariants that will hold of a fully checked AST are:
+
+ * No internal nodes, such as E_internal_exp, or E_comment nodes.
+
+ * E_vector_access nodes and similar will be replaced by function
+ calls E_app to vector access functions. This is different to the
+ old type checker.
+
+ * Every expressions type annotation (tannot) will be Some (typ, env).
+
+ * Also every pattern will be annotated with the type it matches.
+
+ * Toplevel expressions such as typedefs and some subexpressions such
+ as letbinds may have None as their tannots if it doesn't make sense
+ for them to have type annotations. *)
+val check : Env.t -> 'a defs -> tannot defs * Env.t
+
+val initial_env : Env.t
diff --git a/src/type_check_new.ml b/src/type_check_new.ml
deleted file mode 100644
index f3374fea..00000000
--- a/src/type_check_new.ml
+++ /dev/null
@@ -1,2644 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* Alasdair Armstrong *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-open Ast
-open Util
-open Ast_util
-open Big_int
-
-let opt_tc_debug = ref 0
-let depth = ref 0
-
-let rec indent n = match n with
- | 0 -> ""
- | n -> "| " ^ indent (n - 1)
-
-let typ_debug m = if !opt_tc_debug > 1 then prerr_endline (indent !depth ^ m) else ()
-
-let typ_print m = if !opt_tc_debug > 0 then prerr_endline (indent !depth ^ m) else ()
-
-let typ_warning m = prerr_endline ("Warning: " ^ m)
-
-exception Type_error of l * string;;
-
-let typ_error l m = raise (Type_error (l, m))
-
-let deinfix = function
- | Id_aux (Id v, l) -> Id_aux (DeIid v, l)
- | Id_aux (DeIid v, l) -> Id_aux (DeIid v, l)
-
-let string_of_bind (typquant, typ) = string_of_typquant typquant ^ ". " ^ string_of_typ typ
-
-let unaux_nexp (Nexp_aux (nexp, _)) = nexp
-let unaux_order (Ord_aux (ord, _)) = ord
-let unaux_typ (Typ_aux (typ, _)) = typ
-
-let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown)
-let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown)
-let mk_id str = Id_aux (Id str, Parse_ast.Unknown)
-let mk_infix_id str = Id_aux (DeIid str, Parse_ast.Unknown)
-
-let mk_id_typ id = Typ_aux (Typ_id id, Parse_ast.Unknown)
-
-let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown)
-let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown)
-
-let int_typ = mk_id_typ (mk_id "int")
-let nat_typ = mk_id_typ (mk_id "nat")
-let unit_typ = mk_id_typ (mk_id "unit")
-let bit_typ = mk_id_typ (mk_id "bit")
-let real_typ = mk_id_typ (mk_id "real")
-let app_typ id args = mk_typ (Typ_app (id, args))
-let atom_typ nexp = mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)]))
-let range_typ nexp1 nexp2 = mk_typ (Typ_app (mk_id "range", [mk_typ_arg (Typ_arg_nexp nexp1); mk_typ_arg (Typ_arg_nexp nexp2)]))
-let bool_typ = mk_id_typ (mk_id "bool")
-let string_typ = mk_id_typ (mk_id "string")
-
-let vector_typ n m ord typ =
- mk_typ (Typ_app (mk_id "vector",
- [mk_typ_arg (Typ_arg_nexp n);
- mk_typ_arg (Typ_arg_nexp m);
- mk_typ_arg (Typ_arg_order ord);
- mk_typ_arg (Typ_arg_typ typ)]))
-
-let is_range (Typ_aux (typ_aux, _)) =
- match typ_aux with
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)])
- when string_of_id f = "atom" -> Some (n, n)
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)])
- when string_of_id f = "range" -> Some (n1, n2)
- | _ -> None
-
-let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown)
-let nminus n1 n2 = Nexp_aux (Nexp_minus (n1, n2), Parse_ast.Unknown)
-let nsum n1 n2 = Nexp_aux (Nexp_sum (n1, n2), Parse_ast.Unknown)
-let ntimes n1 n2 = Nexp_aux (Nexp_times (n1, n2), Parse_ast.Unknown)
-let npow2 n = Nexp_aux (Nexp_exp n, Parse_ast.Unknown)
-let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown)
-
-let nc_eq n1 n2 = mk_nc (NC_fixed (n1, n2))
-let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2))
-let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown)
-let nc_gteq n1 n2 = NC_aux (NC_bounded_ge (n1, n2), Parse_ast.Unknown)
-let nc_lt n1 n2 = nc_lteq n1 (nsum n2 (nconstant 1))
-let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nconstant 1))
-
-let mk_lit l = E_aux (E_lit (L_aux (l, Parse_ast.Unknown)), (Parse_ast.Unknown, ()))
-
-(* FIXME: Can now negate all n_constraints *)
-let rec nc_negate (NC_aux (nc, _)) =
- match nc with
- | NC_bounded_ge (n1, n2) -> nc_lt n1 n2
- | NC_bounded_le (n1, n2) -> nc_gt n1 n2
- | NC_fixed (n1, n2) -> nc_neq n1 n2
- | NC_not_equal (n1, n2) -> nc_eq n1 n2
- | NC_and (n1, n2) -> mk_nc (NC_or (nc_negate n1, nc_negate n2))
- | NC_or (n1, n2) -> mk_nc (NC_and (nc_negate n1, nc_negate n2))
- | NC_nat_set_bounded (kid, []) -> typ_error Parse_ast.Unknown "Cannot negate empty nexp set"
- | NC_nat_set_bounded (kid, [int]) -> nc_neq (nvar kid) (nconstant int)
- | NC_nat_set_bounded (kid, int :: ints) ->
- mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_nat_set_bounded (kid, ints)))))
-
-(* Utilities for constructing effect sets *)
-
-let mk_effect effs =
- Effect_aux (Effect_set (List.map (fun be_aux -> BE_aux (be_aux, Parse_ast.Unknown)) effs), Parse_ast.Unknown)
-
-let no_effect = mk_effect []
-
-module BESet = Set.Make(BE)
-
-let union_effects e1 e2 =
- match e1, e2 with
- | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
- let base_effs3 = BESet.elements (BESet.of_list (base_effs1 @ base_effs2)) in
- Effect_aux (Effect_set base_effs3, Parse_ast.Unknown)
- | _, _ -> assert false (* We don't do Effect variables *)
-
-let equal_effects e1 e2 =
- match e1, e2 with
- | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
- BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0
- | _, _ -> assert false (* We don't do Effect variables *)
-
-(* An index_sort is a more general form of range type: it can either
- be IS_int, which represents every natural number, or some set of
- natural numbers given by an IS_prop expression of the form
- {'n. f('n) <= g('n) /\ ...} *)
-type index_sort =
- | IS_int
- | IS_prop of kid * (nexp * nexp) list
-
-let string_of_index_sort = function
- | IS_int -> "INT"
- | IS_prop (kid, constraints) ->
- "{" ^ string_of_kid kid ^ " | "
- ^ string_of_list " & " (fun (x, y) -> string_of_nexp x ^ " <= " ^ string_of_nexp y) constraints
- ^ "}"
-
-(**************************************************************************)
-(* 1. Substitutions *)
-(**************************************************************************)
-
-let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l)
-and nexp_subst_aux sv subst = function
- | Nexp_id v -> Nexp_id v
- | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid
- | Nexp_constant c -> Nexp_constant c
- | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
- | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
- | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
- | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp)
- | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp)
-
-let rec nexp_set_to_or l subst = function
- | [] -> typ_error l "Cannot substitute into empty nexp set"
- | [int] -> NC_fixed (subst, nconstant int)
- | (int :: ints) -> NC_or (mk_nc (NC_fixed (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints))
-
-let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l)
-and nc_subst_nexp_aux l sv subst = function
- | NC_fixed (n1, n2) -> NC_fixed (nexp_subst sv subst n1, nexp_subst sv subst n2)
- | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2)
- | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2)
- | NC_nat_set_bounded (kid, ints) as set_nc ->
- if Kid.compare kid sv = 0
- then nexp_set_to_or l (mk_nexp subst) ints
- else set_nc
- | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
- | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
-
-let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l)
-and typ_subst_nexp_aux sv subst = function
- | Typ_wild -> Typ_wild
- | Typ_id v -> Typ_id v
- | Typ_var kid -> Typ_var kid
- | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2, effs)
- | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs)
- | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args)
-and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l)
-and typ_subst_arg_nexp_aux sv subst = function
- | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp)
- | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ)
- | Typ_arg_order ord -> Typ_arg_order ord
- | Typ_arg_effect eff -> Typ_arg_effect eff
-
-let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l)
-and typ_subst_typ_aux sv subst = function
- | Typ_wild -> Typ_wild
- | Typ_id v -> Typ_id v
- | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid
- | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2, effs)
- | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs)
- | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args)
-and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l)
-and typ_subst_arg_typ_aux sv subst = function
- | Typ_arg_nexp nexp -> Typ_arg_nexp nexp
- | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ)
- | Typ_arg_order ord -> Typ_arg_order ord
- | Typ_arg_effect eff -> Typ_arg_effect eff
-
-let order_subst_aux sv subst = function
- | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid
- | Ord_inc -> Ord_inc
- | Ord_dec -> Ord_dec
-
-let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l)
-
-let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l)
-and typ_subst_order_aux sv subst = function
- | Typ_wild -> Typ_wild
- | Typ_id v -> Typ_id v
- | Typ_var kid -> Typ_var kid
- | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2, effs)
- | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs)
- | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args)
-and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l)
-and typ_subst_arg_order_aux sv subst = function
- | Typ_arg_nexp nexp -> Typ_arg_nexp nexp
- | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ)
- | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord)
- | Typ_arg_effect eff -> Typ_arg_effect eff
-
-let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l)
-and typ_subst_kid_aux sv subst = function
- | Typ_wild -> Typ_wild
- | Typ_id v -> Typ_id v
- | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid
- | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2, effs)
- | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs)
- | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args)
-and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l)
-and typ_subst_arg_kid_aux sv subst = function
- | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp)
- | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ)
- | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord)
- | Typ_arg_effect eff -> Typ_arg_effect eff
-
-let quant_item_subst_kid_aux sv subst = function
- | QI_id (KOpt_aux (KOpt_none kid, l)) as qid ->
- if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid
- | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid ->
- if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid
- | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc)
-
-let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l)
-and nexp_simp_aux = function
- | Nexp_sum (n1, n2) ->
- begin
- let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
- let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
- match n1_simp, n2_simp with
- | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 + c2)
- | _, Nexp_neg n2 -> Nexp_minus (n1, n2)
- | _, _ -> Nexp_sum (n1, n2)
- end
- | Nexp_times (n1, n2) ->
- begin
- let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
- let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
- match n1_simp, n2_simp with
- | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 * c2)
- | _, _ -> Nexp_times (n1, n2)
- end
- | Nexp_minus (n1, n2) ->
- begin
- let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in
- let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in
- typ_debug ("SIMP: " ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2);
- match n1_simp, n2_simp with
- | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 - c2)
- | _, _ -> Nexp_minus (n1, n2)
- end
- | nexp -> nexp
-
-let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l)
-
-let typquant_subst_kid_aux sv subst = function
- | TypQ_tq quants -> TypQ_tq (List.map (quant_item_subst_kid sv subst) quants)
- | TypQ_no_forall -> TypQ_no_forall
-
-let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l)
-
-(**************************************************************************)
-(* 2. Environment *)
-(**************************************************************************)
-
-type mut = Immutable | Mutable
-
-type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound
-
-module Env : sig
- type t
- val add_val_spec : id -> typquant * typ -> t -> t
- val get_val_spec : id -> t -> typquant * typ
- val is_union_constructor : id -> t -> bool
- val add_record : id -> typquant -> (typ * id) list -> t -> t
- val is_record : id -> t -> bool
- val get_accessor : id -> t -> typquant * typ
- val add_local : id -> mut * typ -> t -> t
- val add_variant : id -> typquant * type_union list -> t -> t
- val add_union_id : id -> typquant * typ -> t -> t
- val add_flow : id -> (typ -> typ) -> t -> t
- val get_flow : id -> t -> typ -> typ
- val get_register : id -> t -> typ
- val add_register : id -> typ -> t -> t
- val add_regtyp : id -> int -> int -> (index_range * id) list -> t -> t
- val is_regtyp : id -> t -> bool
- val get_regtyp : id -> t -> int * int * (index_range * id) list
- val is_mutable : id -> t -> bool
- val get_constraints : t -> n_constraint list
- val add_constraint : n_constraint -> t -> t
- val get_typ_var : kid -> t -> base_kind_aux
- val get_typ_vars : t -> base_kind_aux KBindings.t
- val add_typ_var : kid -> base_kind_aux -> t -> t
- val get_ret_typ : t -> typ option
- val add_ret_typ : typ -> t -> t
- val add_typ_synonym : id -> (typ_arg list -> typ) -> t -> t
- val get_typ_synonym : id -> t -> typ_arg list -> typ
- val add_overloads : id -> id list -> t -> t
- val get_overloads : id -> t -> id list
- val get_default_order : t -> order
- val set_default_order_inc : t -> t
- val set_default_order_dec : t -> t
- val add_enum : id -> id list -> t -> t
- val get_enum : id -> t -> id list
- val get_casts : t -> id list
- val allow_casts : t -> bool
- val no_casts : t -> t
- val enable_casts : t -> t
- val add_cast : id -> t -> t
- val lookup_id : id -> t -> lvar
- val fresh_kid : t -> kid
- val expand_synonyms : t -> typ -> typ
- val base_typ_of : t -> typ -> typ
- val empty : t
-end = struct
- type t =
- { top_val_specs : (typquant * typ) Bindings.t;
- locals : (mut * typ) Bindings.t;
- union_ids : (typquant * typ) Bindings.t;
- registers : typ Bindings.t;
- regtyps : (int * int * (index_range * id) list) Bindings.t;
- variants : (typquant * type_union list) Bindings.t;
- typ_vars : base_kind_aux KBindings.t;
- typ_synonyms : (typ_arg list -> typ) Bindings.t;
- overloads : (id list) Bindings.t;
- flow : (typ -> typ) Bindings.t;
- enums : IdSet.t Bindings.t;
- records : (typquant * (typ * id) list) Bindings.t;
- accessors : (typquant * typ) Bindings.t;
- casts : id list;
- allow_casts : bool;
- constraints : n_constraint list;
- default_order : order option;
- ret_typ : typ option
- }
-
- let empty =
- { top_val_specs = Bindings.empty;
- locals = Bindings.empty;
- union_ids = Bindings.empty;
- registers = Bindings.empty;
- regtyps = Bindings.empty;
- variants = Bindings.empty;
- typ_vars = KBindings.empty;
- typ_synonyms = Bindings.empty;
- overloads = Bindings.empty;
- flow = Bindings.empty;
- enums = Bindings.empty;
- records = Bindings.empty;
- accessors = Bindings.empty;
- casts = [];
- allow_casts = true;
- constraints = [];
- default_order = None;
- ret_typ = None;
- }
-
- let counter = ref 0
-
- let fresh_kid env =
- let fresh = Kid_aux (Var ("'fv" ^ string_of_int !counter), Parse_ast.Unknown) in
- incr counter; fresh
-
- let freshen_kid env kid (typq, typ) =
- let fresh = fresh_kid env in
- (typquant_subst_kid kid fresh typq, typ_subst_kid kid fresh typ)
-
- let freshen_bind env bind =
- List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars)
-
- let get_val_spec id env =
- try
- let bind = Bindings.find id env.top_val_specs in
- typ_debug ("get_val_spec: Env has " ^ string_of_list ", " (fun (kid, bk) -> string_of_kid kid ^ " => " ^ string_of_base_kind_aux bk) (KBindings.bindings env.typ_vars));
- let bind' = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in
- typ_debug ("get_val_spec: freshened to " ^ string_of_bind bind');
- bind'
- with
- | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id)
-
- let add_val_spec id bind env =
- if Bindings.mem id env.top_val_specs
- then typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound")
- else
- begin
- typ_print ("Adding val spec binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind);
- { env with top_val_specs = Bindings.add id bind env.top_val_specs }
- end
-
- let is_union_constructor id env =
- let is_ctor id (Tu_aux (tu, _)) = match tu with
- | Tu_id ctor_id when Id.compare id ctor_id = 0 -> true
- | Tu_ty_id (_, ctor_id) when Id.compare id ctor_id = 0 -> true
- | _ -> false
- in
- let type_unions = List.concat (List.map (fun (_, (_, tus)) -> tus) (Bindings.bindings env.variants)) in
- List.exists (is_ctor id) type_unions
-
- let get_typ_var kid env =
- try KBindings.find kid env.typ_vars with
- | Not_found -> typ_error (kid_loc kid) ("No kind identifier " ^ string_of_kid kid)
-
- let get_typ_vars env = env.typ_vars
-
- (* FIXME: Add an IdSet for builtin types *)
- let bound_typ_id env id =
- Bindings.mem id env.typ_synonyms
- || Bindings.mem id env.variants
- || Bindings.mem id env.records
- || Bindings.mem id env.regtyps
- || Bindings.mem id env.enums
- || Id.compare id (mk_id "range") = 0
- || Id.compare id (mk_id "vector") = 0
- || Id.compare id (mk_id "register") = 0
- || Id.compare id (mk_id "bit") = 0
- || Id.compare id (mk_id "unit") = 0
- || Id.compare id (mk_id "int") = 0
- || Id.compare id (mk_id "nat") = 0
- || Id.compare id (mk_id "bool") = 0
- || Id.compare id (mk_id "real") = 0
-
- (* Check if a type, order, or n-expression is well-formed. Throws a
- type error if the type is badly formed. FIXME: Add arity to type
- constructors, although arity checking for the builtin types does
- seem to be done by the initial ast check. *)
- let rec wf_typ env (Typ_aux (typ_aux, l)) =
- match typ_aux with
- | Typ_wild -> ()
- | Typ_id id when bound_typ_id env id -> ()
- | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id)
- | Typ_var kid when KBindings.mem kid env.typ_vars -> ()
- | Typ_var kid -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid)
- | Typ_fn (typ_arg, typ_ret, effs) -> wf_typ env typ_arg; wf_typ env typ_ret
- | Typ_tup typs -> List.iter (wf_typ env) typs
- | Typ_app (id, args) when bound_typ_id env id -> List.iter (wf_typ_arg env) args
- | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id)
- and wf_typ_arg env (Typ_arg_aux (typ_arg_aux, _)) =
- match typ_arg_aux with
- | Typ_arg_nexp nexp -> wf_nexp env nexp
- | Typ_arg_typ typ -> wf_typ env typ
- | Typ_arg_order ord -> wf_order env ord
- | Typ_arg_effect _ -> () (* Check: is this ever used? *)
- and wf_nexp env (Nexp_aux (nexp_aux, l)) =
- match nexp_aux with
- | Nexp_id _ -> typ_error l "Unimplemented: Nexp_id"
- | Nexp_var kid ->
- begin
- match get_typ_var kid env with
- | BK_nat -> ()
- | kind -> typ_error l ("Constraint is badly formed, "
- ^ string_of_kid kid ^ " has kind "
- ^ string_of_base_kind_aux kind ^ " but should have kind Nat")
- end
- | Nexp_constant _ -> ()
- | Nexp_times (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
- | Nexp_sum (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
- | Nexp_minus (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2
- | Nexp_exp nexp -> wf_nexp env nexp (* MAYBE: Could put restrictions on what is allowed here *)
- | Nexp_neg nexp -> wf_nexp env nexp
- and wf_order env (Ord_aux (ord_aux, l)) =
- match ord_aux with
- | Ord_var kid ->
- begin
- match get_typ_var kid env with
- | BK_order -> ()
- | kind -> typ_error l ("Order is badly formed, "
- ^ string_of_kid kid ^ " has kind "
- ^ string_of_base_kind_aux kind ^ " but should have kind Order")
- end
- | Ord_inc | Ord_dec -> ()
-
- let add_enum id ids env =
- if bound_typ_id env id
- then typ_error (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound")
- else
- begin
- typ_print ("Adding enum " ^ string_of_id id);
- { env with enums = Bindings.add id (IdSet.of_list ids) env.enums }
- end
-
- let get_enum id env =
- try IdSet.elements (Bindings.find id env.enums)
- with
- | Not_found -> typ_error (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist")
-
- let is_record id env = Bindings.mem id env.records
-
- let add_record id typq fields env =
- if bound_typ_id env id
- then typ_error (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound")
- else
- begin
- typ_print ("Adding record " ^ string_of_id id);
- let fold_accessors accs (typ, fid) =
- let acc_typ = mk_typ (Typ_fn (mk_id_typ id, typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in
- typ_print (indent 1 ^ "Adding accessor " ^ string_of_id fid ^ " :: " ^ string_of_bind (typq, acc_typ));
- Bindings.add fid (typq, acc_typ) accs
- in
- { env with records = Bindings.add id (typq, fields) env.records;
- accessors = List.fold_left fold_accessors env.accessors fields }
- end
-
- let get_accessor id env =
- let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in
- try freshen_bind (Bindings.find id env.accessors)
- with
- | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id id)
-
- let is_mutable id env =
- try
- let (mut, _) = Bindings.find id env.locals in
- match mut with
- | Mutable -> true
- | Immutable -> false
- with
- | Not_found -> typ_error (id_loc id) ("No local binding found for " ^ string_of_id id)
-
- let string_of_mtyp (mut, typ) = match mut with
- | Immutable -> string_of_typ typ
- | Mutable -> "ref<" ^ string_of_typ typ ^ ">"
-
- let add_local id mtyp env =
- begin
- wf_typ env (snd mtyp);
- typ_print ("Adding local binding " ^ string_of_id id ^ " :: " ^ string_of_mtyp mtyp);
- { env with locals = Bindings.add id mtyp env.locals }
- end
-
- let add_variant id variant env =
- begin
- typ_print ("Adding variant " ^ string_of_id id);
- { env with variants = Bindings.add id variant env.variants }
- end
-
- let add_union_id id bind env =
- begin
- typ_print ("Adding union identifier binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind);
- { env with union_ids = Bindings.add id bind env.union_ids }
- end
-
- let get_flow id env =
- try Bindings.find id env.flow with
- | Not_found -> fun typ -> typ
-
- let add_flow id f env =
- begin
- typ_print ("Adding flow constraints for " ^ string_of_id id);
- { env with flow = Bindings.add id (fun typ -> f (get_flow id env typ)) env.flow }
- end
-
- let get_register id env =
- try Bindings.find id env.registers with
- | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id)
-
- let get_overloads id env =
- try Bindings.find id env.overloads with
- | Not_found -> []
-
- let add_overloads id ids env =
- typ_print ("Adding overloads for " ^ string_of_id id ^ " [" ^ string_of_list ", " string_of_id ids ^ "]");
- { env with overloads = Bindings.add id ids env.overloads }
-
- let get_casts env = env.casts
-
- let check_index_range cmp f t (BF_aux (ir, l)) =
- match ir with
- | BF_single n ->
- if cmp f n && cmp n t
- then n
- else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n; t])
- | BF_range (n1, n2) ->
- if cmp f n1 && cmp n1 n2 && cmp n2 t
- then n2
- else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n1; n2; t])
- | BF_concat _ -> typ_error l "Index range concatenation currently unsupported"
-
- let rec check_index_ranges ids cmp base top = function
- | [] -> ()
- | ((range, id) :: ranges) ->
- if IdSet.mem id ids
- then typ_error (id_loc id) ("Duplicate id " ^ string_of_id id ^ " in register typedef")
- else
- begin
- let base' = check_index_range cmp base top range in
- check_index_ranges (IdSet.add id ids) cmp base' top ranges
- end
-
- let add_register id typ env =
- if Bindings.mem id env.registers
- then typ_error (id_loc id) ("Register " ^ string_of_id id ^ " is already bound")
- else
- begin
- typ_print ("Adding register binding " ^ string_of_id id ^ " :: " ^ string_of_typ typ);
- { env with registers = Bindings.add id typ env.registers }
- end
-
- let add_regtyp id base top ranges env =
- if Bindings.mem id env.regtyps
- then typ_error (id_loc id) ("Register type " ^ string_of_id id ^ " is already bound")
- else
- begin
- typ_print ("Adding register type " ^ string_of_id id);
- if base > top
- then check_index_ranges IdSet.empty (fun x y -> x > y) (base + 1) (top - 1) ranges
- else check_index_ranges IdSet.empty (fun x y -> x < y) (base - 1) (top + 1) ranges;
- { env with regtyps = Bindings.add id (base, top, ranges) env.regtyps }
- end
-
- let is_regtyp id env = Bindings.mem id env.regtyps
-
- let get_regtyp id env =
- try Bindings.find id env.regtyps with
- | Not_found -> typ_error (id_loc id) (string_of_id id ^ " is not a register type")
-
- let lookup_id id env =
- try
- let (mut, typ) = Bindings.find id env.locals in
- let flow = get_flow id env in
- Local (mut, flow typ)
- with
- | Not_found ->
- begin
- try Register (Bindings.find id env.registers) with
- | Not_found ->
- begin
- try
- let (enum, _) = List.find (fun (enum, ctors) -> IdSet.mem id ctors) (Bindings.bindings env.enums) in
- Enum (mk_typ (Typ_id enum))
- with
- | Not_found ->
- begin
- try
- let (typq, typ) = freshen_bind env (Bindings.find id env.union_ids) in
- Union (typq, typ)
- with
- | Not_found -> Unbound
- end
- end
- end
-
- let add_typ_var kid k env =
- if KBindings.mem kid env.typ_vars
- then typ_error (kid_loc kid) ("Kind identifier " ^ string_of_kid kid ^ " is already bound")
- else
- begin
- typ_debug ("Adding kind identifier binding " ^ string_of_kid kid ^ " :: " ^ string_of_base_kind_aux k);
- { env with typ_vars = KBindings.add kid k env.typ_vars }
- end
-
- let rec wf_constraint env (NC_aux (nc, _)) =
- match nc with
- | NC_fixed (n1, n2) -> wf_nexp env n1; wf_nexp env n2
- | NC_not_equal (n1, n2) -> wf_nexp env n1; wf_nexp env n2
- | NC_bounded_ge (n1, n2) -> wf_nexp env n1; wf_nexp env n2
- | NC_bounded_le (n1, n2) -> wf_nexp env n1; wf_nexp env n2
- | NC_nat_set_bounded (kid, ints) -> () (* MAYBE: We could demand that ints are all unique here *)
- | NC_or (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2
- | NC_and (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2
-
- let get_constraints env = env.constraints
-
- let add_constraint (NC_aux (_, l) as constr) env =
- wf_constraint env constr;
- begin
- typ_print ("Adding constraint " ^ string_of_n_constraint constr);
- { env with constraints = constr :: env.constraints }
- end
-
- let get_ret_typ env = env.ret_typ
-
- let add_ret_typ typ env = { env with ret_typ = Some typ }
-
- let allow_casts env = env.allow_casts
-
- let no_casts env = { env with allow_casts = false }
- let enable_casts env = { env with allow_casts = true }
-
- let add_cast cast env =
- typ_print ("Adding cast " ^ string_of_id cast);
- { env with casts = cast :: env.casts }
-
- let add_typ_synonym id synonym env =
- if Bindings.mem id env.typ_synonyms
- then typ_error (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists")
- else
- begin
- typ_print ("Adding type synonym " ^ string_of_id id);
- { env with typ_synonyms = Bindings.add id synonym env.typ_synonyms }
- end
-
- let get_typ_synonym id env = Bindings.find id env.typ_synonyms
-
- let rec expand_synonyms env (Typ_aux (typ, l) as t) =
- match typ with
- | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l)
- | Typ_fn (typ1, typ2, effs) -> Typ_aux (Typ_fn (expand_synonyms env typ1, expand_synonyms env typ2, effs), l)
- | Typ_app (id, args) ->
- begin
- try
- let synonym = Bindings.find id env.typ_synonyms in
- expand_synonyms env (synonym args)
- with
- | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l)
- end
- | Typ_id id ->
- begin
- try
- let synonym = Bindings.find id env.typ_synonyms in
- expand_synonyms env (synonym [])
- with
- | Not_found -> Typ_aux (Typ_id id, l)
- end
- | typ -> Typ_aux (typ, l)
- and expand_synonyms_arg env (Typ_arg_aux (typ_arg, l)) =
- match typ_arg with
- | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (expand_synonyms env typ), l)
- | arg -> Typ_arg_aux (arg, l)
-
- let base_typ_of env typ =
- let rec aux (Typ_aux (t,a)) =
- let rewrap t = Typ_aux (t,a) in
- match t with
- | Typ_fn (t1, t2, eff) ->
- rewrap (Typ_fn (aux t1, aux t2, eff))
- | Typ_tup ts ->
- rewrap (Typ_tup (List.map aux ts))
- | Typ_app (register, [Typ_arg_aux (Typ_arg_typ rtyp,_)])
- when string_of_id register = "register" ->
- aux rtyp
- | Typ_app (id, targs) ->
- rewrap (Typ_app (id, List.map aux_arg targs))
- | t -> rewrap t
- and aux_arg (Typ_arg_aux (targ,a)) =
- let rewrap targ = Typ_arg_aux (targ,a) in
- match targ with
- | Typ_arg_typ typ -> rewrap (Typ_arg_typ (aux typ))
- | targ -> rewrap targ in
- aux (expand_synonyms env typ)
-
- let get_default_order env =
- match env.default_order with
- | None -> typ_error Parse_ast.Unknown ("No default order has been set")
- | Some ord -> ord
-
- let set_default_order o env =
- match env.default_order with
- | None -> { env with default_order = Some (Ord_aux (o, Parse_ast.Unknown)) }
- | Some _ -> typ_error Parse_ast.Unknown ("Cannot change default order once already set")
-
- let set_default_order_inc = set_default_order Ord_inc
- let set_default_order_dec = set_default_order Ord_dec
-
-end
-
-
-let add_typquant (quant : typquant) (env : Env.t) : Env.t =
- let rec add_quant_item env = function
- | QI_aux (qi, _) -> add_quant_item_aux env qi
- and add_quant_item_aux env = function
- | QI_const constr -> Env.add_constraint constr env
- | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var kid BK_nat env
- | QI_id (KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (k, _)], _), kid), _)) -> Env.add_typ_var kid k env
- | QI_id (KOpt_aux (_, l)) -> typ_error l "Type variable had non base kinds!"
- in
- match quant with
- | TypQ_aux (TypQ_no_forall, _) -> env
- | TypQ_aux (TypQ_tq quants, _) -> List.fold_left add_quant_item env quants
-
-(* Create vectors with the default order from the environment *)
-
-let dvector_typ env n m typ = vector_typ n m (Env.get_default_order env) typ
-
-let lvector_typ env l typ =
- match Env.get_default_order env with
- | Ord_aux (Ord_inc, _) as ord ->
- vector_typ (nconstant 0) l ord typ
- | Ord_aux (Ord_dec, _) as ord ->
- vector_typ (nminus l (nconstant 1)) l ord typ
-
-let initial_env =
- Env.empty
- |> Env.add_typ_synonym (mk_id "atom") (fun args -> mk_typ (Typ_app (mk_id "range", args @ args)))
-
-(**************************************************************************)
-(* 3. Subtyping and constraint solving *)
-(**************************************************************************)
-
-let order_eq (Ord_aux (ord_aux1, _)) (Ord_aux (ord_aux2, _)) =
- match ord_aux1, ord_aux2 with
- | Ord_inc, Ord_inc -> true
- | Ord_dec, Ord_dec -> true
- | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0
- | _, _ -> false
-
-let rec props_subst sv subst props =
- match props with
- | [] -> []
- | ((nexp1, nexp2) :: props) -> (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) :: props_subst sv subst props
-
-type tnf =
- | Tnf_wild
- | Tnf_id of id
- | Tnf_var of kid
- | Tnf_tup of tnf list
- | Tnf_index_sort of index_sort
- | Tnf_app of id * tnf_arg list
-and tnf_arg =
- | Tnf_arg_nexp of nexp
- | Tnf_arg_typ of tnf
- | Tnf_arg_order of order
- | Tnf_arg_effect of effect
-
-let rec string_of_tnf = function
- | Tnf_wild -> "_"
- | Tnf_id id -> string_of_id id
- | Tnf_var kid -> string_of_kid kid
- | Tnf_tup tnfs -> "(" ^ string_of_list ", " string_of_tnf tnfs ^ ")"
- | Tnf_app (id, args) -> string_of_id id ^ "<" ^ string_of_list ", " string_of_tnf_arg args ^ ">"
- | Tnf_index_sort IS_int -> "INT"
- | Tnf_index_sort (IS_prop (kid, props)) ->
- "{" ^ string_of_kid kid ^ " | " ^ string_of_list " & " (fun (n1, n2) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2) props ^ "}"
-and string_of_tnf_arg = function
- | Tnf_arg_nexp n -> string_of_nexp n
- | Tnf_arg_typ tnf -> string_of_tnf tnf
- | Tnf_arg_order o -> string_of_order o
- | Tnf_arg_effect eff -> string_of_effect eff
-
-let rec normalize_typ env (Typ_aux (typ, l)) =
- match typ with
- | Typ_wild -> Tnf_wild
- | Typ_id (Id_aux (Id "int", _)) -> Tnf_index_sort IS_int
- | Typ_id (Id_aux (Id "nat", _)) ->
- let kid = Env.fresh_kid env in Tnf_index_sort (IS_prop (kid, [(nconstant 0, nvar kid)]))
- | Typ_id v ->
- begin
- try normalize_typ env (Env.get_typ_synonym v env []) with
- | Not_found -> Tnf_id v
- end
- | Typ_var kid -> Tnf_var kid
- | Typ_tup typs -> Tnf_tup (List.map (normalize_typ env) typs)
- | Typ_app (f, []) -> normalize_typ env (Typ_aux (Typ_id f, l))
- | Typ_app (Id_aux (Id "range", _), [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]) ->
- let kid = Env.fresh_kid env in
- Tnf_index_sort (IS_prop (kid, [(n1, nvar kid); (nvar kid, n2)]))
- | Typ_app ((Id_aux (Id "vector", _) as vector), args) ->
- Tnf_app (vector, List.map (normalize_typ_arg env) args)
- | Typ_app (id, args) ->
- begin
- try normalize_typ env (Env.get_typ_synonym id env args) with
- | Not_found -> Tnf_app (id, List.map (normalize_typ_arg env) args)
- end
- | Typ_fn _ -> typ_error l ("Cannot normalize function type " ^ string_of_typ (Typ_aux (typ, l)))
-and normalize_typ_arg env (Typ_arg_aux (typ_arg, _)) =
- match typ_arg with
- | Typ_arg_nexp n -> Tnf_arg_nexp n
- | Typ_arg_typ typ -> Tnf_arg_typ (normalize_typ env typ)
- | Typ_arg_order o -> Tnf_arg_order o
- | Typ_arg_effect e -> Tnf_arg_effect e
-
-(* Here's how the constraint generation works for subtyping
-
-X(b,c...) --> {a. Y(a,b,c...)} \subseteq {a. Z(a,b,c...)}
-
-this is equivalent to
-
-\forall b c. X(b,c) --> \forall a. Y(a,b,c) --> Z(a,b,c)
-
-\forall b c. X(b,c) --> \forall a. !Y(a,b,c) \/ !Z^-1(a,b,c)
-
-\forall b c. X(b,c) --> !\exists a. Y(a,b,c) /\ Z^-1(a,b,c)
-
-\forall b c. !X(b,c) \/ !\exists a. Y(a,b,c) /\ Z^-1(a,b,c)
-
-!\exists b c. X(b,c) /\ \exists a. Y(a,b,c) /\ Z^-1(a,b,c)
-
-!\exists a b c. X(b,c) /\ Y(a,b,c) /\ Z^-1(a,b,c)
-
-which is then a problem we can feed to the constraint solver expecting unsat.
- *)
-
-let rec nexp_constraint var_of (Nexp_aux (nexp, l)) =
- match nexp with
- | Nexp_id v -> typ_error l "Unimplemented: Cannot generate constraint from Nexp_id"
- | Nexp_var kid -> Constraint.variable (var_of kid)
- | Nexp_constant c -> Constraint.constant (big_int_of_int c)
- | Nexp_times (nexp1, nexp2) -> Constraint.mult (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint var_of nexp)
- | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint var_of nexp)
-
-let rec nc_constraint var_of (NC_aux (nc, l)) =
- match nc with
- | NC_fixed (nexp1, nexp2) -> Constraint.eq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | NC_not_equal (nexp1, nexp2) -> Constraint.neq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | NC_bounded_ge (nexp1, nexp2) -> Constraint.gteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | NC_bounded_le (nexp1, nexp2) -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | NC_nat_set_bounded (_, []) -> Constraint.literal false
- | NC_nat_set_bounded (kid, (int :: ints)) ->
- List.fold_left Constraint.disj
- (Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int int)))
- (List.map (fun i -> Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int i))) ints)
- | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint var_of nc1) (nc_constraint var_of nc2)
- | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint var_of nc1) (nc_constraint var_of nc2)
-
-let rec nc_constraints var_of ncs =
- match ncs with
- | [] -> Constraint.literal true
- | [nc] -> nc_constraint var_of nc
- | (nc :: ncs) ->
- Constraint.conj (nc_constraint var_of nc) (nc_constraints var_of ncs)
-
-let prove_z3 env nc =
- typ_print ("Prove " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc);
- let module Bindings = Map.Make(Kid) in
- let bindings = ref Bindings.empty in
- let fresh_var kid =
- let n = Bindings.cardinal !bindings in
- bindings := Bindings.add kid n !bindings;
- n
- in
- let var_of kid =
- try Bindings.find kid !bindings with
- | Not_found -> fresh_var kid
- in
- let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.negate (nc_constraint var_of nc)) in
- match Constraint.call_z3 constr with
- | Constraint.Unsat _ -> typ_debug "unsat"; true
- | Constraint.Unknown [] -> typ_debug "sat"; false
- | Constraint.Unknown _ -> typ_debug "unknown"; false
-
-let prove env (NC_aux (nc_aux, _) as nc) =
- let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) =
- match n1, n2 with
- | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true
- | _, _ -> false
- in
- match nc_aux with
- | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 = c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
- | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
- | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 >= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true
- | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <> c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
- | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 > c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
- | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 < c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false
- | _ -> prove_z3 env nc
-
-let rec subtyp_tnf env tnf1 tnf2 =
- typ_print ("Subset " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_tnf tnf1 ^ " " ^ string_of_tnf tnf2);
- let module Bindings = Map.Make(Kid) in
- let bindings = ref Bindings.empty in
- let fresh_var kid =
- let n = Bindings.cardinal !bindings in
- bindings := Bindings.add kid n !bindings;
- n
- in
- let var_of kid =
- try Bindings.find kid !bindings with
- | Not_found -> fresh_var kid
- in
- let rec neg_props props =
- match props with
- | [] -> Constraint.literal false
- | [(nexp1, nexp2)] -> Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | ((nexp1, nexp2) :: props) ->
- Constraint.disj (Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (neg_props props)
- in
- let rec pos_props props =
- match props with
- | [] -> Constraint.literal true
- | [(nexp1, nexp2)] -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)
- | ((nexp1, nexp2) :: props) ->
- Constraint.conj (Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (pos_props props)
- in
- match (tnf1, tnf2) with
- | Tnf_wild, Tnf_wild -> true
- | Tnf_id v1, Tnf_id v2 -> Id.compare v1 v2 = 0
- | Tnf_var kid1, Tnf_var kid2 -> Kid.compare kid1 kid2 = 0
- | Tnf_tup tnfs1, Tnf_tup tnfs2 ->
- begin
- try List.for_all2 (subtyp_tnf env) tnfs1 tnfs2 with
- | Invalid_argument _ -> false
- end
- | Tnf_app (v1, args1), Tnf_app (v2, args2) -> Id.compare v1 v2 = 0 && List.for_all2 (tnf_args_eq env) args1 args2
- | Tnf_index_sort IS_int, Tnf_index_sort IS_int -> true
- | Tnf_index_sort (IS_prop _), Tnf_index_sort IS_int -> true
- | Tnf_index_sort (IS_prop (kid1, prop1)), Tnf_index_sort (IS_prop (kid2, prop2)) ->
- begin
- let kid3 = Env.fresh_kid env in
- let (prop1, prop2) = props_subst kid1 (Nexp_var kid3) prop1, props_subst kid2 (Nexp_var kid3) prop2 in
- let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.conj (pos_props prop1) (neg_props prop2)) in
- match Constraint.call_z3 constr with
- | Constraint.Unsat _ -> typ_debug "unsat"; true
- | Constraint.Unknown [] -> typ_debug "sat"; false
- | Constraint.Unknown _ -> typ_debug "unknown"; false
- end
- | _, _ -> false
-
-and tnf_args_eq env arg1 arg2 =
- match arg1, arg2 with
- | Tnf_arg_nexp n1, Tnf_arg_nexp n2 -> prove env (NC_aux (NC_fixed (n1, n2), Parse_ast.Unknown))
- | Tnf_arg_order ord1, Tnf_arg_order ord2 -> order_eq ord1 ord2
- | Tnf_arg_typ tnf1, Tnf_arg_typ tnf2 -> subtyp_tnf env tnf1 tnf2 && subtyp_tnf env tnf2 tnf1
- | _, _ -> assert false
-
-let subtyp l env typ1 typ2 =
- if subtyp_tnf env (normalize_typ env typ1) (normalize_typ env typ2)
- then ()
- else typ_error l (string_of_typ typ1
- ^ " is not a subtype of " ^ string_of_typ typ2
- ^ " in context " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env))
-
-let typ_equality l env typ1 typ2 =
- subtyp l env typ1 typ2; subtyp l env typ2 typ1
-
-(**************************************************************************)
-(* 4. Unification *)
-(**************************************************************************)
-
-let rec nexp_frees (Nexp_aux (nexp, l)) =
- match nexp with
- | Nexp_id _ -> typ_error l "Unimplemented Nexp_id in nexp_frees"
- | Nexp_var kid -> KidSet.singleton kid
- | Nexp_constant _ -> KidSet.empty
- | Nexp_times (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
- | Nexp_sum (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
- | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2)
- | Nexp_exp n -> nexp_frees n
- | Nexp_neg n -> nexp_frees n
-
-let order_frees (Ord_aux (ord_aux, l)) =
- match ord_aux with
- | Ord_var kid -> KidSet.singleton kid
- | _ -> KidSet.empty
-
-let rec typ_frees (Typ_aux (typ_aux, l)) =
- match typ_aux with
- | Typ_wild -> KidSet.empty
- | Typ_id v -> KidSet.empty
- | Typ_var kid -> KidSet.singleton kid
- | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map typ_frees typs)
- | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map typ_arg_frees args)
-and typ_arg_frees (Typ_arg_aux (typ_arg_aux, l)) =
- match typ_arg_aux with
- | Typ_arg_nexp n -> nexp_frees n
- | Typ_arg_typ typ -> typ_frees typ
- | Typ_arg_order ord -> order_frees ord
- | Typ_arg_effect _ -> assert false
-
-let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) =
- match nexp1, nexp2 with
- | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0
- | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 = 0
- | Nexp_constant c1, Nexp_constant c2 -> c1 = c2
- | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
- | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
- | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b
- | Nexp_exp n1, Nexp_exp n2 -> nexp_identical n1 n2
- | Nexp_neg n1, Nexp_neg n2 -> nexp_identical n1 n2
- | _, _ -> false
-
-let ord_identical (Ord_aux (ord1, _)) (Ord_aux (ord2, _)) =
- match ord1, ord2 with
- | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0
- | Ord_inc, Ord_inc -> true
- | Ord_dec, Ord_dec -> true
- | _, _ -> false
-
-let rec typ_identical (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) =
- match typ1, typ2 with
- | Typ_wild, Typ_wild -> true
- | Typ_id v1, Typ_id v2 -> Id.compare v1 v2 = 0
- | Typ_var kid1, Typ_var kid2 -> Kid.compare kid1 kid2 = 0
- | Typ_tup typs1, Typ_tup typs2 ->
- begin
- try List.for_all2 typ_identical typs1 typs2 with
- | Invalid_argument _ -> false
- end
- | Typ_app (f1, args1), Typ_app (f2, args2) ->
- begin
- try Id.compare f1 f2 = 0 && List.for_all2 typ_arg_identical args1 args2 with
- | Invalid_argument _ -> false
- end
- | _, _ -> false
-and typ_arg_identical (Typ_arg_aux (arg1, _)) (Typ_arg_aux (arg2, _)) =
- match arg1, arg2 with
- | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2
- | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical typ1 typ2
- | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2
- | Typ_arg_effect _, Typ_arg_effect _ -> assert false
-
-type uvar =
- | U_nexp of nexp
- | U_order of order
- | U_effect of effect
- | U_typ of typ
-
-exception Unification_error of l * string;;
-
-let unify_error l str = raise (Unification_error (l, str))
-
-let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) =
- typ_debug ("UNIFYING NEXPS " ^ string_of_nexp nexp1 ^ " AND " ^ string_of_nexp nexp2 ^ " FOR GOALS " ^ string_of_list ", " string_of_kid (KidSet.elements goals));
- if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals)
- then
- begin
- if prove env (NC_aux (NC_fixed (nexp1, nexp2), Parse_ast.Unknown))
- then None
- else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal")
- end
- else
- match nexp_aux1 with
- | Nexp_id v -> unify_error l "Unimplemented Nexp_id in unify nexp"
- | Nexp_var kid when KidSet.mem kid goals -> Some (kid, nexp2)
- | Nexp_constant c1 ->
- begin
- match nexp_aux2 with
- | Nexp_constant c2 -> if c1 = c2 then None else unify_error l "Constants are not the same"
- | _ -> unify_error l "Unification error"
- end
- | Nexp_sum (n1a, n1b) ->
- if KidSet.is_empty (nexp_frees n1b)
- then unify_nexps l env goals n1a (nminus nexp2 n1b)
- else
- if KidSet.is_empty (nexp_frees n1a)
- then unify_nexps l env goals n1b (nminus nexp2 n1a)
- else unify_error l ("Both sides of Nat expression " ^ string_of_nexp nexp1
- ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2)
- | Nexp_minus (n1a, n1b) ->
- if KidSet.is_empty (nexp_frees n1b)
- then unify_nexps l env goals n1a (nsum nexp2 n1b)
- else unify_error l ("Cannot unify minus Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
- | Nexp_times (n1a, n1b) ->
- if KidSet.is_empty (nexp_frees n1a)
- then
- begin
- match nexp_aux2 with
- | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1a, n2a), Parse_ast.Unknown)) ->
- unify_nexps l env goals n1b n2b
- | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
- end
- else if KidSet.is_empty (nexp_frees n1b)
- then
- begin
- match nexp_aux2 with
- | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1b, n2b), Parse_ast.Unknown)) ->
- unify_nexps l env goals n1a n2a
- | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
- end
- else unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
- | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
-
-let string_of_uvar = function
- | U_nexp n -> string_of_nexp n
- | U_order o -> string_of_order o
- | U_effect eff -> string_of_effect eff
- | U_typ typ -> string_of_typ typ
-
-let unify_order l (Ord_aux (ord_aux1, _) as ord1) (Ord_aux (ord_aux2, _) as ord2) =
- typ_debug ("UNIFYING ORDERS " ^ string_of_order ord1 ^ " AND " ^ string_of_order ord2);
- match ord_aux1, ord_aux2 with
- | Ord_var kid, _ -> KBindings.singleton kid (U_order ord2)
- | Ord_inc, Ord_inc -> KBindings.empty
- | Ord_dec, Ord_dec -> KBindings.empty
- | _, _ -> unify_error l (string_of_order ord1 ^ " cannot be unified with " ^ string_of_order ord2)
-
-let subst_unifiers unifiers typ =
- let subst_unifier typ (kid, uvar) =
- match uvar with
- | U_nexp nexp -> typ_subst_nexp kid (unaux_nexp nexp) typ
- | U_order ord -> typ_subst_order kid (unaux_order ord) typ
- | U_typ subst -> typ_subst_typ kid (unaux_typ subst) typ
- | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier"
- in
- List.fold_left subst_unifier typ (KBindings.bindings unifiers)
-
-let subst_args_unifiers unifiers typ_args =
- let subst_unifier typ_args (kid, uvar) =
- match uvar with
- | U_nexp nexp -> List.map (typ_subst_arg_nexp kid (unaux_nexp nexp)) typ_args
- | U_order ord -> List.map (typ_subst_arg_order kid (unaux_order ord)) typ_args
- | U_typ subst -> List.map (typ_subst_arg_typ kid (unaux_typ subst)) typ_args
- | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier"
- in
- List.fold_left subst_unifier typ_args (KBindings.bindings unifiers)
-
-let unify l env typ1 typ2 =
- typ_print ("Unify " ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2);
- let goals = KidSet.inter (KidSet.diff (typ_frees typ1) (typ_frees typ2)) (typ_frees typ1) in
- let merge_unifiers l kid uvar1 uvar2 =
- match uvar1, uvar2 with
- | Some (U_nexp n1), Some (U_nexp n2) ->
- if nexp_identical n1 n2 then Some (U_nexp n1)
- else unify_error l ("Multiple non-identical unifiers for " ^ string_of_kid kid
- ^ ": " ^ string_of_nexp n1 ^ " and " ^ string_of_nexp n2)
- | Some _, Some _ -> unify_error l "Multiple non-identical non-nexp unifiers"
- | None, Some u2 -> Some u2
- | Some u1, None -> Some u1
- | None, None -> None
- in
- let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) =
- typ_debug ("UNIFYING TYPES " ^ string_of_typ typ1 ^ " AND " ^ string_of_typ typ2);
- match typ1_aux, typ2_aux with
- | Typ_wild, Typ_wild -> KBindings.empty
- | Typ_id v1, Typ_id v2 ->
- if Id.compare v1 v2 = 0 then KBindings.empty
- else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
- | Typ_id v1, Typ_app (f2, []) ->
- if Id.compare v1 f2 = 0 then KBindings.empty
- else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
- | Typ_app (f1, []), Typ_id v2 ->
- if Id.compare f1 v2 = 0 then KBindings.empty
- else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
- | Typ_var kid, _ when KidSet.mem kid goals -> KBindings.singleton kid (U_typ typ2)
- | Typ_var kid1, Typ_var kid2 when Kid.compare kid1 kid2 = 0 -> KBindings.empty
- | Typ_tup typs1, Typ_tup typs2 ->
- begin
- try List.fold_left (KBindings.merge (merge_unifiers l)) KBindings.empty (List.map2 (unify_typ l) typs1 typs2) with
- | Invalid_argument _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2
- ^ " tuple type is of different length")
- end
- | Typ_app (f1, args1), Typ_app (f2, args2) when Id.compare f1 f2 = 0 ->
- unify_typ_arg_list 0 KBindings.empty [] [] args1 args2
- | _, _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2)
-
- and unify_typ_arg_list unified acc uargs1 uargs2 args1 args2 =
- match args1, args2 with
- | [], [] when unified = 0 && List.length uargs1 > 0 ->
- unify_error l "Could not unify arg lists" (*FIXME improve error *)
- | [], [] when unified > 0 && List.length uargs1 > 0 -> unify_typ_arg_list 0 acc [] [] uargs1 uargs2
- | [], [] when List.length uargs1 = 0 -> acc
- | (a1 :: a1s), (a2 :: a2s) ->
- begin
- let unifiers, success =
- try unify_typ_args l a1 a2, true with
- | Unification_error _ -> KBindings.empty, false
- in
- let a1s = subst_args_unifiers unifiers a1s in
- let a2s = subst_args_unifiers unifiers a2s in
- let uargs1 = subst_args_unifiers unifiers uargs1 in
- let uargs2 = subst_args_unifiers unifiers uargs2 in
- if success
- then unify_typ_arg_list (unified + 1) (KBindings.merge (merge_unifiers l) unifiers acc) uargs1 uargs2 a1s a2s
- else unify_typ_arg_list unified acc (a1 :: uargs1) (a2 :: uargs2) a1s a2s
- end
- | _, _ -> unify_error l "Cannot unify type lists of different length"
-
- and unify_typ_args l (Typ_arg_aux (typ_arg_aux1, _) as typ_arg1) (Typ_arg_aux (typ_arg_aux2, _) as typ_arg2) =
- match typ_arg_aux1, typ_arg_aux2 with
- | Typ_arg_nexp n1, Typ_arg_nexp n2 ->
- begin
- match unify_nexps l env goals (nexp_simp n1) (nexp_simp n2) with
- | Some (kid, unifier) -> KBindings.singleton kid (U_nexp unifier)
- | None -> KBindings.empty
- end
- | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l typ1 typ2
- | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l ord1 ord2
- | Typ_arg_effect _, Typ_arg_effect _ -> assert false
- | _, _ -> unify_error l (string_of_typ_arg typ_arg1 ^ " cannot be unified with type argument " ^ string_of_typ_arg typ_arg2)
- in
- let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in
- unify_typ l typ1 typ2
-
-(**************************************************************************)
-(* 5. Type checking expressions *)
-(**************************************************************************)
-
-(* The type checker produces a fully annoted AST - tannot is the type
- of these type annotations. *)
-type tannot = (Env.t * typ * effect) option
-
-let infer_lit env (L_aux (lit_aux, l) as lit) =
- match lit_aux with
- | L_unit -> unit_typ
- | L_zero -> bit_typ
- | L_one -> bit_typ
- | L_num n -> atom_typ (nconstant n)
- | L_true -> bool_typ
- | L_false -> bool_typ
- | L_string _ -> string_typ
- | L_real _ -> real_typ
- | L_bin str ->
- begin
- match Env.get_default_order env with
- | Ord_aux (Ord_inc, _) ->
- dvector_typ env (nconstant 0) (nconstant (String.length str)) (mk_typ (Typ_id (mk_id "bit")))
- | Ord_aux (Ord_dec, _) ->
- dvector_typ env
- (nconstant (String.length str - 1))
- (nconstant (String.length str))
- (mk_typ (Typ_id (mk_id "bit")))
- end
- | L_hex str ->
- begin
- match Env.get_default_order env with
- | Ord_aux (Ord_inc, _) ->
- dvector_typ env (nconstant 0) (nconstant (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit")))
- | Ord_aux (Ord_dec, _) ->
- dvector_typ env
- (nconstant (String.length str * 4 - 1))
- (nconstant (String.length str * 4))
- (mk_typ (Typ_id (mk_id "bit")))
- end
- | L_undef -> typ_error l "Cannot infer the type of undefined"
-
-let quant_items : typquant -> quant_item list = function
- | TypQ_aux (TypQ_tq qis, _) -> qis
- | TypQ_aux (TypQ_no_forall, _) -> []
-
-let is_nat_kid kid = function
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid'), _) -> Kid.compare kid kid' = 0
- | KOpt_aux (KOpt_none kid', _) -> Kid.compare kid kid' = 0
- | _ -> false
-
-let is_order_kid kid = function
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid'), _) -> Kid.compare kid kid' = 0
- | _ -> false
-
-let is_typ_kid kid = function
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid'), _) -> Kid.compare kid kid' = 0
- | _ -> false
-
-let rec instantiate_quants quants kid uvar = match quants with
- | [] -> []
- | ((QI_aux (QI_id kinded_id, _) as quant) :: quants) ->
- typ_debug ("instantiating quant " ^ string_of_quant_item quant);
- begin
- match uvar with
- | U_nexp nexp ->
- if is_nat_kid kid kinded_id
- then instantiate_quants quants kid uvar
- else quant :: instantiate_quants quants kid uvar
- | U_order ord ->
- if is_order_kid kid kinded_id
- then instantiate_quants quants kid uvar
- else quant :: instantiate_quants quants kid uvar
- | U_typ typ ->
- if is_typ_kid kid kinded_id
- then instantiate_quants quants kid uvar
- else quant :: instantiate_quants quants kid uvar
- | _ -> typ_error Parse_ast.Unknown "Cannot instantiate quantifier"
- end
- | ((QI_aux (QI_const nc, l)) :: quants) ->
- begin
- match uvar with
- | U_nexp nexp ->
- QI_aux (QI_const (nc_subst_nexp kid (unaux_nexp nexp) nc), l) :: instantiate_quants quants kid uvar
- | _ -> (QI_aux (QI_const nc, l)) :: instantiate_quants quants kid uvar
- end
-
-let destructure_vec_typ l env typ =
- let destructure_vec_typ' l = function
- | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _);
- Typ_arg_aux (Typ_arg_nexp n2, _);
- Typ_arg_aux (Typ_arg_order o, _);
- Typ_arg_aux (Typ_arg_typ vtyp, _)]
- ), _) when string_of_id id = "vector" -> (n1, n2, o, vtyp)
- | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ)
- in
- destructure_vec_typ' l (Env.expand_synonyms env typ)
-
-let typ_of_annot (l, tannot) = match tannot with
- | Some (_, typ, _) -> typ
- | None -> raise (Reporting_basic.err_unreachable l "no type annotation")
-
-let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
-
-let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
-
-(* Flow typing *)
-
-let destructure_atom (Typ_aux (typ_aux, _)) =
- match typ_aux with
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c, _)), _)])
- when string_of_id f = "atom" -> c
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c1, _)), _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)])
- when string_of_id f = "range" && c1 = c2 -> c1
- | _ -> assert false
-
-let destructure_atom_nexp (Typ_aux (typ_aux, _)) =
- match typ_aux with
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)])
- when string_of_id f = "atom" -> n
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_nexp _, _)])
- when string_of_id f = "range" -> n
- | _ -> assert false
-
-let restrict_range_upper c1 (Typ_aux (typ_aux, l) as typ) =
- match typ_aux with
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp, _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)])
- when string_of_id f = "range" ->
- range_typ nexp (nconstant (min c1 c2))
- | _ -> typ
-
-let restrict_range_lower c1 (Typ_aux (typ_aux, l) as typ) =
- match typ_aux with
- | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _); Typ_arg_aux (Typ_arg_nexp nexp, _)])
- when string_of_id f = "range" ->
- range_typ (nconstant (max c1 c2)) nexp
- | _ -> typ
-
-type flow_constraint =
- | Flow_lteq of int
- | Flow_gteq of int
-
-let apply_flow_constraint = function
- | Flow_lteq c -> (restrict_range_upper c, restrict_range_lower (c + 1))
- | Flow_gteq c -> (restrict_range_lower c, restrict_range_upper (c - 1))
-
-let rec infer_flow env (E_aux (exp_aux, (l, _))) =
- match exp_aux with
- | E_app (f, [x; y]) when string_of_id f = "lteq_atom_atom" ->
- let n1 = destructure_atom_nexp (typ_of x) in
- let n2 = destructure_atom_nexp (typ_of y) in
- [], [nc_lteq n1 n2]
- | E_app (f, [x; y]) when string_of_id f = "gteq_atom_atom" ->
- let n1 = destructure_atom_nexp (typ_of x) in
- let n2 = destructure_atom_nexp (typ_of y) in
- [], [nc_gteq n1 n2]
- | E_app (f, [x; y]) when string_of_id f = "lt_atom_atom" ->
- let n1 = destructure_atom_nexp (typ_of x) in
- let n2 = destructure_atom_nexp (typ_of y) in
- [], [nc_lt n1 n2]
- | E_app (f, [x; y]) when string_of_id f = "gt_atom_atom" ->
- let n1 = destructure_atom_nexp (typ_of x) in
- let n2 = destructure_atom_nexp (typ_of y) in
- [], [nc_gt n1 n2]
- | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lt_range_atom" ->
- let kid = Env.fresh_kid env in
- let c = destructure_atom (typ_of y) in
- [(v, Flow_lteq (c - 1))], []
- | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" ->
- let kid = Env.fresh_kid env in
- let c = destructure_atom (typ_of y) in
- [(v, Flow_lteq c)], []
- | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gt_range_atom" ->
- let kid = Env.fresh_kid env in
- let c = destructure_atom (typ_of y) in
- [(v, Flow_gteq (c + 1))], []
- | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" ->
- let kid = Env.fresh_kid env in
- let c = destructure_atom (typ_of y) in
- [(v, Flow_gteq c)], []
- | _ -> [], []
-
-let rec add_flows b flows env =
- match flows with
- | [] -> env
- | (id, flow) :: flows when b -> add_flows true flows (Env.add_flow id (fst (apply_flow_constraint flow)) env)
- | (id, flow) :: flows -> add_flows false flows (Env.add_flow id (snd (apply_flow_constraint flow)) env)
-
-let rec add_constraints constrs env =
- List.fold_left (fun env constr -> Env.add_constraint constr env) env constrs
-
-(* When doing implicit type coercion, for performance reasons we want
- to filter out the possible casts to only those that could
- reasonably apply. We don't mind if we try some coercions that are
- impossible, but we should be careful to never rule out a possible
- cast - match_typ and filter_casts implement this logic. It must be
- the case that if two types unify, then they match. *)
-let rec match_typ (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) =
- match typ1, typ2 with
- | Typ_wild, Typ_wild -> true
- | _, Typ_var kid2 -> true
- | Typ_id v1, Typ_id v2 when Id.compare v1 v2 = 0 -> true
- | Typ_id v1, Typ_id v2 when string_of_id v1 = "int" && string_of_id v2 = "nat" -> true
- | Typ_tup typs1, Typ_tup typs2 -> List.for_all2 match_typ typs1 typs2
- | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "atom" -> true
- | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "atom" -> true
- | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "range" -> true
- | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "range" -> true
- | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "range" && string_of_id f2 = "atom" -> true
- | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "atom" && string_of_id f2 = "range" -> true
- | Typ_app (f1, _), Typ_app (f2, _) when Id.compare f1 f2 = 0 -> true
- | Typ_id v1, Typ_app (f2, _) when Id.compare v1 f2 = 0 -> true
- | Typ_app (f1, _), Typ_id v2 when Id.compare f1 v2 = 0 -> true
- | _, _ -> false
-
-let rec filter_casts env from_typ to_typ casts =
- match casts with
- | (cast :: casts) ->
- begin
- let (quant, cast_typ) = Env.get_val_spec cast env in
- match cast_typ with
- | Typ_aux (Typ_fn (cast_from_typ, cast_to_typ, _), _)
- when match_typ from_typ cast_from_typ && match_typ to_typ cast_to_typ ->
- typ_print ("Considering cast " ^ string_of_typ cast_typ ^ " for " ^ string_of_typ from_typ ^ " to " ^ string_of_typ to_typ);
- cast :: filter_casts env from_typ to_typ casts
- | _ -> filter_casts env from_typ to_typ casts
- end
- | [] -> []
-
-let is_union_id id env =
- match Env.lookup_id id env with
- | Union (_, _) -> true
- | _ -> false
-
-let crule r env exp typ =
- incr depth;
- typ_print ("Check " ^ string_of_exp exp ^ " <= " ^ string_of_typ typ);
- try
- let checked_exp = r env exp typ in
- decr depth; checked_exp
- with
- | Type_error (l, m) -> decr depth; typ_error l m
-
-let irule r env exp =
- incr depth;
- try
- let inferred_exp = r env exp in
- typ_print ("Infer " ^ string_of_exp exp ^ " => " ^ string_of_typ (typ_of inferred_exp));
- decr depth;
- inferred_exp
- with
- | Type_error (l, m) -> decr depth; typ_error l m
-
-let strip_exp : 'a exp -> unit exp = function exp -> map_exp_annot (fun (l, _) -> (l, ())) exp
-let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) -> (l, ())) pat
-
-let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp =
- let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
- let annot_exp exp typ = annot_exp_effect exp typ no_effect in
- match (exp_aux, typ_aux) with
- | E_block exps, _ ->
- begin
- let rec check_block l env exps typ = match exps with
- | [] -> typ_error l "Empty block found"
- | [exp] -> [crule check_exp env exp typ]
- | (E_aux (E_assign (lexp, bind), _) :: exps) ->
- let texp, env = bind_assignment env lexp bind in
- texp :: check_block l env exps typ
- | ((E_aux (E_assert (E_aux (E_constraint nc, _), assert_msg), _) as exp) :: exps) ->
- typ_print ("Adding constraint " ^ string_of_n_constraint nc ^ " for assert");
- let inferred_exp = irule infer_exp env exp in
- inferred_exp :: check_block l (Env.add_constraint nc env) exps typ
- | (exp :: exps) ->
- let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
- texp :: check_block l env exps typ
- in
- annot_exp (E_block (check_block l env exps typ)) typ
- end
- | E_case (exp, cases), _ ->
- let inferred_exp = irule infer_exp env exp in
- let check_case pat typ = match pat with
- | Pat_aux (Pat_exp (pat, case), (l, _)) ->
- let tpat, env = bind_pat env pat (typ_of inferred_exp) in
- Pat_aux (Pat_exp (tpat, crule check_exp env case typ), (l, None))
- | Pat_aux (Pat_when (pat, guard, case), (l, _)) ->
- let tpat, env = bind_pat env pat (typ_of inferred_exp) in
- let checked_guard = check_exp env guard bool_typ in
- Pat_aux (Pat_when (tpat, checked_guard, crule check_exp env case typ), (l, None))
- in
- annot_exp (E_case (inferred_exp, List.map (fun case -> check_case case typ) cases)) typ
- | E_let (LB_aux (letbind, (let_loc, _)), exp), _ ->
- begin
- match letbind with
- | LB_val_explicit (typschm, pat, bind) -> assert false
- | LB_val_implicit (P_aux (P_typ (ptyp, _), _) as pat, bind) ->
- let checked_bind = crule check_exp env bind ptyp in
- let tpat, env = bind_pat env pat (typ_of checked_bind) in
- annot_exp (E_let (LB_aux (LB_val_implicit (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ
- | LB_val_implicit (pat, bind) ->
- let inferred_bind = irule infer_exp env bind in
- let tpat, env = bind_pat env pat (typ_of inferred_bind) in
- annot_exp (E_let (LB_aux (LB_val_implicit (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ
- end
- | E_app_infix (x, op, y), _ when List.length (Env.get_overloads (deinfix op) env) > 0 ->
- check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ
- | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_prove") = 0 ->
- if prove env nc
- then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
- else typ_error l ("Cannot prove " ^ string_of_n_constraint nc)
- | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 ->
- let rec try_overload = function
- | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp)
- | (f :: fs) -> begin
- typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")");
- try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with
- | Type_error (_, m) -> typ_print ("Error : " ^ m); try_overload fs
- end
- in
- try_overload (Env.get_overloads f env)
- | E_app (f, xs), _ ->
- let inferred_exp = infer_funapp l env f xs (Some typ) in
- type_coercion env inferred_exp typ
- | E_if (cond, then_branch, else_branch), _ ->
- let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
- let flows, constrs = infer_flow env cond' in
- let then_branch' = crule check_exp (add_constraints constrs (add_flows true flows env)) then_branch typ in
- let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch typ in
- annot_exp (E_if (cond', then_branch', else_branch')) typ
- | E_exit exp, _ ->
- let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
- annot_exp_effect (E_exit checked_exp) typ (mk_effect [BE_escape])
- | E_vector vec, _ ->
- begin
- let (start, len, ord, vtyp) = destructure_vec_typ l env typ in
- let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in
- match len with
- | Nexp_aux (Nexp_constant lenc, _) ->
- if List.length vec = lenc then annot_exp (E_vector checked_items) typ
- else typ_error l "List length didn't match" (* FIXME: improve error message *)
- | _ -> typ_error l "Cannot check list constant against non-constant length vector type"
- end
- | E_lit (L_aux (L_undef, _) as lit), _ ->
- annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef])
- (* This rule allows registers of type t to be passed by name with type register<t>*)
- | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "register" ->
- let rtyp = Env.get_register reg env in
- subtyp l env rtyp typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *)
- | E_id id, _ when is_union_id id env ->
- begin
- match Env.lookup_id id env with
- | Union (typq, ctor_typ) ->
- let inferred_exp = infer_funapp' l env id (typq, mk_typ (Typ_fn (unit_typ, ctor_typ, no_effect))) [mk_lit L_unit] (Some typ) in
- annot_exp (E_id id) (typ_of inferred_exp)
- | _ -> assert false (* Unreachble due to guard *)
- end
- | _, _ ->
- let inferred_exp = irule infer_exp env exp in
- type_coercion env inferred_exp typ
-
-(* type_coercion env exp typ takes a fully annoted (i.e. already type
- checked) expression exp, and attempts to cast (coerce) it to the
- type typ by inserting a coercion function that transforms the
- annotated expression into the correct type. Returns an annoted
- expression consisting of a type coercion function applied to exp,
- or throws a type error if the coercion cannot be performed. *)
-and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
- let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
- let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in
- let rec try_casts m = function
- | [] -> typ_error l ("No valid casts:\n" ^ m)
- | (cast :: casts) -> begin
- typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ);
- try
- let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in
- annot_exp (E_cast (typ, checked_cast)) typ
- with
- | Type_error (_, m) -> try_casts m casts
- end
- in
- begin
- try
- typ_debug "PERFORMING TYPE COERCION";
- subtyp l env (typ_of annotated_exp) typ; annotated_exp
- with
- | Type_error (_, m) when Env.allow_casts env ->
- let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
- try_casts "" casts
- | Type_error (l, m) -> typ_error l ("Subtype error " ^ m)
- end
-
-(* type_coercion_unify env exp typ attempts to coerce exp to a type
- exp_typ in the same way as type_coercion, except it is only
- required that exp_typ unifies with typ. Returns the annotated
- coercion as with type_coercion and also a set of unifiers, or
- throws a unification error *)
-and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ =
- let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
- let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in
- let rec try_casts m = function
- | [] -> unify_error l ("No valid casts resulted in unification:\n" ^ m)
- | (cast :: casts) -> begin
- typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification");
- try
- let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
- let ityp = typ_of inferred_cast in
- annot_exp (E_cast (ityp, inferred_cast)) ityp, unify l env typ ityp
- with
- | Type_error (_, m) -> try_casts m casts
- | Unification_error (_, m) -> try_casts m casts
- end
- in
- begin
- try
- typ_debug "PERFORMING COERCING UNIFICATION";
- annotated_exp, unify l env typ (typ_of annotated_exp)
- with
- | Unification_error (_, m) when Env.allow_casts env ->
- let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
- try_casts "" casts
- end
-
-and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
- typ_print ("Binding " ^ string_of_typ typ);
- let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in
- let switch_typ (P_aux (pat_aux, (l, Some (env, _, eff)))) typ = P_aux (pat_aux, (l, Some (env, typ, eff))) in
- let bind_tuple_pat (tpats, env) pat typ =
- let tpat, env = bind_pat env pat typ in tpat :: tpats, env
- in
- match pat_aux with
- | P_id v ->
- begin
- match Env.lookup_id v env with
- | Local (Immutable, _) | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env
- | Local (Mutable, _) | Register _ ->
- typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
- | Enum enum -> subtyp l env enum typ; annot_pat (P_id v) typ, env
- | Union (typq, ctor_typ) ->
- begin
- try
- let _ = unify l env ctor_typ typ in
- annot_pat (P_id v) typ, env
- with
- | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m)
- end
- end
- | P_wild -> annot_pat P_wild typ, env
- | P_tup pats ->
- begin
- match typ_aux with
- | Typ_tup typs ->
- let tpats, env =
- try List.fold_left2 bind_tuple_pat ([], env) pats typs with
- | Invalid_argument _ -> typ_error l "Tuple pattern and tuple type have different length"
- in
- annot_pat (P_tup (List.rev tpats)) typ, env
- | _ -> typ_error l "Cannot bind tuple pattern against non tuple type"
- end
- | P_app (f, pats) when Env.is_union_constructor f env ->
- begin
- let (typq, ctor_typ) = Env.get_val_spec f env in
- let quants = quant_items typq in
- let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with
- | Typ_tup typs -> typs
- | _ -> [typ]
- in
- match Env.expand_synonyms env ctor_typ with
- | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) ->
- begin
- try
- typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for pattern " ^ string_of_typ typ);
- let unifiers = unify l env ret_typ typ in
- typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
- let arg_typ' = subst_unifiers unifiers arg_typ in
- let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
- if (match quants' with [] -> false | _ -> true)
- then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
- else ();
- let ret_typ' = subst_unifiers unifiers ret_typ in
- let tpats, env =
- try List.fold_left2 bind_tuple_pat ([], env) pats (untuple arg_typ') with
- | Invalid_argument _ -> typ_error l "Union constructor pattern arguments have incorrect length"
- in
- annot_pat (P_app (f, List.rev tpats)) typ, env
- with
- | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m)
- end
- | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f)
- end
- | P_app (f, _) when not (Env.is_union_constructor f env) ->
- typ_error l (string_of_id f ^ " is not a union constructor in pattern " ^ string_of_pat pat)
- | _ ->
- let (inferred_pat, env) = infer_pat env pat in
- subtyp l env (pat_typ_of inferred_pat) typ;
- switch_typ inferred_pat typ, env
-
-and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
- let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in
- match pat_aux with
- | P_id v ->
- begin
- match Env.lookup_id v env with
- | Local (Immutable, _) | Unbound ->
- typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation")
- | Local (Mutable, _) | Register _ ->
- typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
- | Enum enum -> annot_pat (P_id v) enum, env
- end
- | P_typ (typ_annot, pat) ->
- let (typed_pat, env) = bind_pat env pat typ_annot in
- annot_pat (P_typ (typ_annot, typed_pat)) typ_annot, env
- | P_lit lit ->
- annot_pat (P_lit lit) (infer_lit env lit), env
- | P_vector_concat (pat :: pats) ->
- let fold_pats (pats, env) pat =
- let inferred_pat, env = infer_pat env pat in
- pats @ [inferred_pat], env
- in
- let (inferred_pat :: inferred_pats), env = List.fold_left fold_pats ([], env) (pat :: pats) in
- let (_, len, _, vtyp) = destructure_vec_typ l env (pat_typ_of inferred_pat) in
- let fold_len len pat =
- let (_, len', _, vtyp') = destructure_vec_typ l env (pat_typ_of pat) in
- typ_equality l env vtyp vtyp';
- nsum len len'
- in
- let len = nexp_simp (List.fold_left fold_len len inferred_pats) in
- annot_pat (P_vector_concat (inferred_pat :: inferred_pats)) (lvector_typ env len vtyp), env
- | _ -> typ_error l ("Couldn't infer type of pattern " ^ string_of_pat pat)
-
-and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) =
- let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, Some (env, mk_typ (Typ_id (mk_id "unit")), no_effect))) in
- let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in
- let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
- let has_typ v env =
- match Env.lookup_id v env with
- | Local (Mutable, _) | Register _ -> true
- | _ -> false
- in
- match lexp_aux with
- | LEXP_field (LEXP_aux (flexp, _), field) ->
- begin
- let infer_flexp = function
- | LEXP_id v ->
- begin match Env.lookup_id v env with
- | Register typ -> typ, LEXP_id v
- | _ -> typ_error l "l-expression field is not a register"
- end
- | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) ->
- begin
- (* Check: is this ok if the vector is immutable? *)
- let is_immutable, vtyp = match Env.lookup_id v env with
- | Unbound -> typ_error l "Cannot assign to element of unbound vector"
- | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
- | Local (Immutable, vtyp) -> true, vtyp
- | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
- in
- let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in
- let E_aux (E_app (_, [_; inferred_exp]), _) = access in
- typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp)
- end
- in
- let regtyp, inferred_flexp = infer_flexp flexp in
- match Env.expand_synonyms env regtyp with
- | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env ->
- let base, top, ranges = Env.get_regtyp regtyp_id env in
- let range, _ =
- try List.find (fun (_, id) -> Id.compare id field = 0) ranges with
- | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp_id)
- in
- let vec_typ = match range, Env.get_default_order env with
- | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) ->
- dvector_typ env (nconstant n) (nconstant 1) (mk_typ (Typ_id (mk_id "bit")))
- | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) ->
- dvector_typ env (nconstant n) (nconstant (n - m + 1)) (mk_typ (Typ_id (mk_id "bit")))
- | _, _ -> typ_error l "Not implemented this register field type yet..."
- in
- let checked_exp = crule check_exp env exp vec_typ in
- annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp (mk_effect [BE_wreg]), field)) vec_typ) checked_exp, env
- | _ -> typ_error l "Field l-expression has invalid type"
- end
- | LEXP_memory (f, xs) ->
- check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env
- | LEXP_cast (typ_annot, v) ->
- let checked_exp = crule check_exp env exp typ_annot in
- let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in
- annot_assign tlexp checked_exp, env'
- | LEXP_id v when has_typ v env ->
- begin match Env.lookup_id v env with
- | Local (Mutable, vtyp) | Register vtyp ->
- let checked_exp = crule check_exp env exp vtyp in
- let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in
- annot_assign tlexp checked_exp, env'
- | _ -> assert false
- end
- | _ ->
- let inferred_exp = irule infer_exp env exp in
- let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in
- annot_assign tlexp inferred_exp, env'
-
-and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
- let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in
- let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
- match lexp_aux with
- | LEXP_id v ->
- begin match Env.lookup_id v env with
- | Local (Immutable, _) | Enum _ ->
- typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
- | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env
- | Register vtyp -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ (mk_effect [BE_wreg]), env
- | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env
- end
- | LEXP_cast (typ_annot, v) ->
- begin
- match Env.lookup_id v env with
- | Local (Immutable, _) | Enum _ ->
- typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
- | Local (Mutable, vtyp) ->
- begin
- subtyp l env typ typ_annot;
- subtyp l env typ_annot vtyp;
- annot_lexp (LEXP_cast (typ_annot, v)) typ, env
- end
- | Register vtyp ->
- begin
- subtyp l env typ typ_annot;
- subtyp l env typ_annot vtyp;
- annot_lexp_effect (LEXP_cast (typ_annot, v)) typ (mk_effect [BE_wreg]), env
- end
- | Unbound ->
- begin
- subtyp l env typ typ_annot;
- annot_lexp (LEXP_cast (typ_annot, v)) typ, Env.add_local v (Mutable, typ_annot) env
- end
- end
- | LEXP_tup lexps ->
- begin
- let (Typ_aux (typ_aux, _)) = typ in
- match typ_aux with
- | Typ_tup typs ->
- let bind_tuple_lexp (tlexps, env) lexp typ =
- let tlexp, env = bind_lexp env lexp typ in tlexp :: tlexps, env
- in
- let tlexps, env =
- try List.fold_left2 bind_tuple_lexp ([], env) lexps typs with
- | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length"
- in
- annot_lexp (LEXP_tup tlexps) typ, env
- | _ -> typ_error l "Cannot bind tuple l-expression against non tuple type"
- end
- | LEXP_vector_range (LEXP_aux (LEXP_id v, _), exp1, exp2) ->
- begin
- let is_immutable, vtyp = match Env.lookup_id v env with
- | Unbound -> typ_error l "Cannot assign to element of unbound vector"
- | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
- | Local (Immutable, vtyp) -> true, vtyp
- | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
- in
- let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_subrange", [E_aux (E_id v, (l, ())); exp1; exp2]), (l, ()))) in
- let E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) = access in
- match typ_of access with
- | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" ->
- subtyp l env typ deref_typ;
- annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env
- | _ when not is_immutable ->
- subtyp l env typ (typ_of access);
- annot_lexp (LEXP_vector_range (annot_lexp (LEXP_id v) vtyp, inferred_exp1, inferred_exp2)) typ, env
- | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp)
- end
- (* Not sure about this case... can the left lexp be anything other than an identifier? *)
- | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) ->
- begin
- let is_immutable, vtyp = match Env.lookup_id v env with
- | Unbound -> typ_error l "Cannot assign to element of unbound vector"
- | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
- | Local (Immutable, vtyp) -> true, vtyp
- | Local (Mutable, vtyp) | Register vtyp -> false, vtyp
- in
- let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in
- let E_aux (E_app (_, [_; inferred_exp]), _) = access in
- match typ_of access with
- | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" ->
- subtyp l env typ deref_typ;
- annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env
- | _ when not is_immutable ->
- subtyp l env typ (typ_of access);
- annot_lexp (LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp)) typ, env
- | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp)
- end
- | _ -> typ_error l ("Unhandled l-expression")
-
-and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
- let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
- let annot_exp exp typ = annot_exp_effect exp typ no_effect in
- match exp_aux with
- | E_nondet exps ->
- annot_exp (E_nondet (List.map (fun exp -> crule check_exp env exp unit_typ) exps)) unit_typ
- | E_id v ->
- begin
- match Env.lookup_id v env with
- | Local (_, typ) | Enum typ -> annot_exp (E_id v) typ
- | Register typ -> annot_exp_effect (E_id v) typ (mk_effect [BE_rreg])
- | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound")
- | Union (typq, typ) ->
- if quant_items typq = []
- then annot_exp (E_id v) typ
- else typ_error l ("Cannot infer the type of polymorphic union indentifier " ^ string_of_id v)
- end
- | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
- | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)])))
- | E_constraint nc ->
- annot_exp (E_constraint nc) bool_typ
- | E_return exp ->
- begin
- match Env.get_ret_typ env with
- | Some typ -> annot_exp (E_return (crule check_exp env exp typ)) (mk_typ (Typ_id (mk_id "unit")))
- | None -> typ_error l "Return found in non-function environment"
- end
- | E_field (exp, field) ->
- begin
- let inferred_exp = irule infer_exp env exp in
- match Env.expand_synonyms env (typ_of inferred_exp) with
- (* Accessing a (bit) field of a register *)
- | Typ_aux (Typ_id regtyp, _) when Env.is_regtyp regtyp env ->
- let base, top, ranges = Env.get_regtyp regtyp env in
- let range, _ =
- try List.find (fun (_, id) -> Id.compare id field = 0) ranges with
- | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp)
- in
- begin
- match range, Env.get_default_order env with
- | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) ->
- let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in
- annot_exp (E_field (inferred_exp, field)) vec_typ
- | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) ->
- let vec_typ = dvector_typ env (nconstant n) (nconstant (n - m + 1)) bit_typ in
- annot_exp (E_field (inferred_exp, field)) vec_typ
- | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) ->
- let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in
- annot_exp (E_field (inferred_exp, field)) vec_typ
- | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) ->
- let vec_typ = dvector_typ env (nconstant n) (nconstant (m - n + 1)) bit_typ in
- annot_exp (E_field (inferred_exp, field)) vec_typ
- | _, _ -> typ_error l "Invalid register field type"
- end
- (* Accessing a field of a record *)
- | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env ->
- begin
- let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor field env) [strip_exp inferred_exp] None in
- match inferred_acc with
- | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc)
- | _ -> assert false (* Unreachable *)
- end
- | _ -> typ_error l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid")
- end
- | E_tuple exps ->
- let inferred_exps = List.map (irule infer_exp env) exps in
- annot_exp (E_tuple inferred_exps) (mk_typ (Typ_tup (List.map typ_of inferred_exps)))
- | E_assign (lexp, bind) ->
- fst (bind_assignment env lexp bind)
- | E_cast (typ, exp) ->
- let checked_exp = crule check_exp env exp typ in
- annot_exp (E_cast (typ, checked_exp)) typ
- | E_app_infix (x, op, y) when List.length (Env.get_overloads (deinfix op) env) > 0 -> infer_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ())))
- | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 ->
- let rec try_overload = function
- | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp)
- | (f :: fs) -> begin
- typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")");
- try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with
- | Type_error (_, m) -> typ_print ("Error: " ^ m); try_overload fs
- end
- in
- try_overload (Env.get_overloads f env)
- | E_app (f, xs) -> infer_funapp l env f xs None
- | E_for (v, f, t, step, ord, body) ->
- begin
- let f, t = match ord with
- | Ord_aux (Ord_inc, _) -> f, t
- | Ord_aux (Ord_dec, _) -> t, f (* reverse direction for downto loop *)
- in
- let inferred_f = irule infer_exp env f in
- let inferred_t = irule infer_exp env t in
- let checked_step = crule check_exp env step int_typ in
- match is_range (typ_of inferred_f), is_range (typ_of inferred_t) with
- | None, _ -> typ_error l ("Type of " ^ string_of_exp f ^ " in foreach must be a range")
- | _, None -> typ_error l ("Type of " ^ string_of_exp t ^ " in foreach must be a range")
- | Some (l1, l2), Some (u1, u2) when prove env (nc_lteq l2 u1) ->
- let checked_body = crule check_exp (Env.add_local v (Immutable, range_typ l1 u2) env) body unit_typ in
- annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ
- | _, _ -> typ_error l "Ranges in foreach overlap"
- end
- | E_if (cond, then_branch, else_branch) ->
- let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
- let flows, constrs = infer_flow env cond' in
- let then_branch' = irule infer_exp (add_constraints constrs (add_flows true flows env)) then_branch in
- let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch (typ_of then_branch') in
- annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch')
- | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ())))
- | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "vector_append", [v1; v2]), (l, ())))
- | E_vector_subrange (v, n, m) -> infer_exp env (E_aux (E_app (mk_id "vector_subrange", [v; n; m]), (l, ())))
- | E_vector [] -> typ_error l "Cannot infer type of empty vector"
- | E_vector ((item :: items) as vec) ->
- let inferred_item = irule infer_exp env item in
- let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in
- let vec_typ = match Env.get_default_order env with
- | Ord_aux (Ord_inc, _) ->
- mk_typ (Typ_app (mk_id "vector",
- [mk_typ_arg (Typ_arg_nexp (nconstant 0));
- mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec)));
- mk_typ_arg (Typ_arg_order (Env.get_default_order env));
- mk_typ_arg (Typ_arg_typ (typ_of inferred_item))]))
- | Ord_aux (Ord_dec, _) ->
- mk_typ (Typ_app (mk_id "vector",
- [mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec - 1)));
- mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec)));
- mk_typ_arg (Typ_arg_order (Env.get_default_order env));
- mk_typ_arg (Typ_arg_typ (typ_of inferred_item))]))
- in
- annot_exp (E_vector (inferred_item :: checked_items)) vec_typ
- | E_assert (test, msg) ->
- let checked_test = crule check_exp env test bool_typ in
- let checked_msg = crule check_exp env msg string_typ in
- annot_exp (E_assert (checked_test, checked_msg)) unit_typ
- | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp)
-
-and infer_funapp l env f xs ret_ctx_typ = infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ
-
-and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ =
- let annot_exp exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in
- let rec number n = function
- | [] -> []
- | (x :: xs) -> (n, x) :: number (n + 1) xs
- in
- let solve_quant = function
- | QI_aux (QI_id _, _) -> false
- | QI_aux (QI_const nc, _) -> prove env nc
- in
- let rec instantiate quants typs ret_typ args =
- match typs, args with
- | (utyps, []), (uargs, []) ->
- begin
- typ_debug ("Got unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs);
- if List.for_all solve_quant quants
- then
- let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in
- (iuargs, ret_typ)
- else typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants
- ^ " not resolved during application of " ^ string_of_id f)
- end
- | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) when KidSet.is_empty (typ_frees typ) ->
- begin
- let carg = crule check_exp env arg typ in
- let (iargs, ret_typ') = instantiate quants (utyps, typs) ret_typ (uargs, args) in
- ((n, carg) :: iargs, ret_typ')
- end
- | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) ->
- begin
- typ_debug ("INSTANTIATE: " ^ string_of_exp arg ^ " with " ^ string_of_typ typ ^ " NF " ^ string_of_tnf (normalize_typ env typ));
- let iarg = irule infer_exp env arg in
- typ_debug ("INFER: " ^ string_of_exp arg ^ " type " ^ string_of_typ (typ_of iarg) ^ " NF " ^ string_of_tnf (normalize_typ env (typ_of iarg)));
- try
- let iarg, unifiers = type_coercion_unify env iarg typ in
- typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
- let utyps' = List.map (subst_unifiers unifiers) utyps in
- let typs' = List.map (subst_unifiers unifiers) typs in
- let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
- let ret_typ' = subst_unifiers unifiers ret_typ in
- let (iargs, ret_typ'') = instantiate quants' (utyps', typs') ret_typ' (uargs, args) in
- ((n, iarg) :: iargs, ret_typ'')
- with
- | Unification_error (l, str) ->
- typ_debug ("Unification error: " ^ str);
- instantiate quants (typ :: utyps, typs) ret_typ ((n, arg) :: uargs, args)
- end
- | (_, []), _ -> typ_error l ("Function " ^ string_of_id f ^ " applied to too many arguments")
- | _, (_, []) -> typ_error l ("Function " ^ string_of_id f ^ " not applied to enough arguments")
- in
- let instantiate_ret quants typs ret_typ =
- match ret_ctx_typ with
- | None -> (quants, typs, ret_typ)
- | Some rct ->
- begin
- typ_debug ("RCT is " ^ string_of_typ rct);
- typ_debug ("INSTANTIATE RETURN:" ^ string_of_typ ret_typ);
- let unifiers = try unify l env ret_typ rct with Unification_error _ -> typ_debug "UERROR"; KBindings.empty in
- typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers));
- let typs' = List.map (subst_unifiers unifiers) typs in
- let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in
- let ret_typ' = subst_unifiers unifiers ret_typ in
- (quants', typs', ret_typ')
- end
- in
- let exp =
- match Env.expand_synonyms env f_typ with
- | Typ_aux (Typ_fn (Typ_aux (Typ_tup typ_args, _), typ_ret, eff), _) ->
- let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) typ_args typ_ret in
- let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in
- let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in
- annot_exp (E_app (f, xs_reordered)) typ_ret eff
- | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) ->
- let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) [typ_arg] typ_ret in
- let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in
- let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in
- annot_exp (E_app (f, xs_reordered)) typ_ret eff
- | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type")
- in
- match ret_ctx_typ with
- | None -> exp
- | Some rct -> type_coercion env exp rct
-
-(**************************************************************************)
-(* 6. Effect system *)
-(**************************************************************************)
-
-let effect_of_annot = function
-| Some (_, _, eff) -> eff
-| None -> no_effect
-
-let effect_of (E_aux (exp, (l, annot))) = effect_of_annot annot
-
-let add_effect (E_aux (exp, (l, annot))) eff1 =
- match annot with
- | Some (env, typ, eff2) -> E_aux (exp, (l, Some (env, typ, union_effects eff1 eff2)))
- | None -> assert false
-
-let effect_of_lexp (LEXP_aux (exp, (l, annot))) = effect_of_annot annot
-
-let add_effect_lexp (LEXP_aux (lexp, (l, annot))) eff1 =
- match annot with
- | Some (env, typ, eff2) -> LEXP_aux (lexp, (l, Some (env, typ, union_effects eff1 eff2)))
- | None -> assert false
-
-let effect_of_pat (P_aux (exp, (l, annot))) = effect_of_annot annot
-
-let add_effect_pat (P_aux (pat, (l, annot))) eff1 =
- match annot with
- | Some (env, typ, eff2) -> P_aux (pat, (l, Some (env, typ, union_effects eff1 eff2)))
- | None -> assert false
-
-let collect_effects xs = List.fold_left union_effects no_effect (List.map effect_of xs)
-
-let collect_effects_lexp xs = List.fold_left union_effects no_effect (List.map effect_of_lexp xs)
-
-let collect_effects_pat xs = List.fold_left union_effects no_effect (List.map effect_of_pat xs)
-
-(* Traversal that propagates effects upwards through expressions *)
-
-let rec propagate_exp_effect (E_aux (exp, annot)) =
- let propagated_exp, eff = propagate_exp_effect_aux exp in
- add_effect (E_aux (propagated_exp, annot)) eff
-and propagate_exp_effect_aux = function
- | E_block xs ->
- let propagated_xs = List.map propagate_exp_effect xs in
- E_block propagated_xs, collect_effects propagated_xs
- | E_nondet xs ->
- let propagated_xs = List.map propagate_exp_effect xs in
- E_nondet propagated_xs, collect_effects propagated_xs
- | E_id id -> E_id id, no_effect
- | E_lit lit -> E_lit lit, no_effect
- | E_cast (typ, exp) ->
- let propagated_exp = propagate_exp_effect exp in
- E_cast (typ, propagated_exp), effect_of propagated_exp
- | E_app (id, xs) ->
- let propagated_xs = List.map propagate_exp_effect xs in
- E_app (id, propagated_xs), collect_effects propagated_xs
- | E_vector xs ->
- let propagated_xs = List.map propagate_exp_effect xs in
- E_vector propagated_xs, collect_effects propagated_xs
- | E_tuple xs ->
- let propagated_xs = List.map propagate_exp_effect xs in
- E_tuple propagated_xs, collect_effects propagated_xs
- | E_if (cond, t, e) ->
- let propagated_cond = propagate_exp_effect cond in
- let propagated_t = propagate_exp_effect t in
- let propagated_e = propagate_exp_effect e in
- E_if (propagated_cond, propagated_t, propagated_e), collect_effects [propagated_cond; propagated_t; propagated_e]
- | E_case (exp, cases) ->
- let propagated_exp = propagate_exp_effect exp in
- let propagated_cases = List.map propagate_pexp_effect cases in
- let case_eff = List.fold_left union_effects no_effect (List.map snd propagated_cases) in
- E_case (propagated_exp, List.map fst propagated_cases), union_effects (effect_of propagated_exp) case_eff
- | E_for (v, f, t, step, ord, body) ->
- let propagated_f = propagate_exp_effect f in
- let propagated_t = propagate_exp_effect t in
- let propagated_step = propagate_exp_effect step in
- let propagated_body = propagate_exp_effect body in
- E_for (v, propagated_f, propagated_t, propagated_step, ord, propagated_body),
- collect_effects [propagated_f; propagated_t; propagated_step; propagated_body]
- | E_let (letbind, exp) ->
- let propagated_lb, eff = propagate_letbind_effect letbind in
- let propagated_exp = propagate_exp_effect exp in
- E_let (propagated_lb, propagated_exp), union_effects (effect_of propagated_exp) eff
- | E_assign (lexp, exp) ->
- let propagated_lexp = propagate_lexp_effect lexp in
- let propagated_exp = propagate_exp_effect exp in
- E_assign (propagated_lexp, propagated_exp), union_effects (effect_of propagated_exp) (effect_of_lexp propagated_lexp)
- | E_sizeof nexp -> E_sizeof nexp, no_effect
- | E_constraint nc -> E_constraint nc, no_effect
- | E_exit exp ->
- let propagated_exp = propagate_exp_effect exp in
- E_exit propagated_exp, effect_of propagated_exp
- | E_return exp ->
- let propagated_exp = propagate_exp_effect exp in
- E_return propagated_exp, effect_of propagated_exp
- | E_assert (test, msg) ->
- let propagated_test = propagate_exp_effect test in
- let propagated_msg = propagate_exp_effect msg in
- E_assert (propagated_test, propagated_msg), collect_effects [propagated_test; propagated_msg]
- | E_field (exp, id) ->
- let propagated_exp = propagate_exp_effect exp in
- E_field (propagated_exp, id), effect_of propagated_exp
- | exp_aux -> typ_error Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression "
- ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))))
-
-and propagate_pexp_effect = function
- | Pat_aux (Pat_exp (pat, exp), (l, annot)) ->
- begin
- let propagated_pat = propagate_pat_effect pat in
- let propagated_exp = propagate_exp_effect exp in
- let propagated_eff = union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp) in
- match annot with
- | Some (typq, typ, eff) ->
- Pat_aux (Pat_exp (propagated_pat, propagated_exp), (l, Some (typq, typ, union_effects eff propagated_eff))),
- union_effects eff propagated_eff
- | None -> Pat_aux (Pat_exp (propagated_pat, propagated_exp), (l, None)), propagated_eff
- end
- | Pat_aux (Pat_when (pat, guard, exp), (l, annot)) ->
- begin
- let propagated_pat = propagate_pat_effect pat in
- let propagated_guard = propagate_exp_effect guard in
- let propagated_exp = propagate_exp_effect exp in
- let propagated_eff = union_effects (effect_of_pat propagated_pat)
- (union_effects (effect_of propagated_guard) (effect_of propagated_exp))
- in
- match annot with
- | Some (typq, typ, eff) ->
- Pat_aux (Pat_when (propagated_pat, propagated_guard, propagated_exp), (l, Some (typq, typ, union_effects eff propagated_eff))),
- union_effects eff propagated_eff
- | None -> Pat_aux (Pat_when (propagated_pat, propagated_guard, propagated_exp), (l, None)), propagated_eff
- end
-
-and propagate_pat_effect (P_aux (pat, annot)) =
- let propagated_pat, eff = propagate_pat_effect_aux pat in
- add_effect_pat (P_aux (propagated_pat, annot)) eff
-and propagate_pat_effect_aux = function
- | P_lit lit -> P_lit lit, no_effect
- | P_wild -> P_wild, no_effect
- | P_as (pat, id) ->
- let propagated_pat = propagate_pat_effect pat in
- P_as (propagated_pat, id), effect_of_pat propagated_pat
- | P_typ (typ, pat) ->
- let propagated_pat = propagate_pat_effect pat in
- P_typ (typ, propagated_pat), effect_of_pat propagated_pat
- | P_id id -> P_id id, no_effect
- | P_app (id, pats) ->
- let propagated_pats = List.map propagate_pat_effect pats in
- P_app (id, propagated_pats), collect_effects_pat propagated_pats
- | P_tup pats ->
- let propagated_pats = List.map propagate_pat_effect pats in
- P_tup propagated_pats, collect_effects_pat propagated_pats
- | P_list pats ->
- let propagated_pats = List.map propagate_pat_effect pats in
- P_list propagated_pats, collect_effects_pat propagated_pats
- | P_vector_concat pats ->
- let propagated_pats = List.map propagate_pat_effect pats in
- P_vector_concat propagated_pats, collect_effects_pat propagated_pats
- | P_vector pats ->
- let propagated_pats = List.map propagate_pat_effect pats in
- P_vector propagated_pats, collect_effects_pat propagated_pats
- | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat"
-
-and propagate_letbind_effect (LB_aux (lb, (l, annot))) =
- let propagated_lb, eff = propagate_letbind_effect_aux lb in
- match annot with
- | Some (typq, typ, eff) -> LB_aux (propagated_lb, (l, Some (typq, typ, eff))), eff
- | None -> LB_aux (propagated_lb, (l, None)), eff
-and propagate_letbind_effect_aux = function
- | LB_val_explicit (typschm, pat, exp) ->
- let propagated_pat = propagate_pat_effect pat in
- let propagated_exp = propagate_exp_effect exp in
- LB_val_explicit (typschm, propagated_pat, propagated_exp),
- union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp)
- | LB_val_implicit (pat, exp) ->
- let propagated_pat = propagate_pat_effect pat in
- let propagated_exp = propagate_exp_effect exp in
- LB_val_implicit (propagated_pat, propagated_exp),
- union_effects (effect_of_pat propagated_pat) (effect_of propagated_exp)
-
-and propagate_lexp_effect (LEXP_aux (lexp, annot)) =
- let propagated_lexp, eff = propagate_lexp_effect_aux lexp in
- add_effect_lexp (LEXP_aux (propagated_lexp, annot)) eff
-and propagate_lexp_effect_aux = function
- | LEXP_id id -> LEXP_id id, no_effect
- | LEXP_memory (id, exps) ->
- let propagated_exps = List.map propagate_exp_effect exps in
- LEXP_memory (id, propagated_exps), collect_effects propagated_exps
- | LEXP_cast (typ, id) -> LEXP_cast (typ, id), no_effect
- | LEXP_tup lexps ->
- let propagated_lexps = List.map propagate_lexp_effect lexps in
- LEXP_tup propagated_lexps, collect_effects_lexp propagated_lexps
- | LEXP_vector (lexp, exp) ->
- let propagated_lexp = propagate_lexp_effect lexp in
- let propagated_exp = propagate_exp_effect exp in
- LEXP_vector (propagated_lexp, propagated_exp), union_effects (effect_of propagated_exp) (effect_of_lexp propagated_lexp)
- | LEXP_vector_range (lexp, exp1, exp2) ->
- let propagated_lexp = propagate_lexp_effect lexp in
- let propagated_exp1 = propagate_exp_effect exp1 in
- let propagated_exp2 = propagate_exp_effect exp2 in
- LEXP_vector_range (propagated_lexp, propagated_exp1, propagated_exp2),
- union_effects (collect_effects [propagated_exp1; propagated_exp2]) (effect_of_lexp propagated_lexp)
- | LEXP_field (lexp, id) ->
- let propagated_lexp = propagate_lexp_effect lexp in
- LEXP_field (propagated_lexp, id),effect_of_lexp propagated_lexp
- | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in lexp"
-
-(**************************************************************************)
-(* 6. Checking toplevel definitions *)
-(**************************************************************************)
-
-let check_letdef env (LB_aux (letbind, (l, _))) =
- begin
- match letbind with
- | LB_val_explicit (typschm, pat, bind) -> assert false
- | LB_val_implicit (P_aux (P_typ (typ_annot, pat), _), bind) ->
- let checked_bind = crule check_exp env (strip_exp bind) typ_annot in
- let tpat, env = bind_pat env (strip_pat pat) typ_annot in
- [DEF_val (LB_aux (LB_val_implicit (P_aux (P_typ (typ_annot, tpat), (l, Some (env, typ_annot, no_effect))), checked_bind), (l, None)))], env
- | LB_val_implicit (pat, bind) ->
- let inferred_bind = irule infer_exp env (strip_exp bind) in
- let tpat, env = bind_pat env (strip_pat pat) (typ_of inferred_bind) in
- [DEF_val (LB_aux (LB_val_implicit (tpat, inferred_bind), (l, None)))], env
- end
-
-let check_funcl env (FCL_aux (FCL_Funcl (id, pat, exp), (l, _))) typ =
- match typ with
- | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) ->
- begin
- let typed_pat, env = bind_pat env (strip_pat pat) typ_arg in
- let env = Env.add_ret_typ typ_ret env in
- let exp = propagate_exp_effect (crule check_exp env (strip_exp exp) typ_ret) in
- FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, Some (env, typ, effect_of exp)))
- end
- | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")
-
-let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, annot))) =
- match annot with
- | Some (_, _, eff) -> eff
- | None -> no_effect (* Maybe could be assert false. This should never happen *)
-
-let infer_funtyp l env tannotopt funcls =
- match tannotopt with
- | Typ_annot_opt_aux (Typ_annot_opt_some (quant, ret_typ), _) ->
- begin
- let rec typ_from_pat (P_aux (pat_aux, (l, _)) as pat) =
- match pat_aux with
- | P_lit lit -> infer_lit env lit
- | P_typ (typ, _) -> typ
- | P_tup pats -> mk_typ (Typ_tup (List.map typ_from_pat pats))
- | _ -> typ_error l ("Cannot infer type from pattern " ^ string_of_pat pat)
- in
- match funcls with
- | [FCL_aux (FCL_Funcl (_, pat, _), _)] ->
- let arg_typ = typ_from_pat pat in
- let fn_typ = mk_typ (Typ_fn (arg_typ, ret_typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in
- (quant, fn_typ)
- | _ -> typ_error l "Cannot infer function type for function with multiple clauses"
- end
- | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error l "Cannot infer function type for unannotated function"
-
-let mk_val_spec typq typ id = DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id), (Parse_ast.Unknown, None)))
-
-let check_tannotopt typq ret_typ = function
- | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> ()
- | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_ret_typ), l) ->
- if typ_identical ret_typ annot_ret_typ
- then ()
- else typ_error l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec")
-
-let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, _)) as fd_aux) =
- let id =
- match (List.fold_right
- (fun (FCL_aux (FCL_Funcl (id, _, _), _)) id' ->
- match id' with
- | Some id' -> if string_of_id id' = string_of_id id then Some id'
- else typ_error l ("Function declaration expects all definitions to have the same name, "
- ^ string_of_id id ^ " differs from other definitions of " ^ string_of_id id')
- | None -> Some id) funcls None)
- with
- | Some id -> id
- | None -> typ_error l "funcl list is empty"
- in
- typ_print ("\nChecking function " ^ string_of_id id);
- let have_val_spec, (quant, (Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) as typ)), env =
- try true, Env.get_val_spec id env, env with
- | Type_error (l, _) ->
- let (quant, typ) = infer_funtyp l env tannotopt funcls in
- false, (quant, typ), env
- in
- check_tannotopt quant vtyp_ret tannotopt;
- typ_debug ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ));
- let funcl_env = add_typquant quant env in
- let funcls = List.map (fun funcl -> check_funcl funcl_env funcl typ) funcls in
- let eff = List.fold_left union_effects no_effect (List.map funcl_effect funcls) in
- let vs_def, env, declared_eff =
- if not have_val_spec
- then
- let typ = Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, eff), vl) in
- [mk_val_spec quant typ id], Env.add_val_spec id (quant, typ) env, eff
- else [], env, declared_eff
- in
- if equal_effects eff declared_eff
- then
- vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env
- else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found")
-
-(* Checking a val spec simply adds the type as a binding in the
- context. We have to destructure the various kinds of val specs, but
- the difference is irrelevant for the typechecker. *)
-let check_val_spec env (VS_aux (vs, (l, _))) =
- let (id, quants, typ, env) = match vs with
- | VS_val_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env)
- | VS_cast_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, Env.add_cast id env)
- | VS_extern_no_rename (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env)
- | VS_extern_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id, _) -> (id, quants, typ, env) in
- [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, typ) env
-
-let check_default env (DT_aux (ds, l)) =
- match ds with
- | DT_kind _ -> [DEF_default (DT_aux (ds,l))], env (* Check: Is this supposed to do nothing? *)
- | DT_order (Ord_aux (Ord_inc, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_inc env
- | DT_order (Ord_aux (Ord_dec, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_dec env
- | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order"
- (* This branch allows us to write something like: default forall Nat 'n. [|'n|] name... what does this even mean?! *)
- | DT_typ (typschm, id) -> typ_error l ("Unsupported default construct")
-
-let check_register env id base top ranges =
- match base, top with
- | Nexp_aux (Nexp_constant basec, _), Nexp_aux (Nexp_constant topc, _) ->
- let no_typq = TypQ_aux (TypQ_tq [], Parse_ast.Unknown) (* Maybe could be TypQ_no_forall? *) in
- (* FIXME: wrong for default Order inc? *)
- let vec_typ = dvector_typ env base (nconstant ((basec - topc) + 1)) bit_typ in
- let cast_typ = mk_typ (Typ_fn (mk_id_typ id, vec_typ, no_effect)) in
- let cast_to_typ = mk_typ (Typ_fn (vec_typ, mk_id_typ id, no_effect)) in
- env
- |> Env.add_regtyp id basec topc ranges
- (* |> Env.add_typ_synonym id (fun _ -> vec_typ) *)
- |> Env.add_val_spec (mk_id ("cast_" ^ string_of_id id)) (no_typq, cast_typ)
- |> Env.add_cast (mk_id ("cast_" ^ string_of_id id))
- |> Env.add_val_spec (mk_id ("cast_to_" ^ string_of_id id)) (no_typq, cast_to_typ)
- |> Env.add_cast (mk_id ("cast_to_" ^ string_of_id id))
- | _, _ -> typ_error (id_loc id) "Num expressions in register type declaration do not evaluate to constants"
-
-let kinded_id_arg kind_id =
- let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in
- match kind_id with
- | KOpt_aux (KOpt_none kid, _) -> typ_arg (Typ_arg_nexp (nvar kid))
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid))
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid), _) ->
- typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown)))
- | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) ->
- typ_arg (Typ_arg_typ (mk_typ (Typ_var kid)))
-
-let fold_union_quant quants (QI_aux (qi, l)) =
- match qi with
- | QI_id kind_id -> quants @ [kinded_id_arg kind_id]
- | _ -> quants
-
-let check_type_union env variant typq (Tu_aux (tu, l)) =
- let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in
- match tu with
- | Tu_id v -> Env.add_union_id v (typq, ret_typ) env
- | Tu_ty_id (typ, v) -> Env.add_val_spec v (typq, mk_typ (Typ_fn (typ, ret_typ, no_effect))) env
-
-let check_typedef env (TD_aux (tdef, (l, _))) =
- let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Typedef") in
- match tdef with
- | TD_abbrev(id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) ->
- [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (fun _ -> typ) env
- | TD_record(id, nmscm, typq, fields, _) ->
- [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env
- | TD_variant(id, nmscm, typq, arms, _) ->
- let env =
- env
- |> Env.add_variant id (typq, arms)
- |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms)
- in
- [DEF_type (TD_aux (tdef, (l, None)))], env
- | TD_enum(id, nmscm, ids, _) ->
- [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env
- | TD_register(id, base, top, ranges) -> [DEF_type (TD_aux (tdef, (l, None)))], check_register env id base top ranges
-
-let rec check_def env def =
- let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Case") in
- match def with
- | DEF_kind kdef -> cd_err ()
- | DEF_type tdef -> check_typedef env tdef
- | DEF_fundef fdef -> check_fundef env fdef
- | DEF_val letdef -> check_letdef env letdef
- | DEF_spec vs -> check_val_spec env vs
- | DEF_default default -> check_default env default
- | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
- | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) ->
- [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, None)))], Env.add_register id typ env
- | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err ()
- | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err ()
- | DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Scattered given to type checker")
- | DEF_comm (DC_comm str) -> [DEF_comm (DC_comm str)], env
- | DEF_comm (DC_comm_struct def) ->
- let defs, env = check_def env def
- in List.map (fun def -> DEF_comm (DC_comm_struct def)) defs, env
-
-let rec check' env (Defs defs) =
- match defs with
- | [] -> (Defs []), env
- | def :: defs ->
- let (def, env) = check_def env def in
- let (Defs defs, env) = check' env (Defs defs) in
- (Defs (def @ defs)), env
-
-let check env defs =
- try check' env defs with
- | Type_error (l, m) -> raise (Reporting_basic.err_typ l m)
diff --git a/src/type_check_new.mli b/src/type_check_new.mli
deleted file mode 100644
index 723f796a..00000000
--- a/src/type_check_new.mli
+++ /dev/null
@@ -1,217 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* Alasdair Armstrong *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-open Ast
-open Ast_util
-
-val opt_tc_debug : int ref
-
-exception Type_error of l * string;;
-
-type mut = Immutable | Mutable
-
-type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound
-
-module Env : sig
- (* Env.t is the type of environments *)
- type t
-
- (* Note: Most get_ functions assume the identifiers exist, and throw type
- errors if it doesn't. *)
-
- val get_val_spec : id -> t -> typquant * typ
-
- val get_register : id -> t -> typ
-
- val get_regtyp : id -> t -> int * int * (index_range * id) list
-
- (* Return all the identifiers in an enumeration. Throws a type error
- if the enumeration doesn't exist. *)
- val get_enum : id -> t -> id list
-
- (* Returns true if id is a register type, false otherwise *)
- val is_regtyp : id -> t -> bool
-
- (* Check if a local variable is mutable. Throws Type_error if it
- isn't a local variable. Probably best to use Env.lookup_id
- instead *)
- val is_mutable : id -> t -> bool
-
- (* Get the current set of constraints. *)
- val get_constraints : t -> n_constraint list
-
- val get_typ_var : kid -> t -> base_kind_aux
-
- val get_typ_vars : t -> base_kind_aux KBindings.t
-
- val is_record : id -> t -> bool
-
- val get_accessor : id -> t -> typquant * typ
-
- (* If the environment is checking a function, then this will get the
- expected return type of the function. It's useful for checking or
- inserting early returns. Returns an option type and won't throw
- any exceptions. *)
- val get_ret_typ : t -> typ option
-
- val get_typ_synonym : id -> t -> typ_arg list -> typ
-
- val get_overloads : id -> t -> id list
-
- (* Lookup id searchs for a specified id in the environment, and
- returns it's type and what kind of identifier it is, using the
- lvar type. Returns Unbound if the identifier is unbound, and
- won't throw any exceptions. *)
- val lookup_id : id -> t -> lvar
-
- (* Return a fresh kind identifier that doesn't exist in the environment *)
- val fresh_kid : t -> kid
-
- val expand_synonyms : t -> typ -> typ
-
- (* Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *)
- val base_typ_of : t -> typ -> typ
-
- (* no_casts removes all the implicit type casts/coercions from the
- environment, so checking a term with such an environment will
- guarantee not to insert any casts. Not that this is only about
- the implicit casting and has nothing to do with the E_cast AST
- node. *)
- val no_casts : t -> t
-
- (* Is casting allowed by the environment? *)
- val allow_casts : t -> bool
-
- val empty : t
-
-end
-
-val add_typquant : typquant -> Env.t -> Env.t
-
-(* Some handy utility functions for constructing types. *)
-val mk_typ : typ_aux -> typ
-val mk_typ_arg : typ_arg_aux -> typ_arg
-val mk_id : string -> id
-val mk_id_typ : id -> typ
-
-val no_effect : effect
-val mk_effect : base_effect_aux list -> effect
-
-val union_effects : effect -> effect -> effect
-val equal_effects : effect -> effect -> bool
-
-val nconstant : int -> nexp
-val nminus : nexp -> nexp -> nexp
-val nsum : nexp -> nexp -> nexp
-val ntimes : nexp -> nexp -> nexp
-val npow2 : nexp -> nexp
-val nvar : kid -> nexp
-
-(* Sail builtin types. *)
-val int_typ : typ
-val nat_typ : typ
-val atom_typ : nexp -> typ
-val range_typ : nexp -> nexp -> typ
-val bit_typ : typ
-val bool_typ : typ
-val unit_typ : typ
-val string_typ : typ
-val real_typ : typ
-val vector_typ : nexp -> nexp -> order -> typ -> typ
-
-val inc_ord : order
-val dec_ord : order
-
-(* Vector with default order. *)
-val dvector_typ : Env.t -> nexp -> nexp -> typ -> typ
-
-(* Vector of specific length with default order, i.e. lvector_typ env n bit_typ = bit[n]. *)
-val lvector_typ : Env.t -> nexp -> typ -> typ
-
-type tannot = (Env.t * typ * effect) option
-
-(* Strip the type annotations from an expression. *)
-val strip_exp : 'a exp -> unit exp
-val strip_pat : 'a pat -> unit pat
-
-(* Check an expression has some type. Returns a fully annotated
- version of the expression, where each subexpression is annotated
- with it's type and the Environment used while checking it. The can
- be used to re-start the typechecking process on any
- sub-expression. so local modifications to the AST can be
- re-checked. *)
-val check_exp : Env.t -> unit exp -> typ -> tannot exp
-
-(* Partial functions: The expressions and patterns passed to these
- functions must be guaranteed to have tannots of the form Some (env,
- typ) for these to work. *)
-val typ_of : tannot exp -> typ
-val typ_of_annot : Ast.l * tannot -> typ
-
-val pat_typ_of : tannot pat -> typ
-
-val effect_of : tannot exp -> effect
-val effect_of_annot : tannot -> effect
-
-val propagate_exp_effect : tannot exp -> tannot exp
-
-(* Fully type-check an AST
-
-Some invariants that will hold of a fully checked AST are:
-
- * No internal nodes, such as E_internal_exp, or E_comment nodes.
-
- * E_vector_access nodes and similar will be replaced by function
- calls E_app to vector access functions. This is different to the
- old type checker.
-
- * Every expressions type annotation (tannot) will be Some (typ, env).
-
- * Also every pattern will be annotated with the type it matches.
-
- * Toplevel expressions such as typedefs and some subexpressions such
- as letbinds may have None as their tannots if it doesn't make sense
- for them to have type annotations. *)
-val check : Env.t -> 'a defs -> tannot defs * Env.t
-
-val initial_env : Env.t
diff --git a/src/type_internal.ml b/src/type_internal.ml
deleted file mode 100644
index 96e8fbe1..00000000
--- a/src/type_internal.ml
+++ /dev/null
@@ -1,4545 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-open Ast
-open Util
-open Big_int
-module Envmap = Finite_map.Fmap_map(String)
-module Nameset' = Set.Make(String)
-module Nameset = struct
- include Nameset'
- let pp ppf nameset =
- Format.fprintf ppf "{@[%a@]}"
- (Pp.lst ",@ " Pp.pp_str)
- (Nameset'.elements nameset)
-end
-
-let zero = big_int_of_int 0
-let one = big_int_of_int 1
-let two = big_int_of_int 2
-
-type kind = { mutable k : k_aux }
-and k_aux =
- | K_Typ
- | K_Nat
- | K_Ord
- | K_Efct
- | K_Val
- | K_Lam of kind list * kind
- | K_infer
-
- type t = { mutable t : t_aux }
-and t_aux =
- | Tvar of string
- | Tid of string
- | Tfn of t * t * implicit_parm * effect
- | Ttup of t list
- | Tapp of string * t_arg list
- | Tabbrev of t * t
- | Toptions of t * t option
- | Tuvar of t_uvar
-and t_uvar = { index : int; mutable subst : t option ; mutable torig_name : string option}
-and implicit_parm =
- | IP_none | IP_length of nexp | IP_start of nexp | IP_user of nexp
-and nexp = { mutable nexp : nexp_aux; mutable imp_param : bool}
-and nexp_aux =
- | Nvar of string
- | Nid of string * nexp (*First term is the name of this nid, second is the constant it represents*)
- | Nconst of big_int
- | Npos_inf
- | Nneg_inf
- | Nadd of nexp * nexp
- | Nsub of nexp * nexp
- | Nmult of nexp * nexp
- | N2n of nexp * big_int option
- | Npow of nexp * int (* nexp raised to the int *)
- | Nneg of nexp (* Unary minus for representing new vector sizes after vector slicing *)
- | Ninexact (*Result of +inf + -inf which is neither less than nor greater than other numbers really *)
- | Nuvar of n_uvar
-and n_uvar =
- (*nindex is a counter; insubst are substitions 'inward'; outsubst are substitions 'outward'. Inward can be non nu
- nin is in an in clause; leave_var flags if we should try to stay a variable; orig_var out inwardmost, name to use
- *)
- { nindex : int; mutable insubst : nexp option; mutable outsubst : nexp option;
- mutable nin : bool; mutable leave_var : bool; mutable orig_var : string option ; mutable been_collapsed : bool }
-and effect = { mutable effect : effect_aux }
-and effect_aux =
- | Evar of string
- | Eset of base_effect list
- | Euvar of e_uvar
-and e_uvar = { eindex : int; mutable esubst : effect option }
-and order = { mutable order : order_aux }
-and order_aux =
- | Ovar of string
- | Oinc
- | Odec
- | Ouvar of o_uvar
-and o_uvar = { oindex : int; mutable osubst : order option }
-and t_arg =
- | TA_typ of t
- | TA_nexp of nexp
- | TA_eft of effect
- | TA_ord of order
-
-type alias_inf =
- | Alias_field of string * string
- | Alias_extract of string * int * int
- | Alias_pair of string * string
-
-type tag =
- | Emp_local
- | Emp_global
- | Emp_intro
- | Emp_set
- | Tuple_assign of tag list
- | External of string option
- | Default
- | Constructor of int
- | Enum of int
- | Alias of alias_inf
- | Spec
-
-let rec compare_nexps n1 n2 =
- match n1.nexp,n2.nexp with
- | Nneg_inf , Nneg_inf -> 0
- | Nneg_inf , _ -> -1
- | _ , Nneg_inf -> 1
- | Nconst n1, Nconst n2 -> compare_big_int n1 n2
- | Nconst _ , _ -> -1
- | _ , Nconst _ -> 1
- | Nid(i1,n1), Nid(i2,n2) ->
- (match compare i1 i2 with
- | 0 -> 0
- | _ -> compare_nexps n1 n2)
- | Nid _ , _ -> -1
- | _ , Nid _ -> 1
- | Nvar i1 , Nvar i2 -> compare i1 i2
- | Nvar _ , _ -> -1
- | _ , Nvar _ -> 1
- | Nuvar {nindex = n1}, Nuvar {nindex = n2} -> compare n1 n2
- | Nuvar _ , _ -> -1
- | _ , Nuvar _ -> 1
- | Nmult(n0,n1),Nmult(n2,n3) ->
- (match compare_nexps n0 n2 with
- | 0 -> compare_nexps n1 n3
- | a -> a)
- | Nmult _ , _ -> -1
- | _ , Nmult _ -> 1
- | Nadd(n1,n12),Nadd(n2,n22) ->
- (match compare_nexps n1 n2 with
- | 0 -> compare_nexps n12 n22
- | a -> a)
- | Nadd _ , _ -> -1
- | _ , Nadd _ -> 1
- | Nsub(n1,n12),Nsub(n2,n22) ->
- (match compare_nexps n1 n2 with
- | 0 -> compare_nexps n12 n22
- | a -> a)
- | Nsub _ , _ -> -1
- | _ , Nsub _ -> 1
- | Npow(n1,_),Npow(n2,_)-> compare_nexps n1 n2
- | Npow _ , _ -> -1
- | _ , Npow _ -> 1
- | N2n(_,Some i1), N2n(_,Some i2) -> compare_big_int i1 i2
- | N2n(n1,_), N2n(n2,_) -> compare_nexps n1 n2
- | N2n _ , _ -> -1
- | _ , N2n _ -> 1
- | Nneg n1 , Nneg n2 -> compare_nexps n1 n2
- | Nneg _ , _ -> -1
- | _ , Nneg _ -> 1
- | Npos_inf , Npos_inf -> 0
- | Npos_inf , _ -> -1
- | _ , Npos_inf -> 1
- | Ninexact , Ninexact -> 0
-
-module NexpM =
- struct
- type t = nexp
- let compare = compare_nexps
-end
-module Var_set = Set.Make(NexpM)
-module Nexpmap = Finite_map.Fmap_map(NexpM)
-
-type nexp_map = nexp Nexpmap.t
-
-type constraint_origin =
- | Patt of Parse_ast.l
- | Expr of Parse_ast.l
- | Fun of Parse_ast.l
- | Specc of Parse_ast.l
-
-type range_enforcement = Require | Guarantee
-type cond_kind = Positive | Negative | Solo | Switch
-type 'a many = One of 'a | Two of 'a * 'a | Many of 'a list
-
-(* Constraints for nexps, plus the location which added the constraint *)
-type nexp_range =
- | LtEq of constraint_origin * range_enforcement * nexp * nexp
- | Lt of constraint_origin * range_enforcement * nexp * nexp
- | Eq of constraint_origin * nexp * nexp
- | NtEq of constraint_origin * nexp * nexp
- | GtEq of constraint_origin * range_enforcement * nexp * nexp
- | Gt of constraint_origin * range_enforcement * nexp * nexp
- | In of constraint_origin * string * int list
- | InS of constraint_origin * nexp * int list
- | Predicate of constraint_origin * nexp_range * nexp_range
- | CondCons of constraint_origin * cond_kind * (nexp Nexpmap.t) option * nexp_range list * nexp_range list
- | BranchCons of constraint_origin * ((nexp many) Nexpmap.t) option * nexp_range list
-
-type variable_range =
- | VR_eq of string * nexp
- | VR_range of string * nexp_range list
- | VR_vec_eq of string * nexp
- | VR_vec_r of string * nexp_range list
- | VR_recheck of string * t (*For cases where inference hasn't yet determined the type of v*)
-
-type bounds_env =
- | No_bounds
- | Bounds of variable_range list * nexp_map option
-
-type t_params = (string * kind) list
-type tannot =
- | NoTyp
- (*See .mli for purpose of attributes *)
- | Base of (t_params * t) * tag * nexp_range list * effect * effect * bounds_env
- (* First tannot is the most polymorphic version; the list includes all variants. All included t are Tfn *)
- | Overload of tannot * bool * tannot list (* these tannot's should all be Base *)
-
-type 'a emap = 'a Envmap.t
-
-type rec_kind = Record | Register
-type rec_env = (string * rec_kind * tannot * ((string * t) list))
-type alias_kind = OneReg of string * tannot | TwoReg of string * string * tannot | MultiReg of (string list) * tannot
-type def_envs = {
- k_env: kind emap;
- abbrevs: tannot emap;
- nabbrevs: nexp emap;
- namesch : tannot emap;
- enum_env : (string list) emap;
- rec_env : rec_env list;
- alias_env : alias_kind emap;
- default_o : order;
- }
-
-type triple = Yes | No | Maybe
-let triple_negate = function
- | Yes -> No
- | No -> Yes
- | Maybe -> Maybe
-
-type exp = tannot Ast.exp
-
-type minmax = (constraint_origin * nexp) option
-type constraints = nexp_range list
-
-(*Nexpression Makers (as built so often)*)
-
-let mk_nv s = {nexp = Nvar s; imp_param = false}
-let mk_nid s n = {nexp = Nid(s,n); imp_param = false}
-let mk_add n1 n2 = {nexp = Nadd(n1,n2); imp_param = false}
-let mk_sub n1 n2 = {nexp = Nsub(n1,n2); imp_param = false}
-let mk_mult n1 n2 = {nexp = Nmult(n1,n2); imp_param = false}
-let mk_c i = {nexp = Nconst i; imp_param = false}
-let mk_c_int i = mk_c (big_int_of_int i)
-let mk_neg n = {nexp = Nneg n; imp_param = false}
-let mk_2n n = {nexp = N2n(n, None); imp_param = false}
-let mk_2nc n i = {nexp = N2n(n, Some i); imp_param = false}
-let mk_pow n i = {nexp = Npow(n, i); imp_param = false}
-let mk_p_inf () = {nexp = Npos_inf; imp_param = false}
-let mk_n_inf () = {nexp = Nneg_inf; imp_param = false}
-let mk_inexact () = {nexp = Ninexact; imp_param = false}
-
-let merge_option_maps m1 m2 =
- match m1,m2 with
- | None,None -> None
- | None,m | m, None -> m
- | Some m1, Some m2 -> Some (Nexpmap.union m1 m2)
-
-(*Getters*)
-
-let get_index n =
- match n.nexp with
- | Nuvar {nindex = i} -> i
- | _ -> assert false
-
-let get_c_loc = function
- | Patt l | Expr l | Specc l | Fun l -> l
-
-let rec get_outer_most n = match n.nexp with
- | Nuvar {outsubst= Some n} -> get_outer_most n
- | _ -> n
-
-let rec get_inner_most n = match n.nexp with
- | Nuvar {insubst=Some n} -> get_inner_most n
- | _ -> n
-
-(*To string functions *)
-let debug_mode = ref true;;
-
-let rec kind_to_string kind = match kind.k with
- | K_Nat -> "Nat"
- | K_Typ -> "Type"
- | K_Ord -> "Order"
- | K_Efct -> "Effect"
- | K_infer -> "Infer"
- | K_Val -> "Val"
- | K_Lam (kinds,kind) -> "Lam [" ^ string_of_list ", " kind_to_string kinds ^ "] -> " ^ (kind_to_string kind)
-
-let co_to_string = function
- | Patt l -> "Pattern " (*^ Reporting_basic.loc_to_string l *)
- | Expr l -> "Expression " (*^ Reporting_basic.loc_to_string l *)
- | Fun l -> "Function def " (*^ Reporting_basic.loc_to_string l *)
- | Specc l -> "Specification " (*^ Reporting_basic.loc_to_string l *)
-
-let rec t_to_string t =
- match t.t with
- | Tid i -> i
- | Tvar i -> i
- | Tfn(t1,t2,imp,e) ->
- let implicit = match imp with
- | IP_none -> ""
- | IP_length n | IP_start n | IP_user n -> " with implicit parameter " ^ n_to_string n ^ " " in
- (t_to_string t1) ^ " -> " ^ (t_to_string t2) ^ " effect " ^ e_to_string e ^ implicit
- | Ttup(tups) -> "(" ^ string_of_list ", " t_to_string tups ^ ")"
- | Tapp(i,args) -> i ^ "<" ^ string_of_list ", " targ_to_string args ^ ">"
- | Tabbrev(ti,ta) -> (t_to_string ti) ^ " : " ^ (t_to_string ta)
- | Toptions(t1,None) -> if !debug_mode then ("optionally " ^ (t_to_string t1)) else (t_to_string t1)
- | Toptions(t1,Some t2) -> if !debug_mode then ("(either "^ (t_to_string t1) ^ " or " ^ (t_to_string t2) ^ ")") else "_"
- | Tuvar({index = i;subst = a}) ->
- if !debug_mode then "Tu_" ^ string_of_int i ^ "("^ (match a with | None -> "None" | Some t -> t_to_string t) ^")" else "_"
-and targ_to_string = function
- | TA_typ t -> t_to_string t
- | TA_nexp n -> n_to_string n
- | TA_eft e -> e_to_string e
- | TA_ord o -> o_to_string o
-and n_to_string n =
- match n.nexp with
- | Nid(i,n) -> i ^ "(*" ^ (n_to_string n) ^ "*)"
- | Nvar i -> i
- | Nconst i -> string_of_big_int i
- | Npos_inf -> "infinity"
- | Nneg_inf -> "-infinity"
- | Ninexact -> "infinity - infinity"
- | Nadd(n1,n2) -> "("^ (n_to_string n1) ^ " + " ^ (n_to_string n2) ^")"
- | Nsub(n1,n2) -> "("^ (n_to_string n1) ^ " - " ^ (n_to_string n2) ^ ")"
- | Nmult(n1,n2) -> "(" ^ (n_to_string n1) ^ " * " ^ (n_to_string n2) ^ ")"
- | N2n(n,None) -> "2**" ^ (n_to_string n)
- | N2n(n,Some i) -> "2**" ^ (n_to_string n) ^ "(*" ^ (string_of_big_int i) ^ "*)"
- | Npow(n, i) -> "(" ^ (n_to_string n) ^ ")**" ^ (string_of_int i)
- | Nneg n -> "-" ^ (n_to_string n)
- | Nuvar _ ->
- if !debug_mode
- then
- let rec show_nuvar n = match n.nexp with
- | Nuvar{insubst=None; nindex = i; orig_var = Some s} -> s^ "()"
- | Nuvar{insubst=Some n; nindex = i; orig_var = Some s} -> s ^ "(" ^ show_nuvar n ^ ")"
- | Nuvar{insubst=None; nindex = i;} -> "Nu_" ^ string_of_int i ^ "()"
- | Nuvar{insubst=Some n; nindex =i;} -> "Nu_" ^ string_of_int i ^ "(" ^ show_nuvar n ^ ")"
- | _ -> n_to_string n in
- show_nuvar (get_outer_most n)
- else "_"
-and ef_to_string (Ast.BE_aux(b,l)) =
- match b with
- | Ast.BE_rreg -> "rreg"
- | Ast.BE_wreg -> "wreg"
- | Ast.BE_rmem -> "rmem"
- | Ast.BE_rmemt -> "rmemt"
- | Ast.BE_wmem -> "wmem"
- | Ast.BE_wmv -> "wmv"
- | Ast.BE_wmvt -> "wmvt"
- | Ast.BE_eamem -> "eamem"
- | Ast.BE_exmem -> "exmem"
- | Ast.BE_barr -> "barr"
- | Ast.BE_undef -> "undef"
- | Ast.BE_depend -> "depend"
- | Ast.BE_unspec-> "unspec"
- | Ast.BE_nondet-> "nondet"
- | Ast.BE_lset -> "lset"
- | Ast.BE_lret -> "lret"
- | Ast.BE_escape -> "escape"
-and efs_to_string es =
- match es with
- | [] -> ""
- | [ef] -> ef_to_string ef
- | ef::es -> ef_to_string ef ^ ", " ^ efs_to_string es
-and e_to_string e =
- match e.effect with
- | Evar i -> "'" ^ i
- | Eset es -> if []=es then "pure" else "{" ^ (efs_to_string es) ^"}"
- | Euvar({eindex=i;esubst=a}) -> if !debug_mode then string_of_int i ^ "()" else "_"
-and o_to_string o =
- match o.order with
- | Ovar i -> "'" ^ i
- | Oinc -> "inc"
- | Odec -> "dec"
- | Ouvar({oindex=i;osubst=a}) -> if !debug_mode then string_of_int i ^ "()" else "_"
-
-let rec tag_to_string = function
- | Emp_local -> "Emp_local"
- | Emp_global -> "Emp_global"
- | Emp_intro -> "Emp_intro"
- | Emp_set -> "Emp_set"
- | Tuple_assign tags -> "Tuple_assign (" ^ string_of_list ", " tag_to_string tags ^ ")"
- | External None -> "External"
- | External (Some s) -> "External " ^ s
- | Default -> "Default"
- | Constructor _ -> "Constructor"
- | Enum _ -> "Enum"
- | Alias _ -> "Alias"
- | Spec -> "Spec"
-
-let enforce_to_string = function
- | Require -> "require"
- | Guarantee -> "guarantee"
-
-let cond_kind_to_string = function
- | Positive -> "positive"
- | Negative -> "negative"
- | Solo -> "solo"
- | Switch -> "switch"
-
-let rec constraint_to_string = function
- | LtEq (co,enforce,nexp1,nexp2) ->
- "LtEq(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^
- n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | Lt (co,enforce,nexp1, nexp2) ->
- "Lt(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^
- n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | Eq (co,nexp1,nexp2) ->
- "Eq(" ^ co_to_string co ^ ", " ^ n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | NtEq(co,nexp1,nexp2) ->
- "NtEq(" ^ co_to_string co ^ ", " ^ n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | GtEq (co,enforce,nexp1,nexp2) ->
- "GtEq(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^
- n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | Gt (co,enforce,nexp1,nexp2) ->
- "Gt(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^
- n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")"
- | In(co,var,ints) -> "In of " ^ var
- | InS(co,n,ints) -> "InS of " ^ n_to_string n
- | Predicate(co,cp,cn) ->
- "Pred(" ^ co_to_string co ^ ", " ^ constraint_to_string cp ^", " ^ constraint_to_string cn ^ ")"
- | CondCons(co,kind,_,pats,exps) ->
- "CondCons(" ^ co_to_string co ^ ", " ^ cond_kind_to_string kind ^
- ", [" ^ constraints_to_string pats ^ "], [" ^ constraints_to_string exps ^ "])"
- | BranchCons(co,_,consts) ->
- "BranchCons(" ^ co_to_string co ^ ", [" ^ constraints_to_string consts ^ "])"
-and constraints_to_string l = string_of_list "; " constraint_to_string l
-
-let variable_range_to_string v = match v with
- | VR_eq (s,n) -> "vr_eq(" ^ s ^ ", " ^ n_to_string n ^ ")"
- | VR_range (s,cs) -> "vr_range(" ^ s ^ ", " ^ constraints_to_string cs ^ ")"
- | VR_vec_eq (s,n) -> "vr_vec_eq(" ^ s ^ ", " ^ n_to_string n ^ ")"
- | VR_vec_r (s,cs) -> "vr_vec_r(" ^ s ^ ", "^ constraints_to_string cs ^ ")"
- | VR_recheck (s,t) -> "vr_recheck(" ^ s ^ ", "^ t_to_string t ^ ")"
-
-let bounds_to_string b = match b with
- | No_bounds -> "Nobounds"
- | Bounds(vs,map)-> "Bounds(" ^ string_of_list "; " variable_range_to_string vs ^ ")"
-
-let rec tannot_to_string = function
- | NoTyp -> "No tannot"
- | Base((vars,t),tag,ncs,ef_l,ef_r,bv) ->
- "Tannot: type = " ^ (t_to_string t) ^ " tag = " ^ tag_to_string tag ^ " constraints = " ^
- constraints_to_string ncs ^ " effect_l = " ^ e_to_string ef_l ^ " effect_r = " ^ e_to_string ef_r ^
- "boundv = " ^ bounds_to_string bv
- | Overload(poly,_,variants) ->
- "Overloaded: poly = " ^ tannot_to_string poly
-
-(* nexp constants, commonly used*)
-let n_zero = mk_c zero
-let n_one = mk_c one
-let n_two = mk_c two
-
-(*effect functions*)
-let rec effect_remove_dups = function
- | [] -> []
- | (BE_aux(be,l))::es ->
- if (List.exists (fun (BE_aux(be',_)) -> be = be') es)
- then effect_remove_dups es
- else (BE_aux(be,l))::(effect_remove_dups es)
-
-let add_effect e ef =
- match ef.effect with
- | Evar s -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "add_effect given var instead of uvar")
- | Eset bases -> {effect = Eset (effect_remove_dups (e::bases))}
- | Euvar _ -> ef.effect <- Eset [e]; ef
-
-let union_effects e1 e2 =
- match e1.effect,e2.effect with
- | Evar s,_ | _,Evar s ->
- raise (Reporting_basic.err_unreachable Parse_ast.Unknown "union_effects given var(s) instead of uvar(s)")
- | Euvar _,_ -> e1.effect <- e2.effect; e2
- | _,Euvar _ -> e2.effect <- e1.effect; e2
- | Eset b1, Eset b2 ->
- (*let _ = Printf.eprintf "union effects of length %s and %s\n" (e_to_string e1) (e_to_string e2) in*)
- {effect= Eset (effect_remove_dups (b1@b2))}
-
-let remove_local_effects ef = match ef.effect with
- | Evar _ | Euvar _ | Eset [] -> ef
- | Eset effects ->
- {effect = Eset (List.filter (fun (BE_aux(be,l)) -> (match be with | BE_lset | BE_lret -> false | _ -> true))
- (effect_remove_dups effects)) }
-
-let rec lookup_record_typ (typ : string) (env : rec_env list) : rec_env option =
- match env with
- | [] -> None
- | ((id,_,_,_) as r)::env ->
- if typ = id then Some(r) else lookup_record_typ typ env
-
-let rec fields_match f1 f2 =
- match f1 with
- | [] -> true
- | f::fs -> (List.mem_assoc f f2) && fields_match fs f2
-
-let rec lookup_record_fields (fields : string list) (env : rec_env list) : rec_env option =
- match env with
- | [] -> None
- | ((id,r,t,fs) as re)::env ->
- if ((List.length fields) = (List.length fs)) &&
- (fields_match fields fs) then
- Some re
- else lookup_record_fields fields env
-
-let rec lookup_possible_records (fields : string list) (env : rec_env list) : rec_env list =
- match env with
- | [] -> []
- | ((id,r,t,fs) as re)::env ->
- if (((List.length fields) <= (List.length fs)) &&
- (fields_match fields fs))
- then re::(lookup_possible_records fields env)
- else lookup_possible_records fields env
-
-let lookup_field_type (field: string) ((id,r_kind,tannot,fields) : rec_env) : t option =
- if List.mem_assoc field fields
- then Some(List.assoc field fields)
- else None
-
-let rec pow_i i n =
- match n with
- | 0 -> one
- | n -> mult_int_big_int i (pow_i i (n-1))
-let two_pow = pow_i 2
-
-(* predicate to determine if pushing a constant in for addition or multiplication could change the form *)
-let rec contains_const n =
- match n.nexp with
- | Nvar _ | Nuvar _ | Npow _ | N2n _ | Npos_inf | Nneg_inf | Ninexact -> false
- | Nconst _ | Nid _ -> true
- | Nneg n -> contains_const n
- | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (contains_const n1) || (contains_const n2)
-
-let rec is_all_nuvar n =
- match n.nexp with
- | Nuvar { insubst = None } -> true
- | Nuvar { insubst = Some n } -> is_all_nuvar n
- | _ -> false
-
-let rec first_non_nu n =
- match n.nexp with
- | Nuvar {insubst = None } -> None
- | Nuvar { insubst = Some n} -> first_non_nu n
- | _ -> Some n
-
-(*Adds new_base to inner most position of n, when that is None
- Report whether mutation happened*)
-let add_to_nuvar_tail n new_base =
- if n.nexp == new_base.nexp
- then false
- else
- let n' = get_inner_most n in
- let new_base' = get_outer_most new_base in
- match n'.nexp,new_base'.nexp with
- | Nuvar ({insubst = None} as nmu), Nuvar(nbmu) ->
- nmu.insubst <- Some new_base';
- nbmu.outsubst <- Some n'; true
- | Nuvar({insubst = None} as nmu),_ ->
- if new_base.nexp == new_base'.nexp
- then begin nmu.insubst <- Some new_base; true end
- else false
- | _ -> false
-
-let rec get_var n =
- match n.nexp with
- | Nvar _ | Nuvar _ | N2n _ -> Some n
- | Nneg n -> get_var n
- | Nmult (_,n1) -> get_var n1
- | _ -> None
-
-let rec get_all_nvar n =
- match n.nexp with
- | Nvar v -> [v]
- | Nneg n | N2n(n,_) | Npow(n,_) -> get_all_nvar n
- | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (get_all_nvar n1)@(get_all_nvar n2)
- | _ -> []
-
-let get_factor n =
- match n.nexp with
- | Nvar _ | Nuvar _ -> n_one
- | Nmult (n1,_) -> n1
- | _ -> assert false
-
-let increment_factor n i =
- match n.nexp with
- | Nvar _ | Nuvar _ | N2n _->
- (match i.nexp with
- | Nconst i ->
- let ni = add_big_int i one in
- if eq_big_int ni zero
- then n_zero
- else mk_mult (mk_c ni) n
- | _ -> mk_mult (mk_add i n_one) n)
- | Nmult(n1,n2) ->
- (match n1.nexp,i.nexp with
- | Nconst i2,Nconst i ->
- let ni = add_big_int i i2 in
- if eq_big_int ni zero
- then n_zero
- else mk_mult (mk_c(add_big_int i i2)) n2
- | _ -> mk_mult (mk_add n1 i) n2)
- | _ -> let _ = Printf.eprintf "increment_factor failed with %s by %s\n" (n_to_string n) (n_to_string i) in assert false
-
-let negate n = match n.nexp with
- | Nconst i -> mk_c (mult_int_big_int (-1) i)
- | _ -> mk_mult (mk_c_int (-1)) n
-
-let odd n = (n mod 2) = 1
-
-(*Expects a normalized nexp*)
-let rec nexp_negative n =
- match n.nexp with
- | Nconst i -> if lt_big_int i zero then Yes else No
- | Nneg_inf -> Yes
- | Npos_inf | N2n _ | Nvar _ | Nuvar _ -> No
- | Nmult(n1,n2) -> (match nexp_negative n1, nexp_negative n2 with
- | Yes,Yes | No, No -> No
- | No, Yes | Yes, No -> Yes
- | Maybe,_ | _, Maybe -> Maybe)
- | Nadd(n1,n2) -> (match nexp_negative n1, nexp_negative n2 with
- | Yes,Yes -> Yes
- | No, No -> No
- | _ -> Maybe)
- | Npow(n1,i) ->
- (match nexp_negative n1 with
- | Yes -> if odd i then Yes else No
- | No -> No
- | Maybe -> if odd i then Maybe else No)
- | _ -> Maybe
-
-let rec normalize_n_rec recur_ok n =
- (*let _ = Printf.eprintf "Working on normalizing %s\n" (n_to_string n) in *)
- match n.nexp with
- | Nid(_,n) -> normalize_n_rec true n
- | Nuvar _ ->
- (match first_non_nu (get_outer_most n) with
- | None -> n
- | Some n' -> n')
- | Nconst _ | Nvar _ | Npos_inf | Nneg_inf | Ninexact -> n
- | Nneg n ->
- let n',to_recur,add_neg = (match n.nexp with
- | Nconst i -> negate n,false,false
- | Nadd(n1,n2) -> mk_add (negate n1) (negate n2),true,false
- | Nsub(n1,n2) -> mk_sub n2 n1,true,false
- | Nneg n -> n,true,false
- | _ -> n,true,true) in
- if to_recur
- then (let n' = normalize_n_rec true n' in
- if add_neg
- then negate n'
- else n')
- else n'
- | Npow(n,i) ->
- let n' = normalize_n_rec true n in
- (match n'.nexp with
- | Nconst n -> mk_c (pow_i i (int_of_big_int n))
- | _ -> mk_pow n' i)
- | N2n(n', Some i) -> n (*Because there is a value for Some, we know this is normalized and n' is constant*)
- | N2n(n, None) ->
- let n' = normalize_n_rec true n in
- (match n'.nexp with
- | Nconst i -> mk_2nc n' (two_pow (int_of_big_int i))
- | _ -> mk_2n n')
- | Nadd(n1,n2) ->
- let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in
- (match n1'.nexp,n2'.nexp, recur_ok with
- | Nneg_inf, Npos_inf,_ | Npos_inf, Nneg_inf,_ -> mk_inexact()
- | Npos_inf, _,_ | _, Npos_inf, _ -> mk_p_inf()
- | Nneg_inf, _,_ | _, Nneg_inf, _ -> mk_n_inf()
- | Nconst i1, Nconst i2,_ | Nconst i1, N2n(_,Some i2),_
- | N2n(_,Some i2), Nconst i1,_ | N2n(_,Some i1),N2n(_,Some i2),_
- -> mk_c (add_big_int i1 i2)
- | Nadd(n11,n12), Nconst i, true ->
- if (eq_big_int i zero) then n1'
- else normalize_n_rec false (mk_add n11 (normalize_n_rec false (mk_add n12 n2')))
- | Nadd(n11,n12), Nconst i, false ->
- if (eq_big_int i zero) then n1'
- else mk_add n11 (normalize_n_rec false (mk_add n12 n2'))
- | Nconst i, Nadd(n21,n22), true ->
- if (eq_big_int i zero) then n2'
- else normalize_n_rec false (mk_add n21 (normalize_n_rec false (mk_add n22 n1')))
- | Nconst i, Nadd(n21,n22), false ->
- if (eq_big_int i zero) then n2'
- else mk_add n21 (normalize_n_rec false (mk_add n22 n1'))
- | Nconst i, _,_ -> if (eq_big_int i zero) then n2' else mk_add n2' n1'
- | _, Nconst i,_ -> if (eq_big_int i zero) then n1' else mk_add n1' n2'
- | Nvar _, Nuvar _,_ | Nvar _, N2n _,_ | Nuvar _, Npow _,_ | Nuvar _, N2n _,_ -> mk_add n2' n1'
- | Nadd(n11,n12), Nadd(n21,n22), true ->
- (match compare_nexps n11 n21 with
- | -1 -> normalize_n_rec false (mk_add n11 (normalize_n_rec false (mk_add n12 n2')))
- | 0 ->
- (match compare_nexps n12 n22 with
- | -1 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n22 n12))
- | 0 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_mult n_two n12))
- | _ -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n12 n22)))
- | _ -> normalize_n_rec false (mk_add n21 (normalize_n_rec false (mk_add n22 n1'))))
- | Nadd(n11,n12), Nadd(n21,n22), false ->
- (match compare_nexps n11 n21 with
- | -1 -> mk_add n11 (normalize_n_rec false (mk_add n12 n2'))
- | 0 ->
- (match compare_nexps n12 n22 with
- | -1 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n22 n12))
- | 0 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_mult n_two n12))
- | _ -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n12 n22)))
- | _ -> mk_add n21 (normalize_n_rec false (mk_add n22 n1')))
- | N2n(n11,_), N2n(n21,_),_ ->
- (match compare_nexps n11 n21 with
- | -1 -> mk_add n2' n1'
- | 0 -> mk_2n (normalize_n_rec true (mk_add n11 n_one))
- | _ -> mk_add n1' n2')
- | Npow(n11,i1), Npow (n21,i2),_ ->
- (match compare_nexps n11 n21, compare i1 i2 with
- | -1,-1 | 0,-1 -> mk_add n2' n1'
- | 0,0 -> mk_mult n_two n1'
- | _ -> mk_add n1' n2')
- | N2n(n11,Some i),Nadd(n21,n22),_ ->
- normalize_n_rec true (mk_add n21 (mk_add n22 (mk_c i)))
- | Nadd(n11,n12), N2n(n21,Some i),_ ->
- normalize_n_rec true (mk_add n11 (mk_add n12 (mk_c i)))
- | N2n(n11,None),Nadd(n21,n22),_ ->
- (match n21.nexp with
- | N2n(n211,_) ->
- (match compare_nexps n11 n211 with
- | -1 -> mk_add n1' n2'
- | 0 -> mk_add (mk_2n (normalize_n_rec true (mk_add n11 n_one))) n22
- | _ -> mk_add n21 (normalize_n_rec true (mk_add n11 n22)))
- | _ -> mk_add n1' n2')
- | Nadd(n11,n12),N2n(n21,None),_ ->
- (match n11.nexp with
- | N2n(n111,_) ->
- (match compare_nexps n111 n21 with
- | -1 -> mk_add n11 (normalize_n_rec true (mk_add n2' n12))
- | 0 -> mk_add (mk_2n (normalize_n_rec true (mk_add n111 n_one))) n12
- | _ -> mk_add n2' n1')
- | _ -> mk_add n2' n1')
- | _ ->
- (match get_var n1', get_var n2' with
- | Some(nv1),Some(nv2) ->
- (match compare_nexps nv1 nv2 with
- | -1 -> mk_add n2' n1'
- | 0 -> increment_factor n1' (get_factor n2')
- | _ -> mk_add n1' n2')
- | Some(nv1),None -> mk_add n2' n1'
- | None,Some(nv2) -> mk_add n1' n2'
- | _ -> (match n1'.nexp,n2'.nexp with
- | Nadd(n11',n12'), _ ->
- (match compare_nexps n11' n2' with
- | -1 -> mk_add n2' n1'
- | 1 -> mk_add n11' (normalize_n_rec true (mk_add n12' n2'))
- | _ -> let _ = Printf.eprintf "Neither term has var but are the same? %s %s\n"
- (n_to_string n1') (n_to_string n2') in assert false)
- | (_, Nadd(n21',n22')) ->
- (match compare_nexps n1' n21' with
- | -1 -> mk_add n21' (normalize_n_rec true (mk_add n1' n22'))
- | 1 -> mk_add n1' n2'
- | _ -> let _ = Printf.eprintf "pattern didn't match unexpextedly here %s %s\n"
- (n_to_string n1') (n_to_string n2') in assert false)
- | _ ->
- (match compare_nexps n1' n2' with
- | -1 -> mk_add n2' n1'
- | 0 -> normalize_n_rec true (mk_mult n_two n1')
- | _ -> mk_add n1' n2'))))
- | Nsub(n1,n2) ->
- let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in
- (*let _ = Printf.eprintf "Normalizing subtraction of %s - %s \n" (n_to_string n1') (n_to_string n2') in*)
- (match n1'.nexp,n2'.nexp with
- | Nneg_inf, Npos_inf | Npos_inf, Nneg_inf -> mk_inexact()
- | Npos_inf, _ | _,Nneg_inf -> mk_p_inf()
- | Nneg_inf, _ | _,Npos_inf -> mk_n_inf()
- | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some i2) | N2n(_,Some i1), Nconst i2 | N2n(_,Some i1), N2n(_,Some i2)->
- (*let _ = Printf.eprintf "constant subtraction of %s - %s gives %s" (Big_int.string_of_big_int i1) (Big_int.string_of_big_int i2) (Big_int.string_of_big_int (sub_big_int i1 i2)) in*)
- mk_c (sub_big_int i1 i2)
- | Nconst i, _ ->
- if (eq_big_int i zero)
- then normalize_n_rec true (negate n2')
- else normalize_n_rec true (mk_add (negate n2') n1')
- | _, Nconst i ->
- if (eq_big_int i zero)
- then n1'
- else normalize_n_rec true (mk_add n1' (mk_c (mult_int_big_int (-1) i)))
- | _,_ ->
- (match compare_nexps n1 n2 with
- | 0 -> n_zero
- | -1 -> mk_add (negate n2') n1'
- | _ -> mk_add n1' (negate n2')))
- | Nmult(n1,n2) ->
- let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in
- (match n1'.nexp,n2'.nexp with
- | Nneg_inf,Nneg_inf -> mk_p_inf()
- | Npos_inf, Nconst i | Nconst i, Npos_inf ->
- if eq_big_int i zero then n_zero else mk_p_inf()
- | Nneg_inf, Nconst i | Nconst i, Nneg_inf ->
- if eq_big_int i zero then n_zero
- else if lt_big_int i zero then mk_p_inf()
- else mk_n_inf()
- | Nneg_inf, _ | _, Nneg_inf ->
- (match nexp_negative n1, nexp_negative n2 with
- | Yes, Yes -> mk_p_inf()
- | _ -> mk_n_inf())
- | Npos_inf, _ | _, Npos_inf ->
- (match nexp_negative n1, nexp_negative n2 with
- | Yes, Yes -> assert false (*One of them must be Npos_inf, so nexp_negative horribly broken*)
- | No, Yes | Yes, No -> mk_n_inf()
- | _ -> mk_p_inf())
- | Ninexact, _ | _, Ninexact -> mk_inexact()
- | Nconst i1, Nconst i2 -> mk_c (mult_big_int i1 i2)
- | Nconst i1, N2n(n,Some i2) | N2n(n,Some i2),Nconst i1 ->
- if eq_big_int i1 two
- then mk_2nc (normalize_n_rec true (mk_add n n_one)) (mult_big_int i1 i2)
- else mk_c (mult_big_int i1 i2)
- | Nconst i1, N2n(n,None) | N2n(n,None),Nconst i1 ->
- if eq_big_int i1 two
- then mk_2n (normalize_n_rec true (mk_add n n_one))
- else mk_mult (mk_c i1) (mk_2n n)
- | (Nmult (_, _), (Nvar _|Npow (_, _)|Nuvar _)) -> mk_mult n1' n2'
- | Nvar _, Nuvar _ -> mk_mult n2' n1'
- | N2n(n1,Some i1),N2n(n2,Some i2) -> mk_2nc (normalize_n_rec true (mk_add n1 n2)) (mult_big_int i1 i2)
- | N2n(n1,_), N2n(n2,_) -> mk_2n (normalize_n_rec true (mk_add n1 n2))
- | N2n _, Nvar _ | N2n _, Nuvar _ | N2n _, Nmult _ | Nuvar _, N2n _ -> mk_mult n2' n1'
- | Nuvar _, Nuvar _ | Nvar _, Nvar _ ->
- (match compare n1' n2' with
- | 0 -> mk_pow n1' 2
- | 1 -> mk_mult n1' n2'
- | _ -> mk_mult n2' n1')
- | Npow(n1,i1),Npow(n2,i2) ->
- (match compare_nexps n1 n2 with
- | 0 -> mk_pow n1 (i1+i2)
- | -1 -> mk_mult n2' n1'
- | _ -> mk_mult n1' n2')
- | Nconst _, Nadd(n21,n22) | Nvar _,Nadd(n21,n22) | Nuvar _,Nadd(n21,n22) | N2n _, Nadd(n21,n22)
- | Npow _,Nadd(n21,n22) | Nmult _, Nadd(n21,n22) ->
- normalize_n_rec true (mk_add (mk_mult n1' n21) (mk_mult n1' n21))
- | Nadd(n11,n12),Nconst _ | Nadd(n11,n12),Nvar _ | Nadd(n11,n12), Nuvar _ | Nadd(n11,n12), N2n _
- | Nadd(n11,n12),Npow _ | Nadd(n11,n12), Nmult _->
- normalize_n_rec true (mk_add (mk_mult n11 n2') (mk_mult n12 n2'))
- | Nmult(n11,n12), Nconst _ -> mk_mult (mk_mult n11 n2') (mk_mult n12 n2')
- | Nconst i1, _ ->
- if (eq_big_int i1 zero) then n1'
- else if (eq_big_int i1 one) then n2'
- else mk_mult n1' n2'
- | _, Nconst i1 ->
- if (eq_big_int i1 zero) then n2'
- else if (eq_big_int i1 one) then n1'
- else mk_mult n2' n1'
- | Nadd(n11,n12),Nadd(n21,n22) ->
- normalize_n_rec true (mk_add (mk_mult n11 n21)
- (mk_add (mk_mult n11 n22)
- (mk_add (mk_mult n12 n21) (mk_mult n12 n22))))
- | Nuvar _, Nvar _ | Nmult _, N2n _-> mk_mult n1' n2'
- | Nuvar _, Nmult(n1,n2) | Nvar _, Nmult(n1,n2) -> (*TODO What's happend to n1'*)
- (match get_var n1, get_var n2 with
- | Some(nv1),Some(nv2) ->
- (match compare_nexps nv1 nv2, n2.nexp with
- | 0, Nuvar _ | 0, Nvar _ -> mk_mult n1 (mk_pow nv1 2)
- | 0, Npow(n2',i) -> mk_mult n1 (mk_pow n2' (i+1))
- | -1, Nuvar _ | -1, Nvar _ -> mk_mult n2' n1'
- | _,_ -> mk_mult (normalize_n_rec true (mk_mult n1 n1')) n2)
- | _ -> mk_mult (normalize_n_rec true (mk_mult n1 n1')) n2)
- | (Npow (n1, i), (Nvar _ | Nuvar _)) ->
- (match compare_nexps n1 n2' with
- | 0 -> mk_pow n1 (i+1)
- | _ -> mk_mult n1' n2')
- | (Npow (_, _), N2n (_, _)) | (Nvar _, (N2n (_, _)|Npow (_, _))) | (Nuvar _, Npow (_, _)) -> mk_mult n2' n1'
- | (N2n (_, _), Npow (_, _)) -> mk_mult n1' n2'
- | Npow(n1,i),Nmult(n21,n22) ->
- (match get_var n1, get_var n2 with
- | Some(nv1),Some(nv2) ->
- (match compare_nexps nv1 nv2,n22.nexp with
- | 0, Nuvar _ | 0, Nvar _ -> mk_mult n21 (mk_pow n1 (i+1))
- | 0, Npow(_,i2) -> mk_mult n21 (mk_pow n1 (i+i2))
- | 1,Npow _ -> mk_mult (normalize_n_rec true (mk_mult n21 n1')) n22
- | _ -> mk_mult n2' n1')
- | _ -> mk_mult (normalize_n_rec true (mk_mult n1' n21)) n22)
- | Nmult _ ,Nmult(n21,n22) -> mk_mult (mk_mult n21 n1') (mk_mult n22 n1')
- | Nsub _, _ | _, Nsub _ ->
- let _ = Printf.eprintf "nsub case still around %s\n" (n_to_string n) in assert false
- | Nneg _,_ | _,Nneg _ ->
- let _ = Printf.eprintf "neg case still around %s\n" (n_to_string n) in assert false
- | Nid _, _ | _, Nid _ ->
- let _ = Printf.eprintf "nid case still around %s\n" (n_to_string n) in assert false
- (* If things are normal, neg should be gone. *)
- )
-
-let normalize_nexp = normalize_n_rec true
-
-let rec normalize_t t = match t.t with
- | Tfn (t1,t2,i,eff) -> {t = Tfn (normalize_t t1,normalize_t t2,i,eff)}
- | Ttup ts -> {t = Ttup (List.map normalize_t ts)}
- | Tapp (c,args) -> {t = Tapp (c, List.map normalize_t_arg args)}
- | Tabbrev (_,t') -> t'
- | _ -> t
-and normalize_t_arg targ = match targ with
- | TA_typ t -> TA_typ (normalize_t t)
- | TA_nexp nexp -> TA_nexp (normalize_nexp nexp)
- | _ -> targ
-
-let int_to_nexp = mk_c_int
-
-let is_bit t = match t.t with
- | Tid "bit"
- | Tabbrev(_,{t=Tid "bit"})
- | Tapp("register",[TA_typ {t=Tid "bit"}]) -> true
- | _ -> false
-
-let rec is_bit_vector t = match t.t with
- | Tapp("vector", [_;_;_; TA_typ t]) -> is_bit t
- | Tapp("register", [TA_typ t']) -> is_bit_vector t'
- | Tabbrev(_,t') -> is_bit_vector t'
- | _ -> false
-
-let rec has_const_vector_length t = match t.t with
- | Tapp("vector", [_;TA_nexp m;_;_]) ->
- (match (normalize_nexp m).nexp with
- | Nconst i -> Some i
- | _ -> None)
- | Tapp("register", [TA_typ t']) -> has_const_vector_length t'
- | Tabbrev(_,t') -> has_const_vector_length t'
- | _ -> None
-
-let v_count = ref 0
-let t_count = ref 0
-let tuvars = ref []
-let n_count = ref 0
-let nuvars = ref []
-let o_count = ref 0
-let ouvars = ref []
-let e_count = ref 0
-let euvars = ref []
-
-let reset_fresh _ =
- begin v_count := 0;
- t_count := 0;
- tuvars := [];
- n_count := 0;
- nuvars := [];
- o_count := 0;
- ouvars := [];
- e_count := 0;
- euvars := [];
- end
-let new_id _ =
- let i = !v_count in
- v_count := i+1;
- (string_of_int i) ^ "v"
-let new_t _ =
- let i = !t_count in
- t_count := i + 1;
- let t = {t = Tuvar { index = i; subst = None ; torig_name = None}} in
- tuvars := t::!tuvars;
- t
-let new_tv rv =
- let i = !t_count in
- t_count := i + 1;
- let t = {t = Tuvar { index = i; subst = None ; torig_name = Some rv}} in
- tuvars := t::!tuvars;
- t
-let new_n _ =
- let i = !n_count in
- n_count := i + 1;
- let n = { nexp = Nuvar { nindex = i; insubst = None; outsubst = None;
- nin = false ; leave_var = false; orig_var = None; been_collapsed = false};
- imp_param = false} in
- nuvars := n::!nuvars;
- n
-let new_nv s =
- let i = !n_count in
- n_count := i + 1;
- let n = { nexp = Nuvar { nindex = i; insubst = None ; outsubst = None;
- nin = false ; leave_var = false ; orig_var = Some s; been_collapsed = false};
- imp_param = false} in
- nuvars := n::!nuvars;
- n
-let leave_nuvar n = match n.nexp with
- | Nuvar u -> u.leave_var <- true; n
- | _ -> n
-let set_imp_param n =
- match n.nexp with
- | Nconst _ | Ninexact | Npos_inf | Nneg_inf -> ()
- | _ -> n.imp_param <- true
-
-let new_o _ =
- let i = !o_count in
- o_count := i + 1;
- let o = { order = Ouvar { oindex = i; osubst = None }} in
- ouvars := o::!ouvars;
- o
-let new_e _ =
- let i = !e_count in
- e_count := i + 1;
- let e = { effect = Euvar { eindex = i; esubst = None }} in
- euvars := e::!euvars;
- e
-
-exception Occurs_exn of t_arg
-let rec resolve_tsubst (t : t) : t =
- (*let _ = Printf.eprintf "resolve_tsubst on %s\n" (t_to_string t) in*)
- match t.t with
- | Tuvar({ subst=Some(t') } as u) ->
- let t'' = resolve_tsubst t' in
- (match t''.t with
- | Tuvar(_) -> u.subst <- Some(t''); t''
- | x -> t.t <- x; t)
- | _ -> t
-let rec resolve_osubst (o : order) : order = match o.order with
- | Ouvar({ osubst=Some(o') } as u) ->
- let o'' = resolve_osubst o' in
- (match o''.order with
- | Ouvar(_) -> u.osubst <- Some(o''); o''
- | x -> o.order <- x; o)
- | _ -> o
-let rec resolve_esubst (e : effect) : effect = match e.effect with
- | Euvar({ esubst=Some(e') } as u) ->
- let e'' = resolve_esubst e' in
- (match e''.effect with
- | Euvar(_) -> u.esubst <- Some(e''); e''
- | x -> e.effect <- x; e)
- | _ -> e
-
-let rec occurs_check_t (t_box : t) (t : t) : unit =
- let t = resolve_tsubst t in
- if t_box == t then
- raise (Occurs_exn (TA_typ t))
- else
- match t.t with
- | Tfn(t1,t2,_,_) ->
- occurs_check_t t_box t1;
- occurs_check_t t_box t2
- | Ttup(ts) ->
- List.iter (occurs_check_t t_box) ts
- | Tapp(_,targs) -> List.iter (occurs_check_ta (TA_typ t_box)) targs
- | Tabbrev(t,ta) -> occurs_check_t t_box t; occurs_check_t t_box ta
- | Toptions(t1,None) -> occurs_check_t t_box t1
- | Toptions(t1,Some t2) -> occurs_check_t t_box t1; occurs_check_t t_box t2
- | _ -> ()
-and occurs_check_ta (ta_box : t_arg) (ta : t_arg) : unit =
- match ta_box,ta with
- | TA_typ tbox,TA_typ t -> occurs_check_t tbox t
- | TA_nexp nbox, TA_nexp n -> occurs_check_n nbox n
- | TA_ord obox, TA_ord o -> occurs_check_o obox o
- | TA_eft ebox, TA_eft e -> occurs_check_e ebox e
- | _,_ -> ()
-(*light-weight occurs check, does not look within nuvar chains*)
-and occurs_check_n (n_box : nexp) (n : nexp) : unit =
- if n_box.nexp == n.nexp then
- raise (Occurs_exn (TA_nexp n))
- else
- match n.nexp with
- | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> occurs_check_n n_box n1; occurs_check_n n_box n2
- | N2n(n,_) | Nneg n | Npow(n,_) -> occurs_check_n n_box n
- | _ -> ()
-and occurs_check_o (o_box : order) (o : order) : unit =
- let o = resolve_osubst o in
- if o_box == o then
- raise (Occurs_exn (TA_ord o))
- else ()
-and occurs_check_e (e_box : effect) (e : effect) : unit =
- let e = resolve_esubst e in
- if e_box == e then
- raise (Occurs_exn (TA_eft e))
- else ()
-
-(* Is checking for structural equality only, other forms of equality will be handeled by constraints *)
-let rec nexp_eq_check n1 n2 =
- match n1.nexp,n2.nexp with
- | Npos_inf,Npos_inf | Nneg_inf,Nneg_inf | Ninexact,Ninexact -> true
- | Nvar v1,Nvar v2 -> v1=v2
- | Nconst n1,Nconst n2 -> eq_big_int n1 n2
- | Nadd(nl1,nl2), Nadd(nr1,nr2) | Nmult(nl1,nl2), Nmult(nr1,nr2) | Nsub(nl1,nl2),Nsub(nr1,nr2)
- -> nexp_eq_check nl1 nr1 && nexp_eq_check nl2 nr2
- | N2n(n,Some i),N2n(n2,Some i2) -> eq_big_int i i2
- | N2n(n,_),N2n(n2,_) -> nexp_eq_check n n2
- | Nneg n,Nneg n2 -> nexp_eq_check n n2
- | Npow(n1,i1),Npow(n2,i2) -> i1=i2 && nexp_eq_check n1 n2
- | Nuvar _,Nuvar _ ->
- let n1_in,n2_in = get_inner_most n1, get_inner_most n2 in
- (match n1_in.nexp, n2_in.nexp with
- | Nuvar{insubst=None; nindex=i1},Nuvar{insubst=None; nindex=i2} -> i1 = i2
- | _ -> nexp_eq_check n1_in n2_in)
- | _,_ -> false
-
-let nexp_eq n1 n2 =
-(* let _ = Printf.eprintf "comparing nexps %s and %s\n" (n_to_string n1) (n_to_string n2) in*)
- let b = nexp_eq_check (normalize_nexp n1) (normalize_nexp n2) in
-(* let _ = Printf.eprintf "compared nexps %s\n" (string_of_bool b) in*)
- b
-
-
-(*determine if ne is divisble without remainder by n,
- for now considering easily checked divisibility:
- i.e. if ne is 2^n, where we otherwhere assume n>0 we just check for 2,
- not for numbers 2^m where n >= m
-*)
-let divisible_by ne n =
- let num,var,uvar,immediate_answer = match n.nexp with
- | Nconst i | N2n(_,Some i)->
- if eq_big_int i unit_big_int || eq_big_int i (minus_big_int unit_big_int)
- then None,None,None,Some true
- else Some i,None,None,None
- | Nvar v -> None, Some(v), None, None
- | Nuvar _ -> None, None, Some(get_index n), None
- | _ -> None, None, None, Some(false)
- in
- match immediate_answer with
- | Some answer -> answer
- | None ->
- let rec walk_nexp n = match n.nexp with
- | Npos_inf | Nneg_inf -> true
- | Ninexact -> false
- | Nvar v ->
- (match var with
- | Some v' -> v = v'
- | _ -> false)
- | Nuvar _ ->
- (match uvar with
- | Some n' -> (get_index n) = n'
- | _ -> false)
- | Nconst i | N2n(_,Some i) ->
- (match num with
- | Some i' -> eq_big_int (mod_big_int i i') zero_big_int
- | _ -> false)
- | N2n(n,_) ->
- (match num with
- | Some i -> eq_big_int i (big_int_of_int 2)
- | _ -> false)
- | Npow(n,_) | Nneg n | Nid(_,n) -> walk_nexp n
- | Nmult(n1,n2) -> walk_nexp n1 || walk_nexp n2
- | Nadd(n1,n2) | Nsub(n1,n2) -> walk_nexp n1 && walk_nexp n2
- in walk_nexp ne
-
-(*divide ne by n, only gives correct answer when divisible_by is true*)
-let divide_by ne n =
- let num,var,uvar,immediate_answer = match n.nexp with
- | Nconst i | N2n(_,Some i)->
- if eq_big_int i unit_big_int
- then None,None,None,Some n
- else if eq_big_int i (minus_big_int unit_big_int)
- then None,None,None,Some (mk_neg n)
- else Some i,None,None,None
- | Nvar v -> None, Some(v), None, None
- | Nuvar _ -> None, None, Some(get_index n), None
- | _ -> None, None, None, Some n
- in
- match immediate_answer with
- | Some answer -> answer
- | None ->
- let rec walk_nexp n = match n.nexp with
- | Nid(_,n) -> walk_nexp n
- | Npos_inf ->
- (match num with
- | Some(i) -> if lt_big_int i zero_big_int then mk_n_inf() else n
- | _ -> n)
- | Nneg_inf ->
- (match num with
- | Some(i) -> if lt_big_int i zero_big_int then mk_p_inf() else n
- | _ -> n)
- | Ninexact -> n
- | Nvar v ->
- (match var with
- | Some v' -> if v = v' then n_one else n
- | _ -> n)
- | Nuvar _ ->
- (match uvar with
- | Some n' -> if (get_index n) = n' then n_one else n
- | _ -> n)
- | Nconst i | N2n(_,Some i) ->
- (match num with
- | Some i' -> mk_c (div_big_int i i')
- | _ -> n)
- | N2n(n1,_) ->
- (match num with
- | Some i -> if eq_big_int i (big_int_of_int 2) then mk_2n (mk_sub n1 n_one) else n
- | _ -> n)
- | Npow(nv,i) ->
- (match nv.nexp,var,uvar with
- | Nvar v, Some v', None -> if v = v' then mk_pow nv (i-1) else n
- | Nuvar _,None, Some i -> if (get_index nv) = i then mk_pow nv (i-1) else n
- | _ -> n)
- | Nneg n -> mk_neg (walk_nexp n)
- | Nmult(n1,n2) -> mk_mult (walk_nexp n1) (walk_nexp n2)
- | Nadd(n1,n2) -> mk_add (walk_nexp n1) (walk_nexp n2)
- | Nsub(n1,n2) -> mk_sub (walk_nexp n1) (walk_nexp n2)
- in walk_nexp ne
-
-(*Remove nv (assumed to be either a nuvar or an nvar) from ne as much as possible.
- Due to requiring integral values only, as well as variables multiplied by others,
- there might be some non-removable factors
- Returns the variable with any non-removable factors, and the rest of the expression
-*)
-let isolate_nexp nv ne =
- let normal_ne = normalize_nexp ne in
- let var,uvar = match nv.nexp with
- | Nvar v -> Some v, None
- | Nuvar _ -> None, Some (get_index nv)
- | _ -> None, None in
- (* returns isolated_nexp,
- option nv plus any factors,
- option factors other than 1,
- bool whether factors need to be divided from other terms*)
- let rec remove_from ne = match ne.nexp with
- | Nid(_,n) -> remove_from n
- | Npos_inf | Nneg_inf | Ninexact | Nconst _ | N2n(_,Some _)-> ne,None,None,false
- | Nvar v ->
- (match var with
- | Some v' -> if v = v' then (n_zero,Some ne,None,false) else (ne,None,None,false)
- | _ -> (ne,None,None,false))
- | Nuvar _ ->
- (match uvar with
- | Some n' -> if (get_index ne) = n' then n_zero,Some ne,None,false else ne,None,None,false
- | _ -> ne,None,None,false)
- | N2n(n1,_) | Npow(n1,_)->
- (match remove_from n1 with
- | (_, None,_,_) -> ne,None,None,false
- | (_,Some _,_,_) -> (n_zero,Some ne,Some ne,false))
- | Nneg n -> assert false (*Normal forms shouldn't have nneg*)
- | Nmult(n1,n2) ->
- (match (remove_from n1, remove_from n2) with
- | (_, None,_,_),(_,None,_,_) -> (ne,None,None,false)
- | (_, None,_,_),(nv,Some n,None,false) ->
- if nexp_eq n1 n_one
- then (nv,Some n, None, false)
- else (n_zero, Some n, Some n1, true)
- | (_, None,_,_),(nv, Some n, Some nf, true) ->
- (nv, Some(mk_mult n1 n2), Some (mk_mult n1 nf), true)
- | (_, None,_,_), (nv, Some n, Some nf, false) ->
- (nv, Some (mk_mult n1 n2), Some (mk_mult n1 n2), false)
- | _ -> (n_zero, Some ne, Some ne, false))
- | Nadd(n1,n2) ->
- (match (remove_from n1, remove_from n2) with
- | (_,None,_,_),(_,None,_,_) -> ne,None,None,false
- | (new_n1,Some nv,factor,try_factor),(_,None,_,_) -> (mk_add new_n1 n2, Some nv,factor,try_factor)
- | (_, None,_,_),(new_n2,Some nv,factor,try_factor) -> (mk_add n1 new_n2, Some nv,factor, try_factor)
- | (nn1, Some nv1,Some f1,true), (nn2, Some nv2,Some f2,true) ->
- if nexp_eq nv1 nv2
- then (mk_add nn1 nn2, Some nv1, Some (mk_add f1 f2), true)
- else (mk_add nn1 nn2, Some (mk_add nv1 nv2), Some (mk_add f1 f2), false)
- | (nn1, _,_,_),(nn2,_,_,_) ->
- (mk_add nn1 nn2, Some ne, Some ne, false) (*It's all gone horribly wrong, punt*))
- | Nsub(n1,n2) -> assert false in (*Normal forms shouldn't have nsub*)
- let (new_ne,new_nv,new_factor,attempt_factor) = remove_from normal_ne in
- let new_ne = normalize_nexp new_ne in
- match new_nv with
- | None -> None,None, new_ne
- | Some n_nv ->
- (match n_nv.nexp,new_factor,attempt_factor with
- | Nvar _, None, _ | Nuvar _, None, _ -> (Some n_nv,None,new_ne)
- | Nvar _, Some f, true | Nuvar _, Some f, true ->
- if divisible_by new_ne f
- then (Some n_nv, Some f, normalize_nexp (divide_by new_ne f))
- else (Some (mk_mult f n_nv), None, new_ne)
- | Nconst _,_,_ | Ninexact,_,_ | Npos_inf,_,_ | Nneg_inf,_,_ | Nid _,_,_ -> assert false (*double oh my*)
- | N2n _,_,_ | Npow _,_,_ | Nadd _,_,_ | Nneg _,_,_ | Nsub _,_,_ | Nvar _,_,false | Nuvar _,_,false
- -> (Some n_nv,None, new_ne)
- | Nmult(n1,n2),_,_ ->
- if nexp_eq n1 n_nv
- then if divisible_by new_ne n2
- then (Some n1, Some n2, normalize_nexp (divide_by new_ne n2))
- else (Some n_nv, None, new_ne)
- else if nexp_eq n2 n_nv
- then if divisible_by new_ne n1
- then (Some n2, Some n1, normalize_nexp (divide_by new_ne n1))
- else (Some n_nv, None, new_ne)
- else assert false (*really bad*))
-
-let nexp_one_more_than n1 n2 =
- let n1,n2 = (normalize_nexp (normalize_nexp n1)), (normalize_nexp (normalize_nexp n2)) in
- match n1.nexp,n2.nexp with
- | Nconst i, Nconst j -> (int_of_big_int i) = (int_of_big_int j)+1
- | _, Nsub(n2',{nexp = Nconst i}) ->
- if (int_of_big_int i) = 1 then nexp_eq n1 n2' else false
- | _, Nadd(n2',{nexp = Nconst i}) ->
- if (int_of_big_int i) = -1 then nexp_eq n1 n2' else false
- | Nadd(n1',{nexp = Nconst i}),_ ->
- if (int_of_big_int i) = 1 then nexp_eq n1' n2 else false
- | _ -> false
-
-
-let rec nexp_gt_compare eq_ok n1 n2 =
- let n1,n2 = (normalize_nexp (get_inner_most n1), normalize_nexp (get_inner_most n2)) in
- let ge_test = if eq_ok then ge_big_int else gt_big_int in
- let is_eq = nexp_eq n1 n2 in
- if eq_ok && is_eq
- then Yes
- else if (not eq_ok) && is_eq then No
- else
- match n1.nexp,n2.nexp with
- | Nconst i, Nconst j | N2n(_,Some i), N2n(_,Some j)-> if ge_test i j then Yes else No
- | Npos_inf, _ | _, Nneg_inf -> Yes
- | Nuvar _, Npos_inf | Nneg_inf, Nuvar _ -> if eq_ok then Maybe else No
- | Nneg_inf, _ | _, Npos_inf -> No
- | Ninexact, _ | _, Ninexact -> Maybe
- | N2n(n1,_), N2n(n2,_) -> nexp_gt_compare eq_ok n1 n2
- | Nmult(n11,n12), Nmult(n21,n22) ->
- if nexp_eq n12 n22
- then nexp_gt_compare eq_ok n11 n21
- else Maybe
- | Nmult(n11,n12), _ ->
- if nexp_eq n12 n2
- then triple_negate (nexp_negative n11)
- else Maybe
- | _, Nmult(n21,n22) ->
- if nexp_eq n1 n22
- then nexp_negative n21
- else Maybe
- | Nadd(n11,n12),Nadd(n21,n22) ->
- (match (nexp_gt_compare eq_ok n11 n21, nexp_gt_compare eq_ok n12 n22,
- (nexp_negative n11, nexp_negative n12, nexp_negative n21, nexp_negative n22)) with
- | Yes, Yes, (No, No, No, No) -> Yes
- | No, No, (No, No, No, No) -> No
- | _ -> Maybe)
- | Nadd(n11,n12), _ ->
- if nexp_eq n11 n2
- then triple_negate (nexp_negative n12)
- else if nexp_eq n12 n2
- then triple_negate (nexp_negative n11)
- else Maybe
- | _ , Nadd(n21,n22) ->
- if nexp_eq n1 n21
- then nexp_negative n22
- else if nexp_eq n1 n22
- then nexp_negative n21
- else Maybe
- | Npow(n11,i1), Npow(n21, i2) ->
- if nexp_eq n11 n21
- then if i1 >= i2 then Yes else No
- else Maybe
- | Npow(n11,i1), _ ->
- if nexp_eq n11 n2
- then if i1 = 0 then No else Yes
- else Maybe
- | _, Npow(n21,i2) ->
- if nexp_eq n1 n21
- then if i2 = 0 then Yes else No
- else Maybe
- | _ -> Maybe
-
-let nexp_ge = nexp_gt_compare true
-let nexp_gt = nexp_gt_compare false
-let nexp_le n1 n2 = nexp_gt_compare true n2 n1
-let nexp_lt n1 n2 = nexp_gt_compare false n2 n1
-
-let equate_t (t_box : t) (t : t) : unit =
- let t = resolve_tsubst t in
- if t_box == t then ()
- else
- (occurs_check_t t_box t;
- match t.t with
- | Tuvar(_) ->
- (match t_box.t with
- | Tuvar(u) ->
- u.subst <- Some(t)
- | _ -> assert false)
- | _ ->
- t_box.t <- t.t)
-
-(*Assumes that both are nuvar, and both set initially on outermost of chain *)
-let rec occurs_in_nuvar_chain n_box n : bool =
- n_box.nexp == n.nexp || (*if both are at outermost and they are the same, then n occurs in n_box *)
- let n_box' = get_inner_most n_box in
- match n_box'.nexp with
- | Nuvar( { insubst= None }) -> false
- | Nuvar( { insubst= Some(n_box') }) -> occurs_in_nexp n_box' n
- | _ -> occurs_in_nexp n_box' n
-
-(*Heavy-weight occurs check, including nuvar chains. Assumes second argument always a nuvar*)
-and occurs_in_nexp n_box nuvar : bool =
-(* let _ = Printf.eprintf "occurs_in_nexp given n_box %s nuvar %s eq? %b\n"
- (n_to_string n_box) (n_to_string nuvar) (n_box.nexp == nuvar.nexp) in*)
- if n_box.nexp == nuvar.nexp then true
- else match n_box.nexp with
- | Nuvar _ -> occurs_in_nuvar_chain (get_outer_most n_box) (get_outer_most nuvar)
- | Nadd (nb1,nb2) | Nsub(nb1,nb2)| Nmult (nb1,nb2) -> occurs_in_nexp nb1 nuvar || occurs_in_nexp nb2 nuvar
- | Nneg nb | N2n(nb,None) | Npow(nb,_) -> occurs_in_nexp nb nuvar
- | _ -> false
-
-(*Assumes that n is set to it's outermost n*)
-let collapse_nuvar_chain n =
- let rec collapse n =
- match n.nexp with
- | Nuvar { insubst = None } -> (n,[n])
- | Nuvar ({insubst = Some ni } as u) ->
- (*let _ = Printf.eprintf "Collapsing %s, about to collapse it's insubst\n" (n_to_string n) in*)
- let _,internals = collapse ni in
- (*let _ = Printf.eprintf "Collapsed %s, with inner %s\n" (n_to_string n) (n_to_string ni) in*)
- (match ni.nexp with
- | Nuvar nim ->
- u.leave_var <- u.leave_var || nim.leave_var;
- u.nin <- u.nin || nim.nin;
- u.orig_var <- (match u.orig_var,nim.orig_var with
- | None, None -> None
- | Some i, Some j -> if i = j then Some i else None
- | Some i,_ | _, Some i -> Some i);
- u.insubst <- None;
- u.outsubst <- None;
- u.been_collapsed <- true;
- (*Shouldn't need this but Somewhere somethings going wonky*)
- (*nim.nindex <- u.nindex; *)
- (n,n::internals)
- | _ -> if u.leave_var then u.insubst <- Some ni else n.nexp <- ni.nexp; (n,[n]))
- | _ -> (n,[n])
- in
- let rec set_nexp n_from n_to_s = match n_to_s with
- | [] -> n_from
- | n_to::n_to_s -> n_to.nexp <- n_from.nexp; set_nexp n_from n_to_s in
- let (n,all) = collapse n in
- set_nexp n (List.tl all)
-
-(*assumes called on outermost*)
-let rec leave_nu_as_var n =
- match n.nexp with
- | Nuvar nu ->
- (match nu.insubst with
- | None -> nu.leave_var
- | Some(nexp) -> nu.leave_var || leave_nu_as_var nexp)
- | _ -> false
-
-let equate_n (n_box : nexp) (n : nexp) : bool =
- (*let _ = Printf.eprintf "equate_n given n_box %s and n %s\n" (n_to_string n_box) (n_to_string n) in*)
- let n_box = get_outer_most n_box in
- let n = get_outer_most n in
- if n_box.nexp == n.nexp then true
- else
- let occur_nbox_n = occurs_in_nexp n_box n in
- let occur_n_nbox = occurs_in_nexp n n_box in
- match (occur_nbox_n,occur_n_nbox) with
- | true,true -> false
- | true,false | false,true -> true
- | false,false ->
- (*let _ = Printf.eprintf "equate_n has does not occur in %s and %s\n" (n_to_string n_box) (n_to_string n) in*)
- (*If one is empty, set the empty one into the bottom of the other one if you can, but put it in the chain
- If neither are empty, merge but make sure to set the nexp to be the same (not yet being done)
- *)
- match n_box.nexp,n.nexp with
- | Nuvar _, Nuvar _ | Nuvar _, _ | _, Nuvar _ -> add_to_nuvar_tail n_box n
- | _ -> false
-let equate_o (o_box : order) (o : order) : unit =
- let o = resolve_osubst o in
- if o_box == o then ()
- else
- (occurs_check_o o_box o;
- match o.order with
- | Ouvar(_) ->
- (match o_box.order with
- | Ouvar(u) ->
- u.osubst <- Some(o)
- | _ -> o.order <- o_box.order)
- | _ ->
- o_box.order <- o.order)
-let equate_e (e_box : effect) (e : effect) : unit =
- let e = resolve_esubst e in
- if e_box == e then ()
- else
- (occurs_check_e e_box e;
- match e.effect with
- | Euvar(_) ->
- (match e_box.effect with
- | Euvar(u) ->
- u.esubst <- Some(e)
- | _ -> assert false)
- | _ ->
- e_box.effect <- e.effect)
-
-let fresh_var just_use_base varbase i mkr bindings =
- let v = if just_use_base then varbase else "'" ^ varbase ^ (string_of_int i) in
- match Envmap.apply bindings v with
- | Some _ -> mkr v false
- | None -> mkr v true
-
-let rec fresh_tvar bindings t =
- match t.t with
- | Tuvar { index = i;subst = None } ->
- fresh_var false "tv" i (fun v add -> equate_t t {t=Tvar v}; if add then Some (v,{k=K_Typ}) else None) bindings
- | Tuvar { index = i; subst = Some ({t = Tuvar _} as t') } ->
- let kv = fresh_tvar bindings t' in
- equate_t t t';
- kv
- | Tuvar { index = i; subst = Some t' } ->
- t.t <- t'.t;
- None
- | _ -> None
-let rec fresh_nvar bindings n =
- (*let _ = Printf.eprintf "fresh_nvar for %s\n" (n_to_string n) in*)
- match n.nexp with
- | Nuvar { nindex = i;insubst = None ; orig_var = None } ->
- fresh_var false "nv" i (fun v add -> n.nexp <- (Nvar v);
- (*(Printf.eprintf "fresh nvar set %i to %s : %s\n" i v (n_to_string n));*)
- if add then Some(v,{k=K_Nat}) else None) bindings
- | Nuvar { nindex = i;insubst = None ; orig_var = Some v } ->
- fresh_var true v 0 (fun v add -> n.nexp <- (Nvar v);
- (*(Printf.eprintf "fresh nvar set %i to %s : %s\n" i v (n_to_string n));*)
- if add then Some(v,{k=K_Nat}) else None) bindings
- | Nuvar { nindex = i; insubst = Some n' } ->
- n.nexp <- n'.nexp;
- None
- | _ -> None
-let rec fresh_ovar bindings o =
- match o.order with
- | Ouvar { oindex = i;osubst = None } ->
- fresh_var false "ov" i (fun v add -> equate_o o {order = (Ovar v)};
- if add then Some(v,{k=K_Nat}) else None) bindings
- | Ouvar { oindex = i; osubst = Some({order=Ouvar _} as o')} ->
- let kv = fresh_ovar bindings o' in
- equate_o o o';
- kv
- | Ouvar { oindex = i; osubst = Some o' } ->
- o.order <- o'.order;
- None
- | _ -> None
-let rec fresh_evar bindings e =
- match e.effect with
- | Euvar { eindex = i;esubst = None } ->
- fresh_var false "ev" i (fun v add -> equate_e e {effect = (Evar v)};
- if add then Some(v,{k=K_Nat}) else None) bindings
- | Euvar { eindex = i; esubst = Some({effect=Euvar _} as e')} ->
- let kv = fresh_evar bindings e' in
- equate_e e e';
- kv
- | Euvar { eindex = i; esubst = Some e' } ->
- e.effect <- e'.effect;
- None
- | _ -> None
-
-let contains_nuvar_nexp n ne =
- let compare_to i = match n.nexp with
- | Nuvar {nindex = i2} -> i = i2
- | _ -> false in
- let rec search ne =
- match ne.nexp with
- | Nuvar {nindex =i}-> compare_to i
- | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> search n1 || search n2
- | N2n(n,_) | Nneg n | Npow(n,_) -> search n
- | _ -> false in
- search ne
-
-let contains_nvar_nexp n ne =
- let compare_to v = match n.nexp with
- | Nvar v' -> v = v'
- | _ -> false in
- let rec search ne =
- match ne.nexp with
- | Nvar v-> compare_to v
- | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> search n1 || search n2
- | N2n(n,_) | Nneg n | Npow(n,_) -> search n
- | _ -> false in
- search ne
-
-let rec contains_n nexp_contains n cs =
- let contains = contains_n nexp_contains in
- match cs with
- | [] -> []
- | ((LtEq(_,_,nl,nr) | Lt(_,_,nl,nr) | GtEq(_,_,nl,nr) | Gt(_,_,nl,nr) | Eq(_,nl,nr) | NtEq(_,nl,nr)) as co)::cs ->
- if (nexp_contains n nl || nexp_contains n nr)
- then co::(contains n cs)
- else contains n cs
- | CondCons(so,kind,_,conds,exps)::cs ->
- let conds' = contains n conds in
- let exps' = contains n exps in
- (match conds',exps' with
- | [],[] -> contains n cs
- | _ -> CondCons(so,kind,None,conds',exps')::contains n cs)
- | BranchCons(so,_,b_cs)::cs ->
- (match contains n b_cs with
- | [] -> contains n cs
- | b -> BranchCons(so,None,b)::contains n cs)
- | (Predicate(so,cp,cn) as co)::cs ->
- (match contains n [cp;cn] with
- | [] -> contains n cs
- | _ -> co::contains n cs)
- | _::cs -> contains n cs
-
-let contains_nuvar = contains_n contains_nuvar_nexp
-let contains_nvar = contains_n contains_nvar_nexp
-
-let rec refine_guarantees check_nvar max_lt min_gt id cs =
- match cs with
- | [] ->
- (match max_lt,min_gt with
- | None,None -> []
- | Some(c,i),None -> [LtEq(c,Guarantee,id,i)]
- | None,Some(c,i) -> [GtEq(c,Guarantee,id,i)]
- | Some(cl,il),Some(cg,ig) -> [LtEq(cl,Guarantee,id,il);GtEq(cg,Guarantee,id,ig)]), max_lt, min_gt
- | (LtEq(c,Guarantee,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in
- curr::cs,max,min in
- (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*)
- (match nes.nexp,neb.nexp,check_nvar,max_lt,min_gt with
- | Nuvar _ , _, false, None, _ | Nvar _, _, true, None, _ ->
- (*let _ = Printf.eprintf "in var nill case of <=\n" in *)
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*new max*)
- else no_match ()
- | _ , Nuvar _, false, _, None | _,Nvar _, true, _, None ->
- (*let _ = Printf.eprintf "in var nill case of <=\n" in *)
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*new min*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true,Some(cm, omax), _ ->
- (*let _ = Printf.eprintf "in var case of <=\n" in *)
- if nexp_eq id nes
- then match nexp_ge neb omax with
- | Yes -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*replace old max*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint *)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true,_, Some(cm, omin) ->
- (*let _ = Printf.eprintf "in var case of <=\n" in *)
- if nexp_eq id neb
- then match nexp_le nes omin with
- | Yes -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*replace old min*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint *)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match ())
- | (Lt(c,Guarantee,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in
- curr::cs,max,min in
- (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*)
- (match nes.nexp,neb.nexp,check_nvar,max_lt,min_gt with
- | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _->
- (*let _ = Printf.eprintf "in var, nil case of <\n" in *)
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*new max*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None->
- (*let _ = Printf.eprintf "in var, nil case of <\n" in *)
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*new max*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ ->
- (*let _ = Printf.eprintf "in var case of <\n" in *)
- if nexp_eq id nes
- then match nexp_gt neb omax with
- | Yes -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*replace old max*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) ->
- (*let _ = Printf.eprintf "in var case of <\n" in *)
- if nexp_eq id neb
- then match nexp_lt nes omin with
- | Yes -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*replace old min*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match ())
- | (GtEq(c,Guarantee,nes,neb) as curr)::cs ->
- (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*)
- let no_match _ =
- let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in
- curr::cs,max,min in
- (match nes.nexp,neb.nexp,check_nvar,min_gt,max_lt with
- | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _->
- (*let _ = Printf.eprintf "in var, nil case of >=\n" in *)
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*new min*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None->
- (*let _ = Printf.eprintf "in var, nil case of >=\n" in *)
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*new max*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ ->
- (*let _ = Printf.eprintf "in var case of >=\n" in *)
- if nexp_eq id nes
- then match nexp_le neb omin with
- | Yes -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*replace old min*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) ->
- (*let _ = Printf.eprintf "in var case of >=\n" in *)
- if nexp_eq id neb
- then match nexp_ge nes omax with
- | Yes -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*replace old max*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match ())
- | (Gt(c,Guarantee,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in
- curr::cs,max,min in
- (* let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*)
- (match nes.nexp,neb.nexp,check_nvar,min_gt,max_lt with
- | Nuvar _,_, false, None,_ | Nvar _, _, true, None,_->
- (*let _ = Printf.eprintf "in var, nil case of >\n" in *)
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*new min*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None ->
- (*let _ = Printf.eprintf "in var, nil case of >\n" in *)
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*new max*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ ->
- (*let _ = Printf.eprintf "in var case of >\n" in *)
- if nexp_eq id nes
- then match nexp_lt neb omin with
- | Yes -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*replace old min*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) ->
- (*let _ = Printf.eprintf "in var case of >\n" in *)
- if nexp_eq id neb
- then match nexp_gt nes omax with
- | Yes -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*replace old min*)
- | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match ())
- | c::cs ->
- (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [c]) in*)
- let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in
- c::cs,max,min
-
-let rec refine_requires check_nvar min_lt max_gt id cs =
- match cs with
- | [] ->
- (match min_lt,max_gt with
- | None,None -> []
- | Some(c,i),None -> [LtEq(c,Require,id,i)]
- | None,Some(c,i) -> [GtEq(c,Require,id,i)]
- | Some(cl,il),Some(cg,ig) -> [LtEq(cl,Require,id,il);GtEq(cg,Require,id,ig)]), min_lt,max_gt
- | (LtEq(c,Require,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in
- curr::cs,max,min in
- (match nes.nexp,neb.nexp,check_nvar,min_lt,max_gt with
- | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _ ->
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*new min*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None ->
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ ->
- if nexp_eq id nes
- then match nexp_le neb omin with
- | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match()
- | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) ->
- if nexp_eq id neb
- then match nexp_ge nes omax with
- | Yes -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*replace old max*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match()
- | _ -> no_match())
- | (Lt(c,Require,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in
- curr::cs,max,min in
- (match nes.nexp,neb.nexp,check_nvar,min_lt,max_gt with
- | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _->
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar(Some(c,neb)) max_gt id cs (*new min*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None->
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*new max*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ ->
- if nexp_eq id nes
- then match nexp_lt neb omin with
- | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _,true, _, Some(cm, omax) ->
- if nexp_eq id neb
- then match nexp_gt nes omax with
- | Yes -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*replace old max*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match())
- | (GtEq(c,Require,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in
- curr::cs,max,min in
- (match nes.nexp,neb.nexp,check_nvar,max_gt,min_lt with
- | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _ ->
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*)
- else no_match ()
- | _, Nuvar _, false, _, None | _, Nvar _, true, _, None ->
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*new min*)
- else no_match ()
- | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ ->
- if nexp_eq id nes
- then match nexp_ge neb omax with
- | Yes -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*replace old max*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) ->
- if nexp_eq id neb
- then match nexp_le nes omin with
- | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match ())
- | (Gt(c,Require,nes,neb) as curr)::cs ->
- let no_match _ =
- let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in
- curr::cs,max,min in
- (match nes.nexp,neb.nexp,check_nvar,max_gt,min_lt with
- | Nuvar _, _, true, None, _ | Nvar _, _, false, None, _ ->
- if nexp_eq id nes
- then match neb.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*)
- else refine_requires check_nvar min_lt max_gt id cs
- | _, Nuvar _, true, _, None | _, Nvar _, false, _, None->
- if nexp_eq id neb
- then match nes.nexp with
- | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*)
- | _ -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*new min*)
- else refine_requires check_nvar min_lt max_gt id cs
- | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ ->
- if nexp_eq id nes
- then match nexp_gt neb omax with
- | Yes -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*replace old max*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (* remove redundant constraint *)
- | Maybe -> no_match ()
- else no_match ()
- | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) ->
- if nexp_eq id neb
- then match nexp_lt nes omin with
- | Yes -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*replace old min*)
- | No -> refine_requires check_nvar min_lt max_gt id cs (* remove redundant constraint *)
- | Maybe -> no_match ()
- else no_match ()
- | _ -> no_match())
- | c::cs ->
- let (cs,min,max) = refine_requires check_nvar min_lt max_gt id cs in
- c::cs,min_lt,max_gt
-
-let nat_t = {t = Tapp("range",[TA_nexp n_zero;TA_nexp (mk_p_inf());])}
-let int_t = {t = Tapp("range",[TA_nexp (mk_n_inf());TA_nexp (mk_p_inf());])}
-let uint8_t = {t = Tapp("range",[TA_nexp n_zero; TA_nexp (mk_sub (mk_2nc (mk_c_int 8) (big_int_of_int 256)) n_one)])}
-let uint16_t = {t = Tapp("range",[TA_nexp n_zero;
- TA_nexp (mk_sub (mk_2nc (mk_c_int 16) (big_int_of_int 65536)) n_one)])}
-let uint32_t = {t = Tapp("range",[TA_nexp n_zero;
- TA_nexp (mk_sub (mk_2nc (mk_c_int 32) (big_int_of_string "4294967296")) n_one)])}
-let uint64_t = {t = Tapp("range",[TA_nexp n_zero;
- TA_nexp (mk_sub (mk_2nc (mk_c_int 64) (big_int_of_string "18446744073709551616"))
- (mk_c_int 1))
- ])}
-
-let int8_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 7) (big_int_of_int 128))) ;
- TA_nexp (mk_c_int 127)])}
-let int16_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 15) (big_int_of_int 32768)));
- TA_nexp (mk_c_int 32767)])}
-let int32_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 31) (big_int_of_int 2147483648))) ;
- TA_nexp (mk_c_int 2147483647)])}
-let int64_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 63) (big_int_of_string "9223372036854775808")));
- TA_nexp (mk_c (big_int_of_string "9223372036854775807"))])}
-
-let unit_t = { t = Tid "unit" }
-let bit_t = {t = Tid "bit" }
-let bool_t = {t = Tid "bool" }
-let nat_typ = {t=Tid "nat"}
-let string_t = {t = Tid "string"}
-let pure_e = {effect=Eset []}
-let nob = No_bounds
-
-let rec get_cummulative_effects = function
- | NoTyp -> pure_e
- | Base(_,_,_,_,efr,_) -> efr
- | _ -> pure_e
-
-let get_eannot (E_aux(_,(l,annot))) = annot
-
-let initial_kind_env =
- Envmap.from_list [
- ("bool", {k = K_Typ});
- ("nat", {k = K_Typ});
- ("int", {k = K_Typ});
- ("uint8", {k = K_Typ});
- ("uint16", {k= K_Typ});
- ("uint32", {k=K_Typ});
- ("uint64", {k=K_Typ});
- ("unit", {k = K_Typ});
- ("bit", {k = K_Typ});
- ("string", {k = K_Typ});
- ("real", {k = K_Typ});
- ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})});
- ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})});
- ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})});
- ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) });
- ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } );
- ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})});
- ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) });
- ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} );
- ]
-
-let simple_annot t = Base(([],t),Emp_local,[],pure_e,pure_e,nob)
-let simple_annot_efr t efr = Base(([],t),Emp_local,[],pure_e,efr,nob)
-let global_annot t = Base(([],t),Emp_global,[],pure_e,pure_e,nob)
-let tag_annot t tag = Base(([],t),tag,[],pure_e,pure_e,nob)
-let tag_annot_efr t tag efr = Base(([],t),tag,[],pure_e,efr,nob)
-let constrained_annot t cs = Base(([],t),Emp_local,cs,pure_e,pure_e,nob)
-let constrained_annot_efr t cs efr = Base(([],t),Emp_local,cs,pure_e,efr,nob)
-let bounds_annot t bs = Base(([],t),Emp_local,[],pure_e,pure_e,bs)
-let bounds_annot_efr t bs efr = Base(([],t),Emp_local,[],pure_e,efr,bs)
-let cons_tag_annot t tag cs = Base(([],t),tag,cs,pure_e,pure_e,nob)
-let cons_tag_annot_efr t tag cs efr = Base(([],t),tag,cs,pure_e,efr,nob)
-let cons_efl_annot t cs ef = Base(([],t),Emp_local,cs,ef,pure_e,nob)
-let cons_efs_annot t cs efl efr = Base(([],t),Emp_local,cs,efl,efr,nob)
-let efs_annot t efl efr = Base(([],t),Emp_local,[],efl,efr,nob)
-let tag_efs_annot t tag efl efr = Base(([],t),tag,[],efl,efr,nob)
-let cons_bs_annot t cs bs = Base(([],t),Emp_local,cs,pure_e,pure_e,bs)
-let cons_bs_annot_efr t cs bs efr = Base(([],t), Emp_local, cs, pure_e, efr, bs)
-
-let initial_abbrev_env =
- Envmap.from_list [
- ("nat",global_annot nat_t);
- ("int",global_annot int_t);
- ("uint8",global_annot uint8_t);
- ("uint16",global_annot uint16_t);
- ("uint32",global_annot uint32_t);
- ("uint64",global_annot uint64_t);
- ("bool",global_annot bit_t);
- ]
-
-let mk_nat_params l = List.map (fun i -> (i,{k=K_Nat})) l
-let mk_typ_params l = List.map (fun i -> (i,{k=K_Typ})) l
-let mk_ord_params l = List.map (fun i -> (i,{k=K_Ord})) l
-
-let mk_tup ts = {t = Ttup ts }
-let mk_pure_fun arg ret = {t = Tfn (arg,ret,IP_none,pure_e)}
-let mk_pure_imp arg ret var = {t = Tfn (arg,ret,IP_length (mk_nv var),pure_e)}
-
-let lib_tannot param_typs func cs =
- Base(param_typs, External func, cs, pure_e, pure_e, nob)
-
-let mk_ovar s = {order = Ovar s}
-let mk_range n1 n2 = {t=Tapp("range",[TA_nexp n1;TA_nexp n2])}
-let mk_atom n1 = {t = Tapp("atom",[TA_nexp n1])}
-let mk_vector typ order start size = {t=Tapp("vector",[TA_nexp start; TA_nexp size; TA_ord order; TA_typ typ])}
-let mk_bitwise_op name symb arity =
- let ovar = mk_ovar "o" in
- let vec_typ = mk_vector bit_t ovar (mk_nv "n") (mk_nv "m") in
- let single_bit_vec_typ = mk_vector bit_t ovar (mk_nv "n") n_one in
- let vec_args = Array.to_list (Array.make arity vec_typ) in
- let single_bit_vec_args = Array.to_list (Array.make arity single_bit_vec_typ) in
- let bit_args = Array.to_list (Array.make arity bit_t) in
- let gen_args = Array.to_list (Array.make arity {t = Tvar "a"}) in
- let svarg,varg,barg,garg = if (arity = 1)
- then List.hd single_bit_vec_args,List.hd vec_args,List.hd bit_args,List.hd gen_args
- else mk_tup single_bit_vec_args,mk_tup vec_args,mk_tup bit_args, mk_tup gen_args in
- (symb,
- Overload(lib_tannot ((mk_typ_params ["a"]),mk_pure_fun garg {t=Tvar "a"}) (Some name) [], true,
- [lib_tannot ((mk_nat_params ["n";"m"]@mk_ord_params["o"]), mk_pure_fun varg vec_typ) (Some name) [];
- (*lib_tannot (["n",{k=K_Nat};"o",{k=K_Ord}],mk_pure_fun svarg single_bit_vec_typ) (Some name) [];*)
- lib_tannot ([],mk_pure_fun barg bit_t) (Some (name ^ "_bit")) []]))
-
-let initial_typ_env_list : (string * ((string * tannot) list)) list =
-
- [
- "bitwise logical operators",
- [
- ("not",
- Base(([], mk_pure_fun bit_t bit_t), External (Some "bitwise_not_bit"), [],pure_e,pure_e,nob));
- mk_bitwise_op "bitwise_not" "~" 1;
- mk_bitwise_op "bitwise_or" "|" 2;
- mk_bitwise_op "bitwise_xor" "^" 2;
- mk_bitwise_op "bitwise_and" "&" 2;
- ];
- "bitwise shifts and rotates",
- [
- ("<<",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"));
- (mk_range n_zero (mk_nv "m"))])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- External (Some "bitwise_leftshift"),[],pure_e,pure_e,nob));
- (">>",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"));
- (mk_range n_zero (mk_nv "m"))])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- External (Some "bitwise_rightshift"),[],pure_e,pure_e,nob));
- ("<<<",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"));
- (mk_range n_zero (mk_nv "m"))])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- External (Some "bitwise_rotate"),[],pure_e,pure_e,nob));
- ];
- "bitvector duplicate, extension, and MSB",
- [
- ("^^",
- Overload(
- Base((mk_nat_params["n";"o";"p"]@[("a",{k=K_Typ})],
- (mk_pure_fun (mk_tup [{t=Tvar "a"}; mk_atom (mk_nv "n")])
- (mk_vector bit_t {order = Oinc} (mk_nv "o") (mk_nv "p")))),
- External (Some "duplicate"), [], pure_e, pure_e, nob),
- false,
- [Base((mk_nat_params ["n"],
- (mk_pure_fun (mk_tup [bit_t;mk_atom (mk_nv "n")])
- (mk_vector bit_t {order=Oinc} (mk_c zero) (mk_nv "n")))),
- External (Some "duplicate"),[],pure_e,pure_e,nob);
- Base((mk_nat_params ["n";"m";"o"]@mk_ord_params["ord"],
- mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "m");
- mk_atom (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_mult (mk_nv "m") (mk_nv "n")))),
- External (Some "duplicate_bits"),[],pure_e,pure_e,nob);]));
- ("EXTZ",Base((((mk_nat_params ["n";"m";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_imp (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "m")) "m")),
- External (Some "extz"),[],pure_e,pure_e,nob));
- ("EXTS",Base((((mk_nat_params ["n";"m";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_imp (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "m")) "m")),
- External (Some "exts"),[],pure_e,pure_e,nob));
- ("most_significant", lib_tannot ((mk_nat_params ["n";"m"]@(mk_ord_params ["ord"])),
- (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) bit_t))
- None []);
- ];
- "arithmetic",
- [
- ("+",Overload(
- lib_tannot ((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) (Some "add") [],
- true,
- [lib_tannot ((mk_nat_params ["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_add (mk_nv "n") (mk_nv "m")))))
- (Some "add") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))))
- (Some "add_vec") [];
- lib_tannot ((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_range (mk_nv "q") (mk_2n (mk_nv "n")))))
- (Some "add_vec_vec_range") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "add_vec_range")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require, (mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t])))
- (Some "add_overflow_vec") [];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "add_vec_range_range")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "add_range_vec")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_sub (mk_2n (mk_nv "m")) n_one)))))
- (Some "add_range_vec_range")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"))))
- (Some "add_vec_bit") [];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [bit_t; mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"))))
- (Some "add_bit_vec") [];
- ]));
- ("+_s",Overload(
- lib_tannot ((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) (Some "add") [],
- true,
- [lib_tannot ((mk_nat_params ["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_add (mk_nv "n") (mk_nv "m")))))
- (Some "add_signed") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))))
- (Some "add_vec_signed") [];
- lib_tannot ((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_range (mk_nv "q") (mk_2n (mk_nv "n")))))
- (Some "add_vec_vec_range_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "add_vec_range_signed")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t])))
- (Some "add_overflow_vec_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "add_vec_range_range_signed")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require, (mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "add_range_vec_signed")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "add_range_vec_range_signed")
- [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"))))
- (Some "add_vec_bit_signed") [];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t])))
- (Some "add_overflow_vec_bit_signed") [];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [bit_t; mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"))))
- (Some "add_bit_vec_signed") [];
- ]));
- ("-",Overload(
- lib_tannot ((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"}))
- (Some "minus") [],
- true,
- [lib_tannot ((mk_nat_params["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_sub (mk_nv "n") (mk_nv "m")))))
- (Some "minus") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))))
- (Some "minus_vec") [];
- lib_tannot ((mk_nat_params ["m";"n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_atom (mk_nv "m")))) (Some "minus_vec_vec_range") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "minus_vec_range") [];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "minus_vec_range_range") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "minus_range_vec") [];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "minus_range_vec_range") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t])))
- (Some "minus_overflow_vec") [];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t])))
- (Some "minus_overflow_vec_bit") [];
- ]));
- ("-_s",Overload(
- lib_tannot ((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"}))
- (Some "minus") [],
- true,
- [lib_tannot ((mk_nat_params["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_sub (mk_nv "n") (mk_nv "m")))))
- (Some "minus") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"))))
- (Some "minus_vec_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "minus_vec_range_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "minus_vec_range_range_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))))
- (Some "minus_range_vec_signed") [];
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");])
- (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m"))))))
- (Some "minus_range_vec_range_signed") [];
- lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t])))
- (Some "minus_overflow_vec_signed") [];
- lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t])))
- (Some "minus_overflow_vec_bit_signed") [];
- ]));
- ("*",Overload(
- lib_tannot ((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]){t=Tvar "c"}))
- (Some "multiply") [],
- true,
- [lib_tannot ((mk_nat_params["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_mult (mk_nv "n") (mk_nv "m")))))
- (Some "multiply") [];
- Base(((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "n") (mk_nv "n"))))),
- (External (Some "multiply_vec")), [],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "m") (mk_nv "m"))))),
- (External (Some "mult_range_vec")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "m") (mk_nv "m"))))),
- (External (Some "mult_vec_range")),[],pure_e,pure_e,nob);
- ]));
- ("*_s",Overload(
- Base(((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]){t=Tvar "c"})),
- (External (Some "multiply")),[],pure_e,pure_e,nob),
- true,
- [Base(((mk_nat_params["n";"m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")])
- (mk_atom (mk_mult (mk_nv "n") (mk_nv "m"))))),
- (External (Some "multiply_signed")), [],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"o";"p";"m"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_add (mk_nv "n") (mk_nv "n"))))),
- (External (Some "multiply_vec_signed")), [],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_add (mk_nv "m") (mk_nv "m"))))),
- (External (Some "mult_range_vec_signed")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_add (mk_nv "m") (mk_nv "m"))))),
- (External (Some "mult_vec_range_signed")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"o";"p";"m"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_add (mk_nv "n") (mk_nv "n")));
- bit_t;bit_t]))),
- (External (Some "mult_overflow_vec_signed")), [],pure_e,pure_e,nob);
- ]));
- ("mod",
- Overload(
- Base(((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})),
- (External (Some "modulo")),[],pure_e,pure_e,nob),
- true,
- [Base(((mk_nat_params["n";"o";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ; mk_atom (mk_nv "o")])
- (mk_range n_zero (mk_sub (mk_nv "o") n_one)))),
- (External (Some "modulo")),
- [GtEq(Specc(Parse_ast.Int("modulo",None)),Require,(mk_nv "o"),n_one)],pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"o"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_range n_one (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "mod_vec_range")),
- [GtEq(Specc(Parse_ast.Int("mod",None)),Require,(mk_nv "o"),n_one);],pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "mod_vec")),[],pure_e,pure_e,nob)]));
- ("mod_s",
- Overload(
- Base(((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})),
- (External (Some "mod_signed")),[],pure_e,pure_e,nob),
- true,
- [Base(((mk_nat_params["n";"o";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ; mk_atom (mk_nv "o")])
- (mk_range n_zero (mk_sub (mk_nv "o") n_one)))),
- (External (Some "mod_signed")),
- [GtEq(Specc(Parse_ast.Int("modulo",None)),Require,(mk_nv "o"),n_one)],pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"o"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_range n_one (mk_nv "o")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "mod_signed_vec_range")),
- [GtEq(Specc(Parse_ast.Int("mod",None)),Require,(mk_nv "o"),n_one);],pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "mod_signed_vec")),[],pure_e,pure_e,nob)]));
- ("div",
- Base(((mk_nat_params["n";"m";"o";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")])
- (mk_atom (mk_nv "o")))),
- (*This should really be != to 0, as negative is just fine*)
- (External (Some "quot")),[(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "m"),n_one);*)
- LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee,
- (mk_mult (mk_nv "n") (mk_nv "o")),(mk_nv "m"))],
- pure_e,pure_e,nob));
- ("quot",
- Overload(
- Base(((mk_typ_params ["a";"b";"c"]),
- (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})),
- (External (Some "quot")),[],pure_e,pure_e,nob),
- true,
- [Base(((mk_nat_params["n";"m";"o";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")])
- (mk_atom (mk_nv "o")))),
- (*This should really be != to 0, as negative is just fine*)
- (External (Some "quot")),[(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "m"),n_one);*)
- LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee,
- (mk_mult (mk_nv "n") (mk_nv "o")),(mk_nv "m"))],
- pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "quot_vec")),[GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],
- pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); bit_t;bit_t]))),
- (External (Some "quot_overflow_vec")),
- [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],
- pure_e,pure_e,nob)]));
- ("quot_s",
- Overload(
- Base(((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})),
- (External (Some "quot_signed")),[],pure_e,pure_e,nob),
- true,
- [Base(((mk_nat_params["n";"m";"o";"p";"q";"r"]),
- (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m"); mk_range (mk_nv "o") (mk_nv "p")])
- (mk_range (mk_nv "q") (mk_nv "r")))),
- (External (Some "quot_signed")),
- [(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "o"),n_one);*)
- LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee,(mk_mult (mk_nv "p") (mk_nv "r")),mk_nv "m")],
- pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")])
- (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))),
- (External (Some "quot_vec_signed")),
- [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],pure_e,pure_e,nob);
- Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")])
- (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); bit_t;bit_t]))),
- (External (Some "quot_overflow_vec_signed")),
- [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],pure_e,pure_e,nob);
- ]));
- ];
- "additional arithmetic on singleton ranges; vector length",
- [
- ("**",
- Base(((mk_nat_params ["o"]),
- (mk_pure_fun (mk_tup [(mk_atom n_two); (mk_atom (mk_nv "o"))])
- (mk_atom (mk_2n (mk_nv "o"))))),
- (External (Some "power")), [],pure_e,pure_e,nob));
-
- ("abs",Base(((mk_nat_params ["n";"m";]),
- (mk_pure_fun (mk_atom (mk_nv "n")) (mk_range n_zero (mk_nv "m")))),
- External (Some "abs"),[],pure_e,pure_e,nob));
- ("max",
- Base(((mk_nat_params ["n";"m";"o"]),
- (mk_pure_fun (mk_tup [(mk_atom (mk_nv "n"));(mk_atom (mk_nv "m"))])
- (mk_atom (mk_nv "o")))),
- External (Some "max"),[],pure_e,pure_e,nob));
- ("min",
- Base(((mk_nat_params ["n";"m";"o"]),
- (mk_pure_fun (mk_tup [(mk_atom (mk_nv "n"));(mk_atom (mk_nv "m"))])
- (mk_atom (mk_nv "o")))),
- External (Some "min"),[],pure_e,pure_e,nob));
- ("length", Base((["a",{k=K_Typ}]@(mk_nat_params["n";"m"])@(mk_ord_params["ord"]),
- (mk_pure_fun (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))
- (mk_atom (mk_nv "m")))),
- (External (Some "length")),[],pure_e,pure_e,nob));
- ];
-
- "comparisons",
- [
- (*Correct types again*)
- ("==",
- Overload(
- (lib_tannot (mk_typ_params ["a";"b"],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t))
- (Some "eq") []),
- false,
- [(*== : 'a['m] * 'a['m] -> bit_t *)
- lib_tannot ((mk_nat_params["n";"m";"o"]@mk_typ_params["a"]@mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "o") (mk_nv "m")])
- bit_t))
- (Some "eq_vec")
- [];
- (* == : bit['n] * [:'o:] -> bit_t *)
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- bit_t))
- (Some "eq_range_vec")
- [];
- (* == : [:'o:] * bit['n] -> bit_t *)
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- bit_t))
- (Some "eq_vec_range")
- [];
- (* == : [:'n:] * [:'m:] -> bit_t *)
- lib_tannot ((mk_nat_params["n";"m";],
- mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t))
- (Some "eq_range")
- [Predicate(Specc(Parse_ast.Int("==",None)),
- Eq(Specc(Parse_ast.Int("==",None)), mk_nv "n", mk_nv "m"),
- NtEq(Specc(Parse_ast.Int("==",None)), mk_nv "n", mk_nv "m"))];
- (* == : (bit_t,bit_t) -> bit_t *)
- lib_tannot ([], mk_pure_fun (mk_tup [bit_t;bit_t]) bit_t)
- (Some "eq_bit")
- [];
- lib_tannot (["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t))
- (Some "eq") []]));
- ("!=",
- Overload(
- lib_tannot ((mk_typ_params ["a";"b"]),(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t))
- (Some "neq") [],
- false,
- [(*!= : 'a['m] * 'a['m] -> bit_t *)
- lib_tannot ((mk_nat_params["n";"m";"o"]@mk_typ_params["a"]@mk_ord_params["ord"]),
- (mk_pure_fun (mk_tup [mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "o") (mk_nv "m")])
- bit_t))
- (Some "neq_vec")
- [];
- (* != : bit['n] * [:'o:] -> bit_t *)
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")])
- bit_t))
- (Some "neq_range_vec")
- [];
- (* != : [:'o:] * bit['n] -> bit_t *)
- lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")])
- bit_t))
- (Some "neq_vec_range")
- [];
- (* != : [:'n:] * [:'m:] -> bit_t *)
- lib_tannot ((mk_nat_params["n";"m";],
- mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t))
- (Some "neq_range")
- [Predicate(Specc(Parse_ast.Int("!=",None)),
- Eq(Specc(Parse_ast.Int("!=",None)), mk_nv "n", mk_nv "m"),
- NtEq(Specc(Parse_ast.Int("!=",None)), mk_nv "n", mk_nv "m"))];
- (* != : (bit_t,bit_t) -> bit_t *)
- lib_tannot ([], mk_pure_fun (mk_tup [bit_t;bit_t]) bit_t)
- (Some "neq_bit")
- [];
- lib_tannot (["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t))
- (Some "neq") []]));
- ("<",
- Overload(
- Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)),
- (External (Some "lt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n"; "m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "lt")),
- [Predicate(Specc(Parse_ast.Int("<",None)),
- Lt(Specc(Parse_ast.Int("<",None)),Guarantee, mk_nv "n", mk_nv "m"),
- GtEq(Specc(Parse_ast.Int("<",None)),Guarantee, mk_nv "n", mk_nv "m"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "lt_vec")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o"]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")]) bit_t)),
- (External (Some "lt_vec_range")), [], pure_e,pure_e, nob);
- ]));
- ("<_u",
- Overload(
- Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)),
- (External (Some "lt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n"; "m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "lt_unsigned")),
- [Predicate(Specc(Parse_ast.Int("<",None)),
- Lt(Specc(Parse_ast.Int("<_u",None)),Guarantee, mk_nv "n", mk_nv "m"),
- GtEq(Specc(Parse_ast.Int("<_u",None)),Guarantee, mk_nv "n", mk_nv "m"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "lt_vec_unsigned")),[],pure_e,pure_e,nob);
- ]));
- ("<_s",
- Overload(
- Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)),
- (External (Some "lt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n"; "m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "lt_signed")),
- [Predicate(Specc(Parse_ast.Int("<_s",None)),
- Lt(Specc(Parse_ast.Int("<_s",None)),Guarantee, mk_nv "n", mk_nv "m"),
- GtEq(Specc(Parse_ast.Int("<_s",None)),Guarantee, mk_nv "n", mk_nv "m"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "lt_vec_signed")),[],pure_e,pure_e,nob);
- ]));
- (">",
- Overload(
- Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)),
- (External (Some "gt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n";"m"]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "gt")),
- [Predicate(Specc(Parse_ast.Int(">",None)),
- Gt(Specc(Parse_ast.Int(">",None)),Guarantee, mk_nv "n", mk_nv "m"),
- LtEq(Specc(Parse_ast.Int(">",None)),Guarantee, mk_nv "n", mk_nv "m"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "gt_vec")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")]) bit_t)),
- (External (Some "gt_vec_range")), [], pure_e,pure_e, nob);
- ]));
- (">_u",
- Overload(
- Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)),
- (External (Some "gt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n";"m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "gt_unsigned")),
- [Predicate(Specc(Parse_ast.Int(">_u",None)),
- Gt(Specc(Parse_ast.Int(">_u",None)),Guarantee, mk_nv "n", mk_nv "m"),
- LtEq(Specc(Parse_ast.Int(">_u",None)),Guarantee, mk_nv "n", mk_nv "n"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "gt_vec_unsigned")),[],pure_e,pure_e,nob);
- ]));
- (">_s",
- Overload(
- Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)),
- (External (Some "gt")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n";"m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "gt_signed")),
- [Predicate(Specc(Parse_ast.Int(">_s",None)),
- Gt(Specc(Parse_ast.Int(">_s",None)),Guarantee, mk_nv "n", mk_nv "m"),
- LtEq(Specc(Parse_ast.Int(">_s",None)),Guarantee, mk_nv "m", mk_nv "m"))],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "gt_vec_signed")),[],pure_e,pure_e,nob);
- ]));
- ("<=",
- Overload(
- Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)),
- (External (Some "lteq")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n"; "m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "lteq")),
- [Predicate(Specc(Parse_ast.Int("<=",None)),
- LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "m"),
- Gt(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "m"))],
- pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")]) bit_t)),
- (External (Some "lteq_vec_range")), [], pure_e,pure_e, nob);
- Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) bit_t)),
- (External (Some "lteq_range_vec")), [], pure_e,pure_e, nob);
- Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "lteq_vec")),[],pure_e,pure_e,nob);
- ]));
- ("<=_s",
- Overload(
- Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)),
- (External (Some "lteq")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n"; "m";]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)),
- (External (Some "lteq_signed")),
- [LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "o");
- LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "m",mk_nv "p")],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "lteq_vec_signed")),[],pure_e,pure_e,nob);
- ]));
- (">=",
- Overload(
- Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)),
- (External (Some "gteq")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n";"m";"o";"p"]),
- (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m");mk_range (mk_nv "o") (mk_nv "p")]) bit_t)),
- (External (Some "gteq")),
- [GtEq(Specc(Parse_ast.Int(">=",None)),Guarantee, mk_nv "n", mk_nv "o");
- GtEq(Specc(Parse_ast.Int(">=",None)),Guarantee, mk_nv "m", mk_nv "p")],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "gteq_vec")),[],pure_e,pure_e,nob);
- Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");
- mk_atom (mk_nv "o")]) bit_t)),
- (External (Some "gteq_vec_range")), [], pure_e,pure_e, nob);
- Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]),
- (mk_pure_fun (mk_tup [mk_atom (mk_nv "o");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) bit_t)),
- (External (Some "gteq_range_vec")), [], pure_e,pure_e, nob);
- ]));
- (">=_s",
- Overload(
- Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)),
- (External (Some "gteq")),[],pure_e,pure_e,nob),
- false,
- [Base(((mk_nat_params ["n";"m";"o";"p"]),
- (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m");mk_range (mk_nv "o") (mk_nv "p")]) bit_t)),
- (External (Some "gteq_signed")),
- [GtEq(Specc(Parse_ast.Int(">=_s",None)),Guarantee, mk_nv "n", mk_nv "o");
- GtEq(Specc(Parse_ast.Int(">=_s",None)),Guarantee, mk_nv "m", mk_nv "p")],
- pure_e,pure_e,nob);
- Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]),
- (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n");
- mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)),
- (External (Some "gteq_vec_signed")),[],pure_e,pure_e,nob);
- ]));
- ];
-
-(** ? *)
- "oddments",
- [
- ("is_one",Base(([],(mk_pure_fun bit_t bit_t)),(External (Some "is_one")),[],pure_e,pure_e,nob));
- ("signed",Base((mk_nat_params["n";"m";"o"]@[("ord",{k=K_Ord})],
- (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))
- (mk_atom (mk_nv "o")))),
- External (Some "signed"),
- [(GtEq(Specc(Parse_ast.Int("signed",None)),Guarantee,
- mk_nv "o", mk_neg(mk_2n (mk_nv "m"))));
- (LtEq(Specc(Parse_ast.Int("signed",None)),Guarantee,
- mk_nv "o", mk_sub (mk_2n (mk_nv "m")) n_one));],pure_e,pure_e,nob));
- ("unsigned",Base((mk_nat_params["n";"m";"o"]@[("ord",{k=K_Ord})],
- (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))
- (mk_atom (mk_nv "o")))),
- External (Some "unsigned"),
- [(GtEq(Specc(Parse_ast.Int("unsigned",None)),Guarantee,
- mk_nv "o", n_zero));
- (LtEq(Specc(Parse_ast.Int("unsigned",None)),Guarantee,
- mk_nv "o", mk_sub (mk_2n (mk_nv "m")) n_one));],pure_e,pure_e,nob));
-
- ("ignore",lib_tannot ([("a",{k=K_Typ})],mk_pure_fun {t=Tvar "a"} unit_t) None []);
-
- (* incorrect types for typechecking processed sail code; do we care? *)
- ("mask",Base(((mk_typ_params ["a"])@(mk_nat_params["n";"m";"o";"p"])@(mk_ord_params["ord"]),
- (mk_pure_imp (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m"))
- (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "p") (mk_nv "o")) "o")),
- (External (Some "mask")),
- [GtEq(Specc(Parse_ast.Int("mask",None)),Guarantee, (mk_nv "m"), (mk_nv "o"))],pure_e,pure_e,nob));
- (*TODO These should be IP_start *)
- ("to_vec_inc",Base(([("a",{k=K_Typ})],{t=Tfn(nat_typ,{t=Tvar "a"},IP_none,pure_e)}),
- (External None),[],pure_e,pure_e,nob));
- ("to_vec_dec",Base(([("a",{k=K_Typ})],{t=Tfn(nat_typ,{t=Tvar "a"},IP_none,pure_e)}),
- (External None),[],pure_e,pure_e,nob));
- ];
-
-
-"option type constructors",
- [
- ("Some", Base((["a",{k=K_Typ}], mk_pure_fun {t=Tvar "a"} {t=Tapp("option", [TA_typ {t=Tvar "a"}])}),
- Constructor 2,[],pure_e,pure_e,nob));
- ("None", Base((["a", {k=K_Typ}], mk_pure_fun unit_t {t=Tapp("option", [TA_typ {t=Tvar "a"}])}),
- Constructor 2,[],pure_e,pure_e,nob));
- ];
-
-"list operations",
- [
- ("append",
- lib_tannot
- (["a",{k=K_Typ}], mk_pure_fun (mk_tup [{t=Tapp("list", [TA_typ {t=Tvar "a"}])};
- {t=Tapp("list", [TA_typ {t=Tvar "a"}])}])
- {t=Tapp("list",[TA_typ {t=Tvar "a"}])})
- None []);
- ];
-
-]
-
-
-let initial_typ_env : tannot Envmap.t =
- Envmap.from_list (List.flatten (List.map snd initial_typ_env_list))
-
-
-
-let rec typ_subst s_env leave_imp t =
- match t.t with
- | Tvar i -> (match Envmap.apply s_env i with
- | Some(TA_typ t1) -> t1
- | _ -> { t = Tvar i})
- | Tuvar _ -> new_t()
- | Tid i -> { t = Tid i}
- | Tfn(t1,t2,imp,e) ->
- {t =Tfn((typ_subst s_env false t1),(typ_subst s_env false t2),(ip_subst s_env leave_imp imp),(e_subst s_env e)) }
- | Ttup(ts) -> { t= Ttup(List.map (typ_subst s_env leave_imp) ts) }
- | Tapp(i,args) -> {t= Tapp(i,List.map (ta_subst s_env leave_imp) args)}
- | Tabbrev(ti,ta) -> {t = Tabbrev(typ_subst s_env leave_imp ti,typ_subst s_env leave_imp ta) }
- | Toptions(t1,None) -> {t = Toptions(typ_subst s_env leave_imp t1,None)}
- | Toptions(t1,Some t2) -> {t = Toptions(typ_subst s_env leave_imp t1,Some (typ_subst s_env leave_imp t2)) }
-and ip_subst s_env leave_imp ip =
- let leave_nu = if leave_imp then leave_nuvar else (fun i -> i) in
- match ip with
- | IP_none -> ip
- | IP_length n -> IP_length (leave_nu (n_subst s_env n))
- | IP_start n -> IP_start (leave_nu (n_subst s_env n))
- | IP_user n -> IP_user (leave_nu (n_subst s_env n))
-and ta_subst s_env leave_imp ta =
- match ta with
- | TA_typ t -> TA_typ (typ_subst s_env leave_imp t)
- | TA_nexp n -> TA_nexp (n_subst s_env n)
- | TA_eft e -> TA_eft (e_subst s_env e)
- | TA_ord o -> TA_ord (o_subst s_env o)
-and n_subst s_env n =
- match n.nexp with
- | Nvar i ->
- (match Envmap.apply s_env i with
- | Some(TA_nexp n1) -> n1
- | _ -> mk_nv i)
- | Nid(i,n) -> n_subst s_env n
- | Nuvar _ -> new_n()
- | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> n
- | N2n(n1,None) -> mk_2n (n_subst s_env n1)
- | N2n(n1,Some(i)) -> mk_2nc (n_subst s_env n1) i
- | Npow(n1,i) -> mk_pow (n_subst s_env n1) i
- | Nneg n1 -> mk_neg (n_subst s_env n1)
- | Nadd(n1,n2) -> mk_add (n_subst s_env n1) (n_subst s_env n2)
- | Nsub(n1,n2) -> mk_sub (n_subst s_env n1) (n_subst s_env n2)
- | Nmult(n1,n2) -> mk_mult(n_subst s_env n1) (n_subst s_env n2)
-and o_subst s_env o =
- match o.order with
- | Ovar i -> (match Envmap.apply s_env i with
- | Some(TA_ord o1) -> o1
- | _ -> { order = Ovar i })
- | Ouvar _ -> new_o ()
- | _ -> o
-and e_subst s_env e =
- match e.effect with
- | Evar i -> (match Envmap.apply s_env i with
- | Some(TA_eft e1) -> e1
- | _ -> {effect = Evar i})
- | Euvar _ -> new_e ()
- | _ -> e
-
-let rec cs_subst t_env cs =
- match cs with
- | [] -> []
- | Eq(l,n1,n2)::cs -> Eq(l,n_subst t_env n1,n_subst t_env n2)::(cs_subst t_env cs)
- | NtEq(l,n1,n2)::cs -> NtEq(l, n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs)
- | GtEq(l,enforce,n1,n2)::cs -> GtEq(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs)
- | Gt(l,enforce,n1,n2)::cs -> Gt(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs)
- | LtEq(l,enforce,n1,n2)::cs -> LtEq(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs)
- | Lt(l,enforce,n1,n2)::cs -> Lt(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs)
- | In(l,s,ns)::cs ->
- let nexp = n_subst t_env (mk_nv s) in
- (match nexp.nexp with
- | Nuvar urec -> urec.nin <- true
- | _ -> ());
- InS(l,nexp,ns)::(cs_subst t_env cs)
- | InS(l,n,ns)::cs -> InS(l,n_subst t_env n,ns)::(cs_subst t_env cs)
- | Predicate(l, cp,cn)::cs ->
- Predicate(l, List.hd(cs_subst t_env [cp]), List.hd(cs_subst t_env [cn]))::(cs_subst t_env cs)
- | CondCons(l,kind,_,cs_p,cs_e)::cs ->
- CondCons(l,kind,None,cs_subst t_env cs_p,cs_subst t_env cs_e)::(cs_subst t_env cs)
- | BranchCons(l,_,bs)::cs -> BranchCons(l,None,cs_subst t_env bs)::(cs_subst t_env cs)
-
-let subst_with_env env leave_imp t cs e =
- (typ_subst env leave_imp t, cs_subst env cs, e_subst env e, env)
-
-let subst_n_with_env = n_subst
-
-let subst (k_env : (Envmap.k * kind) list) (leave_imp:bool) (use_var:bool)
- (t : t) (cs : nexp_range list) (e : effect) : (t * nexp_range list * effect * t_arg emap) =
- let subst_env = Envmap.from_list
- (List.map (fun (id,k) -> (id,
- match k.k with
- | K_Typ -> TA_typ (if use_var then (new_tv id) else (new_t ()))
- | K_Nat -> TA_nexp (if use_var then (new_nv id) else (new_n ()))
- | K_Ord -> TA_ord (new_o ())
- | K_Efct -> TA_eft (new_e ())
- | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown
- "substitution given an environment with a non-base-kind kind"))) k_env)
- in
- subst_with_env subst_env leave_imp t cs e
-
-let rec typ_param_eq l spec_param fun_param =
- match (spec_param,fun_param) with
- | ([],[]) -> []
- | (_,[]) ->
- raise (Reporting_basic.err_typ l "Specification type variables and function definition variables must match")
- | ([],_) ->
- raise
- (Reporting_basic.err_typ l "Function definition declares more type variables than specification variables")
- | ((ids,tas)::spec_param,(idf,taf)::fun_param) ->
- if ids=idf
- then match (tas,taf) with
- | (TA_typ tas_t,TA_typ taf_t) -> (equate_t tas_t taf_t); typ_param_eq l spec_param fun_param
- | (TA_nexp tas_n, TA_nexp taf_n) -> Eq((Specc l),tas_n,taf_n)::typ_param_eq l spec_param fun_param
- | (TA_ord tas_o,TA_ord taf_o) -> (equate_o tas_o taf_o); typ_param_eq l spec_param fun_param
- | (TA_eft tas_e,TA_eft taf_e) -> (equate_e tas_e taf_e); typ_param_eq l spec_param fun_param
- | _ ->
- raise (Reporting_basic.err_typ l
- ("Specification and function definition have different kinds for variable " ^ ids))
- else raise (Reporting_basic.err_typ l
- ("Specification type variables must match in order and number the function definition type variables, stopped matching at " ^ ids ^ " and " ^ idf))
-
-let type_param_consistent l spec_param fun_param =
- let specs = Envmap.to_list spec_param in
- let funs = Envmap.to_list fun_param in
- match specs,funs with
- | [],[] | _,[] -> []
- | _ -> typ_param_eq l specs funs
-
-let rec t_remove_unifications s_env t =
- match t.t with
- | Tvar _ | Tid _-> s_env
- | Tuvar tu ->
- (match tu.subst with
- | None ->
- (match fresh_tvar s_env t with
- | Some ks -> Envmap.insert s_env ks
- | None -> s_env)
- | _ -> ignore(resolve_tsubst t); s_env)
- | Tfn(t1,t2,_,e) -> e_remove_unifications (t_remove_unifications (t_remove_unifications s_env t1) t2) e
- | Ttup(ts) -> List.fold_right (fun t s_env -> t_remove_unifications s_env t) ts s_env
- | Tapp(i,args) -> List.fold_left (fun s_env t -> ta_remove_unifications s_env t) s_env args
- | Tabbrev(ti,ta) -> (t_remove_unifications (t_remove_unifications s_env ti) ta)
- | Toptions(t1,t2) -> assert false (*This should really be removed by this point*)
-and ta_remove_unifications s_env ta =
- match ta with
- | TA_typ t -> (t_remove_unifications s_env t)
- | TA_nexp n -> (n_remove_unifications s_env n)
- | TA_eft e -> (e_remove_unifications s_env e)
- | TA_ord o -> (o_remove_unifications s_env o)
-and n_remove_unifications s_env n =
- (*let _ = Printf.eprintf "n_remove_unifications %s\n" (n_to_string n) in*)
- match n.nexp with
- | Nvar _ | Nid _ | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> s_env
- | Nuvar _ ->
- let _ = collapse_nuvar_chain (get_outer_most n) in
- (*let _ = Printf.eprintf "nuvar is before turning into var %s\n" (n_to_string n) in*)
- (match fresh_nvar s_env n with
- | Some ks -> Envmap.insert s_env ks
- | None -> s_env)
- | N2n(n1,_) | Npow(n1,_) | Nneg n1 -> (n_remove_unifications s_env n1)
- | Nadd(n1,n2) | Nsub(n1,n2) | Nmult(n1,n2) -> (n_remove_unifications (n_remove_unifications s_env n1) n2)
-and o_remove_unifications s_env o =
- match o.order with
- | Ouvar _ -> (match fresh_ovar s_env o with
- | Some ks -> Envmap.insert s_env ks
- | None -> s_env)
- | _ -> s_env
-and e_remove_unifications s_env e =
- match e.effect with
- | Euvar _ -> (match fresh_evar s_env e with
- | Some ks -> Envmap.insert s_env ks
- | None -> s_env)
- | _ -> s_env
-
-
-let remove_internal_unifications s_env =
- let rec rem remove s_env u_list = match u_list with
- | [] -> s_env
- | i::u_list -> rem remove (remove s_env i) u_list
- in
- (rem e_remove_unifications
- (rem o_remove_unifications
- (rem n_remove_unifications
- (rem t_remove_unifications s_env !tuvars)
- !nuvars)
- !ouvars)
- !euvars)
-
-let rec t_to_typ t =
- match t.t with
- | Tid i -> Typ_aux(Typ_id (Id_aux((Id i), Parse_ast.Unknown)),Parse_ast.Unknown)
- | Tvar i -> Typ_aux(Typ_var (Kid_aux((Var i),Parse_ast.Unknown)),Parse_ast.Unknown)
- | Tfn(t1,t2,_,e) -> Typ_aux(Typ_fn (t_to_typ t1, t_to_typ t2, e_to_ef e),Parse_ast.Unknown)
- | Ttup ts -> Typ_aux(Typ_tup(List.map t_to_typ ts),Parse_ast.Unknown)
- | Tapp(i,args) ->
- Typ_aux(Typ_app(Id_aux((Id i), Parse_ast.Unknown),List.map targ_to_typ_arg args),Parse_ast.Unknown)
- | Tabbrev(t,_) -> t_to_typ t
- | Tuvar _ | Toptions _ -> Typ_aux(Typ_var (Kid_aux((Var "fresh"),Parse_ast.Unknown)),Parse_ast.Unknown)
-and targ_to_typ_arg targ =
- Typ_arg_aux(
- (match targ with
- | TA_nexp n -> Typ_arg_nexp (n_to_nexp n)
- | TA_typ t -> Typ_arg_typ (t_to_typ t)
- | TA_ord o -> Typ_arg_order (o_to_order o)
- | TA_eft e -> Typ_arg_effect (e_to_ef e)), Parse_ast.Unknown)
-and n_to_nexp n =
- Nexp_aux(
- (match n.nexp with
- | Nid(i,_) -> Nexp_id (Id_aux ((Id i),Parse_ast.Unknown))
- | Nvar i -> Nexp_var (Kid_aux((Var i),Parse_ast.Unknown))
- | Nconst i -> Nexp_constant (int_of_big_int i) (*TODO: Push more bigint around*)
- | Npos_inf -> Nexp_constant max_int (*TODO: Not right*)
- | Nneg_inf -> Nexp_constant min_int (* see above *)
- | Ninexact -> Nexp_constant min_int (*and above*)
- | Nmult(n1,n2) -> Nexp_times(n_to_nexp n1,n_to_nexp n2)
- | Nadd(n1,n2) -> Nexp_sum(n_to_nexp n1,n_to_nexp n2)
- | Nsub(n1,n2) -> Nexp_minus(n_to_nexp n1,n_to_nexp n2)
- | N2n(n,_) -> Nexp_exp (n_to_nexp n)
- | Npow(n,1) -> let Nexp_aux(n',_) = n_to_nexp n in n'
- | Npow(n,i) -> Nexp_times(n_to_nexp n,n_to_nexp( mk_pow n (i-1)))
- | Nneg n -> Nexp_neg (n_to_nexp n)
- | Nuvar _ -> Nexp_var (Kid_aux((Var "fresh"),Parse_ast.Unknown))), Parse_ast.Unknown)
-and e_to_ef ef =
- Effect_aux(
- (match ef.effect with
- | Evar i -> Effect_var (Kid_aux((Var i),Parse_ast.Unknown))
- | Eset effects -> Effect_set effects
- | Euvar _ -> assert false), Parse_ast.Unknown)
-and o_to_order o =
- Ord_aux(
- (match o.order with
- | Ovar i -> Ord_var (Kid_aux((Var i),Parse_ast.Unknown))
- | Oinc -> Ord_inc
- | Odec -> Ord_dec
- | Ouvar _ -> Ord_var (Kid_aux((Var "fresh"),Parse_ast.Unknown))), Parse_ast.Unknown)
-
-let rec get_abbrev d_env t =
- match t.t with
- | Tid i ->
- (match Envmap.apply d_env.abbrevs i with
- | Some(Base((params,ta),tag,cs,efct,_,_)) ->
- let ta,cs,_,_ = subst params false false ta cs efct in
- let ta,cs' = get_abbrev d_env ta in
- (match ta.t with
- | Tabbrev(t',ta) -> ({t=Tabbrev({t=Tabbrev(t,t')},ta)},cs@cs')
- | _ -> ({t = Tabbrev(t,ta)},cs))
- | _ -> t,[])
- | Tapp(i,args) ->
- (match Envmap.apply d_env.abbrevs i with
- | Some(Base((params,ta),tag,cs,efct,_,_)) ->
- let env = Envmap.from_list2 (List.map fst params) args in
- let ta,cs' = get_abbrev d_env (typ_subst env false ta) in
- (match ta.t with
- | Tabbrev(t',ta) -> ({t=Tabbrev({t=Tabbrev(t,t')},ta)},cs_subst env (cs@cs'))
- | _ -> ({t = Tabbrev(t,ta)},cs_subst env cs))
- | _ -> t,[])
- | _ -> t,[]
-
-let is_enum_typ d_env t =
- let t,_ = get_abbrev d_env t in
- let t_actual = match t.t with | Tabbrev(_,ta) -> ta | _ -> t in
- match t_actual.t with
- | Tid i -> (match Envmap.apply d_env.enum_env i with
- | Some(ns) -> Some(List.length ns)
- | _ -> None)
- | _ -> None
-
-let eq_error l msg = raise (Reporting_basic.err_typ l msg)
-let multi_constraint_error l1 l2 msg = raise (Reporting_basic.err_typ_dual (get_c_loc l1) (get_c_loc l2) msg)
-
-let compare_effect (BE_aux(e1,_)) (BE_aux(e2,_)) =
- match e1,e2 with
- | (BE_rreg,BE_rreg) -> 0
- | (BE_rreg,_) -> -1
- | (_,BE_rreg) -> 1
- | (BE_wreg,BE_wreg) -> 0
- | (BE_wreg,_) -> -1
- | (_,BE_wreg) -> 1
- | (BE_rmem,BE_rmem) -> 0
- | (BE_rmem,_) -> -1
- | (_,BE_rmem) -> 1
- | (BE_rmemt,BE_rmemt) -> 0
- | (BE_rmemt,_) -> -1
- | (_,BE_rmemt) -> 1
- | (BE_wmem,BE_wmem) -> 0
- | (BE_wmem,_) -> -1
- | (_,BE_wmem) -> 1
- | (BE_wmv,BE_wmv) -> 0
- | (BE_wmv, _ ) -> -1
- | (_,BE_wmv) -> 1
- | (BE_wmvt,BE_wmvt) -> 0
- | (BE_wmvt, _ ) -> -1
- | (_,BE_wmvt) -> 1
- | (BE_eamem,BE_eamem) -> 0
- | (BE_eamem,_) -> -1
- | (_,BE_eamem) -> 1
- | (BE_exmem,BE_exmem) -> 0
- | (BE_exmem,_) -> -1
- | (_,BE_exmem) -> 1
- | (BE_barr,BE_barr) -> 0
- | (BE_barr,_) -> 1
- | (_,BE_barr) -> -1
- | (BE_undef,BE_undef) -> 0
- | (BE_undef,_) -> -1
- | (_,BE_undef) -> 1
- | (BE_unspec,BE_unspec) -> 0
- | (BE_unspec,_) -> -1
- | (_,BE_unspec) -> 1
- | (BE_nondet,BE_nondet) -> 0
- | (BE_nondet,_) -> -1
- | (_,BE_nondet) -> 1
- | (BE_depend,BE_depend) -> 0
- | (BE_depend,_) -> -1
- | (_,BE_depend) -> 1
- | (BE_lset,BE_lset) -> 0
- | (BE_lset,_) -> -1
- | (_,BE_lset) -> 1
- | (BE_lret,BE_lret) -> 0
- | (BE_lret,_) -> -1
- | (_, BE_lret) -> 1
- | (BE_escape,BE_escape) -> 0
-
-let effect_sort = List.sort compare_effect
-
-let eq_be_effect (BE_aux (e1,_)) (BE_aux(e2,_)) = e1 = e2
-
-(* Check that o1 is or can be eqaul to o2.
- In the event that one is polymorphic, inc or dec can be used polymorphically but 'a cannot be used as inc or dec *)
-let order_eq co o1 o2 =
- let l = get_c_loc co in
- match (o1.order,o2.order) with
- | (Oinc,Oinc) | (Odec,Odec) | (Oinc,Ovar _) | (Odec,Ovar _) -> o2
- | (Ouvar i,_) -> equate_o o1 o2; o2
- | (_,Ouvar i) -> equate_o o2 o1; o2
- | (Ovar v1,Ovar v2) -> if v1=v2 then o2
- else eq_error l ("Order variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified")
- | (Oinc,Odec) | (Odec,Oinc) -> eq_error l "Order mismatch of inc and dec"
- | (Ovar v1,Oinc) -> eq_error l ("Polymorphic order " ^ v1 ^ " cannot be used where inc is expected")
- | (Ovar v1,Odec) -> eq_error l ("Polymorhpic order " ^ v1 ^ " cannot be used where dec is expected")
-
-let rec remove_internal_effects = function
- | [] -> []
- | (BE_aux((BE_lset | BE_lret),_))::effects -> remove_internal_effects effects
- | b::effects -> b::(remove_internal_effects effects)
-
-let has_effect searched_for eff =
- match eff.effect with
- | Eset es ->
- List.exists (eq_be_effect searched_for) es
- | _ -> false
-
-let has_rreg_effect = has_effect (BE_aux(BE_rreg, Parse_ast.Unknown))
-let has_wreg_effect = has_effect (BE_aux(BE_wreg, Parse_ast.Unknown))
-let has_rmem_effect = has_effect (BE_aux(BE_rmem, Parse_ast.Unknown))
-let has_rmemt_effect = has_effect (BE_aux(BE_rmemt, Parse_ast.Unknown))
-let has_wmem_effect = has_effect (BE_aux(BE_wmem, Parse_ast.Unknown))
-let has_eamem_effect = has_effect (BE_aux(BE_eamem, Parse_ast.Unknown))
-let has_exmem_effect = has_effect (BE_aux(BE_exmem, Parse_ast.Unknown))
-let has_memv_effect = has_effect (BE_aux(BE_wmv, Parse_ast.Unknown))
-let has_memvt_effect = has_effect (BE_aux(BE_wmvt, Parse_ast.Unknown))
-let has_lret_effect = has_effect (BE_aux(BE_lret, Parse_ast.Unknown))
-
-(*Similarly to above.*)
-let effects_eq co e1 e2 =
- let l = get_c_loc co in
- match e1.effect,e2.effect with
- | Eset _ , Evar _ -> e2
- | Euvar i,_ -> equate_e e1 e2; e2
- | _,Euvar i -> equate_e e2 e1; e2
- | Eset es1,Eset es2 ->
- let es1, es2 = remove_internal_effects es1, remove_internal_effects es2 in
- if (List.length es1) = (List.length es2) && (List.for_all2 eq_be_effect (effect_sort es1) (effect_sort es2) )
- then e2
- else eq_error l ("Effects must be the same, given " ^ e_to_string e1 ^ " and " ^ e_to_string e2)
- | Evar v1, Evar v2 -> if v1 = v2 then e2
- else eq_error l ("Effect variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified")
- | Evar v1, Eset _ ->
- eq_error l ("Effect variable " ^ v1 ^ " cannot be used where a concrete set of effects is specified")
-
-
-let build_variable_range d_env v typ =
- let t,_ = get_abbrev d_env typ in
- let t_actual = match t.t with | Tabbrev(_,t) -> t | _ -> t in
- match t_actual.t with
- | Tapp("atom", [TA_nexp n]) -> Some(VR_eq(v,n))
- | Tapp("range", [TA_nexp base;TA_nexp top]) ->
- Some(VR_range(v,[LtEq((Patt Parse_ast.Unknown),Require,base,top)]))
- | Tapp("vector", [TA_nexp start; TA_nexp rise; _; _]) -> Some(VR_vec_eq(v,rise))
- | Tuvar _ -> Some(VR_recheck(v,t_actual))
- | _ -> None
-
-let get_vr_var =
- function | VR_eq (v,_) | VR_range(v,_) | VR_vec_eq(v,_) | VR_vec_r(v,_) | VR_recheck(v,_) -> v
-
-let compare_variable_range v1 v2 = compare (get_vr_var v1) (get_vr_var v2)
-
-let extract_bounds d_env v typ =
- match build_variable_range d_env v typ with
- | None -> No_bounds
- | Some vb -> Bounds([vb], None)
-
-let find_bounds v bounds = match bounds with
- | No_bounds -> None
- | Bounds(bs,maps) ->
- let rec find_rec bs = match bs with
- | [] -> None
- | b::bs -> if (get_vr_var b) = v then Some(b) else find_rec bs in
- find_rec bs
-
-let add_map_to_bounds m bounds = match bounds with
- | No_bounds -> Bounds([],Some m)
- | Bounds(bs,None) -> Bounds(bs,Some m)
- | Bounds(bs,Some m') -> Bounds(bs,Some (Nexpmap.union m m'))
-
-let rec add_map_tannot m tannot = match tannot with
- | NoTyp -> NoTyp
- | Base(params,tag,cs,efl,efr,bounds) -> Base(params,tag,cs,efl,efr,add_map_to_bounds m bounds)
- | Overload(t,r,ts) -> Overload(add_map_tannot m t,r,ts)
-
-let get_map_bounds = function
- | No_bounds -> None
- | Bounds(_,m) -> m
-
-let get_map_tannot = function
- | NoTyp -> None
- | Base(_,_,_,_,_,bounds) -> get_map_bounds bounds
- | Overload _ -> None
-
-let rec expand_nexp n = match n.nexp with
- | Nvar _ | Nconst _ | Nuvar _ | Npos_inf | Nneg_inf | Ninexact -> [n]
- | Nadd (n1,n2) | Nsub (n1,n2) | Nmult (n1,n2) -> n::((expand_nexp n1)@(expand_nexp n2))
- | N2n (n1,_) | Npow (n1,_) | Nneg n1 | Nid(_,n1) -> n::(expand_nexp n1)
-
-let is_nconst n = match n.nexp with | Nconst _ -> true | _ -> false
-
-let find_var_from_nexp n bounds =
- (*let _ = Printf.eprintf "finding %s in bounds\n" (n_to_string n) in*)
- if is_nconst n then None
- else match bounds with
- | No_bounds -> None
- | Bounds(bs,map) ->
- let rec find_rec bs n = match bs with
- | [] -> None
- | b::bs -> (match b with
- | VR_eq(ev,n1) ->
- (*let _ = Printf.eprintf "checking if %s is eq to %s, to bind to %s, eq? %b\n"
- (n_to_string n) (n_to_string n1) ev (nexp_eq_check n1 n) in*)
- if nexp_eq_check n1 n then Some (None,ev) else find_rec bs n
- | VR_vec_eq (ev,n1)->
- (*let _ = Printf.eprintf "checking if %s is eq to %s, to bind to %s, eq? %b\n"
- (n_to_string n) (n_to_string n1) ev (nexp_eq_check n1 n) in*)
- if nexp_eq_check n1 n then Some (Some "length",ev) else find_rec bs n
- | _ -> find_rec bs n) in
- match find_rec bs n,map with
- | None, None -> None
- | None, Some map ->
- (match Nexpmap.apply map n with
- | None -> None
- | Some n' -> find_rec bs n')
- | s,_ -> s
-
-let merge_bounds b1 b2 =
- match b1,b2 with
- | No_bounds,b | b,No_bounds -> b
- | Bounds(b1s,map1),Bounds(b2s,map2) ->
- let merged_map = match map1,map2 with
- | None, None -> None
- | None, m | m, None -> m
- | Some m1, Some m2 -> Some (Nexpmap.union m1 m2) in
- let b1s = List.sort compare_variable_range b1s in
- let b2s = List.sort compare_variable_range b2s in
- let rec merge b1s b2s = match (b1s,b2s) with
- | [],b | b,[] -> b
- | b1::b1s,b2::b2s ->
- match compare_variable_range b1 b2 with
- | -1 -> b1::(merge b1s (b2::b2s))
- | 1 -> b2::(merge (b1::b1s) b2s)
- | _ -> (match b1,b2 with
- | VR_eq(v,n1),VR_eq(_,n2) ->
- if nexp_eq n1 n2 then b1 else VR_range(v,[Eq((Patt Parse_ast.Unknown),n1,n2)])
- | VR_eq(v,n),VR_range(_,ranges) |
- VR_range(v,ranges),VR_eq(_,n) -> VR_range(v,(Eq((Patt Parse_ast.Unknown),n,n))::ranges)
- | VR_range(v,ranges1),VR_range(_,ranges2) -> VR_range(v, List.rev_append (List.rev ranges1) ranges2)
- | VR_vec_eq(v,n1),VR_vec_eq(_,n2) ->
- if nexp_eq n1 n2 then b1 else VR_vec_r(v,[Eq((Patt Parse_ast.Unknown),n1,n2)])
- | VR_vec_eq(v,n),VR_vec_r(_,ranges) |
- VR_vec_r(v,ranges),VR_vec_eq(_,n) -> VR_vec_r(v,(Eq((Patt Parse_ast.Unknown),n,n)::ranges))
- | _ -> b1
- )::(merge b1s b2s) in
- Bounds ((merge b1s b2s),merged_map)
-
-let rec conforms_to_t d_env loosely within_coercion spec actual =
- (*let _ = Printf.eprintf "conforms_to_t called, evaluated loosely? %b & within_coercion? %b, with spec %s and actual %s\n"
- within_coercion loosely (t_to_string spec) (t_to_string actual) in*)
- let spec,_ = get_abbrev d_env spec in
- let actual,_ = get_abbrev d_env actual in
- match (spec.t,actual.t,loosely) with
- | (Tuvar _,_,true) -> true
- | (Ttup ss, Ttup acs,_) ->
- (List.length ss = List.length acs) && List.for_all2 (conforms_to_t d_env loosely within_coercion) ss acs
- | (Tid is, Tid ia,_) -> is = ia
- | (Tapp(is,tas), Tapp("register",[TA_typ t]),true) ->
- if is = "register" && (List.length tas) = 1
- then List.for_all2 (conforms_to_ta d_env loosely within_coercion) tas [TA_typ t]
- else conforms_to_t d_env loosely within_coercion spec t
- | (Tapp("vector",[TA_nexp bs;TA_nexp rs;TA_ord os;TA_typ ts]),
- Tapp("vector",[TA_nexp ba;TA_nexp ra;TA_ord oa;TA_typ ta]),_) ->
- conforms_to_t d_env loosely within_coercion ts ta
- && conforms_to_o loosely os oa
- && conforms_to_n false within_coercion eq_big_int rs ra
- | (Tapp("range",[TA_nexp bs;TA_nexp rs]),Tapp("range",[TA_nexp ba;TA_nexp ra]),_) -> true (*
- conforms_to_n true within_coercion le_big_int bs ba && conforms_to_n true within_coercion ge_big_int rs ra *)
- | (Tapp("atom",[TA_nexp n]),Tapp("range",[TA_nexp ba;TA_nexp ra]),_) -> true (*
- conforms_to_n true within_coercion le_big_int ba n && conforms_to_n true within_coercion ge_big_int n ra *)
- | (Tapp("range",[TA_nexp bs;TA_nexp rs]),Tapp("atom",[TA_nexp n]),_) -> true (*
- conforms_to_n true within_coercion le_big_int bs n && conforms_to_n true within_coercion ge_big_int rs n &&
- conforms_to_n true within_coercion ge_big_int bs n *)
- | (Tapp(is,tas), Tapp(ia, taa),_) ->
-(* let _ = Printf.eprintf "conforms to given two apps: %b, %b\n"
- (is = ia) (List.length tas = List.length taa) in*)
- (is = ia) && (List.length tas = List.length taa) &&
- (List.for_all2 (conforms_to_ta d_env loosely within_coercion) tas taa)
- | (Tid "bit", Tapp("vector",[_;_;_;TA_typ ti]), _) ->
- within_coercion &&
- conforms_to_t d_env loosely within_coercion spec ti
- | (Tabbrev(_,s),a,_) -> conforms_to_t d_env loosely within_coercion s actual
- | (s,Tabbrev(_,a),_) -> conforms_to_t d_env loosely within_coercion spec a
- | (_,_,_) -> false
-and conforms_to_ta d_env loosely within_coercion spec actual =
-(*let _ = Printf.eprintf "conforms_to_ta called, evaluated loosely? %b, with %s and %s\n"
- loosely (targ_to_string spec) (targ_to_string actual) in*)
- match spec,actual with
- | TA_typ s, TA_typ a -> conforms_to_t d_env loosely within_coercion s a
- | TA_nexp s, TA_nexp a -> conforms_to_n loosely within_coercion eq_big_int s a
- | TA_ord s, TA_ord a -> conforms_to_o loosely s a
- | TA_eft s, TA_eft a -> conforms_to_e loosely s a
- | _ -> false
-and conforms_to_n loosely within_coercion op spec actual =
-(* let _ = Printf.eprintf "conforms_to_n called, evaluated loosely? %b, with coercion? %b with %s and %s\n"
- loosely within_coercion (n_to_string spec) (n_to_string actual) in*)
- match (spec.nexp,actual.nexp,loosely,within_coercion) with
- | (Nconst si,Nconst ai,_,_) -> op si ai
- | (Nconst _,Nuvar _,false,false) -> false
- | _ -> true
-and conforms_to_o loosely spec actual =
- match (spec.order,actual.order,loosely) with
- | (Ouvar _,_,true) | (Oinc,Oinc,_) | (Odec,Odec,_) | (_, Ouvar _,_) -> true
- | _ -> false
-and conforms_to_e loosely spec actual =
- match (spec.effect,actual.effect,loosely) with
- | (Euvar _,_,true) -> true
- | (_,Euvar _,true) -> false
- | _ ->
- try begin ignore (effects_eq (Specc Parse_ast.Unknown) spec actual); true end with
- | _ -> false
-
-(*Is checking for structural equality amongst the types, building constraints for kind Nat.
- When considering two range type applications, will check for consistency instead of equality
- When considering two atom type applications, will expand into a range encompasing both when widen is true
-*)
-let rec type_consistent_internal co d_env enforce widen t1 cs1 t2 cs2 =
- let l = get_c_loc co in
- let t1,cs1' = get_abbrev d_env t1 in
- let t2,cs2' = get_abbrev d_env t2 in
- let cs1,cs2 = cs1@cs1',cs2@cs2' in
- let csp = cs1@cs2 in
- let t1_actual = match t1.t with | Tabbrev(_,t1) -> t1 | _ -> t1 in
- let t2_actual = match t2.t with | Tabbrev(_,t2) -> t2 | _ -> t2 in
-(* let _ = Printf.eprintf "type_consistent_internal called with, widen? %b, %s with actual %s and %s with actual %s\n"
- widen (t_to_string t1) (t_to_string t1_actual) (t_to_string t2) (t_to_string t2_actual) in*)
- match t1_actual.t,t2_actual.t with
- | Tvar v1,Tvar v2 ->
- if v1 = v2 then (t2,csp)
- else eq_error l ("Type variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified")
- | Tid v1,Tid v2 ->
- if v1 = v2 then (t2,csp)
- else eq_error l ("Types " ^ v1 ^ " and " ^ v2 ^ " do not match")
- | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tapp("range",[TA_nexp b2;TA_nexp r2;]) ->
- if (nexp_eq b1 b2)&&(nexp_eq r1 r2)
- then (t2,csp)
- else (t1, csp@[GtEq(co,enforce,b1,b2);LtEq(co,enforce,r1,r2)])
- | Tapp("atom",[TA_nexp a]),Tapp("range",[TA_nexp b1; TA_nexp r1]) ->
- (t1, csp@[GtEq(co,enforce,a,b1);LtEq(co,enforce,a,r1)])
- | Tapp("range",[TA_nexp b1; TA_nexp r1]),Tapp("atom",[TA_nexp a]) ->
- (t2, csp@[LtEq(co,Guarantee,b1,a);GtEq(co,Guarantee,r1,a)])
- | Tapp("atom",[TA_nexp a1]),Tapp("atom",[TA_nexp a2]) ->
- if nexp_eq a1 a2
- then (t2,csp)
- else if not(widen)
- then (t1, csp@[Eq(co,a1,a2)])
- else (match a1.nexp,a2.nexp with
- | Nconst i1, Nconst i2 ->
- if lt_big_int i1 i2
- then ({t= Tapp("range",[TA_nexp a1;TA_nexp a2])},csp)
- else ({t=Tapp ("range",[TA_nexp a2;TA_nexp a1])},csp)
- (*| Nconst _, Nuvar _ | Nuvar _, Nconst _->
- (t1, csp@[Eq(co,a1,a2)])*) (*TODO This is the correct constraint.
- However, without the proper support for In checks actually working,
- this will cause specs to not build*)
- | _ -> (*let nu1,nu2 = new_n (),new_n () in
- ({t=Tapp("range",[TA_nexp nu1;TA_nexp nu2])},
- csp@[LtEq(co,enforce,nu1,a1);LtEq(co,enforce,nu1,a2);LtEq(co,enforce,a1,nu2);LtEq(co,enforce,a2,nu2)])*)
- (t1, csp@[LtEq(co,enforce,a1,a2);(GtEq(co,enforce,a1,a2))]))
- (*EQ is the right thing to do, but see above. Introducing new free vars here is bad*)
- | Tapp("vector",[TA_nexp b1; TA_nexp l1; ord; ty1]),Tapp("vector",[TA_nexp b2; TA_nexp l2; ord2; ty2]) ->
- let cs = if widen then [Eq(co,l1,l2)] else [Eq(co,l1,l2);Eq(co,b1,b2)] in
- (t2, cs@(type_arg_eq co d_env enforce widen ord ord2)@(type_arg_eq co d_env enforce widen ty1 ty2))
- | Tapp(id1,args1), Tapp(id2,args2) ->
- (*let _ = Printf.eprintf "checking consistency of %s and %s\n" id1 id2 in*)
- let la1,la2 = List.length args1, List.length args2 in
- if id1=id2 && la1 = la2
- then (t2,csp@(List.flatten (List.map2 (type_arg_eq co d_env enforce widen) args1 args2)))
- else eq_error l ("Type application of " ^ (t_to_string t1) ^ " and " ^ (t_to_string t2) ^ " must match")
- | Tfn(tin1,tout1,_,effect1),Tfn(tin2,tout2,_,effect2) ->
- let (tin,cin) = type_consistent co d_env Require widen tin1 tin2 in
- let (tout,cout) = type_consistent co d_env Guarantee widen tout1 tout2 in
- let _ = effects_eq co effect1 effect2 in
- (t2,csp@cin@cout)
- | Ttup t1s, Ttup t2s ->
- (t2,csp@(List.flatten (List.map snd (List.map2 (type_consistent co d_env enforce widen) t1s t2s))))
- | Tuvar _, t -> equate_t t1 t2; (t1,csp)
- (*| Tapp("range",[TA_nexp b;TA_nexp r]),Tuvar _ ->
- let b2,r2 = new_n (), new_n () in
- let t2' = {t=Tapp("range",[TA_nexp b2;TA_nexp r2])} in
- equate_t t2 t2';
- (t2,csp@[GtEq(co,enforce,b,b2);LtEq(co,enforce,r,r2)])*)
- | Tapp("atom",[TA_nexp a]),Tuvar _ ->
- if widen
- then
- let b,r = new_n (), new_n () in
- let t2' = {t=Tapp("range",[TA_nexp b;TA_nexp r])} in
- begin equate_t t2 t2';
- (t2,csp@[GtEq(co,enforce,a,b);LtEq(co,enforce,a,r)]) end
- else begin equate_t t2 t1; (t2,csp) end
- | t,Tuvar _ -> equate_t t2 t1; (t2,csp)
- | _,_ -> eq_error l ("Type mismatch found " ^ (t_to_string t1) ^ " but expected a " ^ (t_to_string t2))
-
-and type_arg_eq co d_env enforce widen ta1 ta2 =
- match ta1,ta2 with
- | TA_typ t1,TA_typ t2 -> snd (type_consistent co d_env enforce widen t1 t2)
- | TA_nexp n1,TA_nexp n2 -> if nexp_eq n1 n2 then [] else [Eq(co,n1,n2)]
- | TA_eft e1,TA_eft e2 -> (ignore(effects_eq co e1 e2); [])
- | TA_ord o1,TA_ord o2 -> (ignore(order_eq co o1 o2);[])
- | _,_ -> eq_error (get_c_loc co) "Type arguments must be of the same kind"
-
-and type_consistent co d_env enforce widen t1 t2 =
- type_consistent_internal co d_env enforce widen t1 [] t2 []
-
-let rec type_coerce_internal co d_env enforce is_explicit widen bounds t1 cs1 e t2 cs2 =
- let l = get_c_loc co in
- let t1,cs1' = get_abbrev d_env t1 in
- let t2,cs2' = get_abbrev d_env t2 in
- let t1_actual = match t1.t with | Tabbrev(_,t1) -> t1 | _ -> t1 in
- let t2_actual = match t2.t with | Tabbrev(_,t2) -> t2 | _ -> t2 in
- let cs1,cs2 = cs1@cs1',cs2@cs2' in
- let csp = cs1@cs2 in
- (*let _ = Printf.eprintf "called type_coerce_internal is_explicit %b, widen %b, turning %s with actual %s into %s with actual %s\n"
- is_explicit widen (t_to_string t1) (t_to_string t1_actual) (t_to_string t2) (t_to_string t2_actual) in*)
- match t1_actual.t,t2_actual.t with
-
- (* Toptions is an internal constructor representing the type we're
- going to be casting to and the natural type. source-language type
- annotations might be demanding a coercion, so this checks
- conformance and adds a coercion if needed *)
-
- | Toptions(to1,Some to2),_ ->
- if (conforms_to_t d_env false true to1 t2_actual || conforms_to_t d_env false true to2 t2_actual)
- then begin t1_actual.t <- t2_actual.t; (t2,csp,pure_e,e) end
- else eq_error l ("Neither " ^ (t_to_string to1) ^
- " nor " ^ (t_to_string to2) ^ " can match expected type " ^ (t_to_string t2))
- | Toptions(to1,None),_ ->
- if is_explicit
- then type_coerce_internal co d_env enforce is_explicit widen bounds to1 cs1 e t2 cs2
- else (t2,csp,pure_e,e)
- | _,Toptions(to1,Some to2) ->
- if (conforms_to_t d_env false true to1 t1_actual || conforms_to_t d_env false true to2 t1_actual)
- then begin t2_actual.t <- t1_actual.t; (t1,csp,pure_e,e) end
- else eq_error l ((t_to_string t1) ^ " can match neither expected type " ^
- (t_to_string to1) ^ " nor " ^ (t_to_string to2))
- | _,Toptions(to1,None) ->
- if is_explicit
- then type_coerce_internal co d_env enforce is_explicit widen bounds t1_actual cs1 e to1 cs2
- else (t1,csp,pure_e,e)
-
- (* recursive coercions to components of tuples. They may be
- complex expressions, not top-level tuples, so we sometimes
- need to add a pattern match. At present we do that almost
- always, unnecessarily often. The any_coerced is wrong *)
- | Ttup t1s, Ttup t2s ->
- let tl1,tl2 = List.length t1s,List.length t2s in
- if tl1=tl2 then
- let ids = List.map (fun _ -> Id_aux(Id (new_id ()),l)) t1s in
- let vars = List.map2 (fun i t -> E_aux(E_id(i),(l,Base(([],t),Emp_local,[],pure_e,pure_e,nob)))) ids t1s in
- let (coerced_ts,cs,efs,coerced_vars,any_coerced) =
- List.fold_right2 (fun v (t1,t2) (ts,cs,efs,es,coerced) ->
- let (t',c',ef,e') = type_coerce co d_env enforce is_explicit widen bounds t1 v t2 in
- ((t'::ts),c'@cs,union_effects ef efs,(e'::es), coerced || (v == e')))
- vars (List.combine t1s t2s) ([],[],pure_e,[],false) in
- if (not any_coerced) then (t2,cs,pure_e,e)
- else let e' = E_aux(E_case(e,
- [(Pat_aux(Pat_exp
- (P_aux(P_tup
- (List.map2
- (fun i t ->
- P_aux(P_id i,
- (l,
- (*TODO should probably link i and t in bindings*)
- (Base(([],t),Emp_local,[],pure_e,pure_e,nob)))))
- ids t1s),(l,Base(([],t1),Emp_local,[],pure_e,pure_e,nob))),
- E_aux(E_tuple coerced_vars,
- (l,Base(([],t2),Emp_local,cs,pure_e,pure_e,nob)))),
- (l,Base(([],t2),Emp_local,[],pure_e,pure_e,nob))))]),
- (l,(Base(([],t2),Emp_local,[],pure_e,pure_e,nob)))) in
- (t2,csp@cs,efs,e')
- else eq_error l ("Found a tuple of length " ^ (string_of_int tl1) ^
- " but expected a tuple of length " ^ (string_of_int tl2))
-
-
- (* all the Tapp cases *)
- | Tapp(id1,args1),Tapp(id2,args2) ->
- if id1=id2 && (id1 <> "vector")
- (* no coercion needed, so fall back to consistency *)
- then let t',cs' = type_consistent co d_env enforce widen t1 t2 in (t',cs',pure_e,e)
- else (match id1,id2,is_explicit with
-
- (* can coerce between two vectors just to change the start index *)
- | "vector","vector",_ ->
- (match args1,args2 with
- | [TA_nexp b1;TA_nexp r1;TA_ord o1;TA_typ t1i],
- [TA_nexp b2;TA_nexp r2;TA_ord o2;TA_typ t2i] ->
- (match o1.order,o2.order with
- | Oinc,Oinc | Odec,Odec -> ()
- | Oinc,Ouvar _ | Odec,Ouvar _ -> equate_o o2 o1;
- | Ouvar _,Oinc | Ouvar _, Odec -> equate_o o1 o2;
- | _,_ -> equate_o o1 o2);
- let cs = csp@[Eq(co,r1,r2)]@(if widen then [] else [Eq(co,b1,b2)]) in
- let t',cs' = type_consistent co d_env enforce widen t1i t2i in
- let tannot = Base(([],t2),Emp_local,cs@cs',pure_e,(get_cummulative_effects (get_eannot e)),nob) in
- let e' = E_aux(E_internal_cast ((l,(Base(([],t2),Emp_local,[],pure_e,pure_e,nob))),e),(l,tannot)) in
- (t2,cs@cs',pure_e,e')
- | _ -> raise (Reporting_basic.err_unreachable l "vector is not properly kinded"))
-
- (* coercion from a bit vector into a number *)
- | "vector","range",_ ->
- (match args1,args2 with
- | [TA_nexp b1;TA_nexp r1;TA_ord _;TA_typ {t=Tid "bit"}],
- [TA_nexp b2;TA_nexp r2;] ->
- let cs = [Eq(co,b2,n_zero);LtEq(co,Guarantee,mk_sub (mk_2n(r1)) n_one,r2)] in
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "unsigned",l)),[e]),
- (l,
- cons_tag_annot_efr t2 (External (Some "unsigned"))
- cs (get_cummulative_effects (get_eannot e)))))
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ ->
- eq_error l "Cannot convert a vector to a range without an order"
- | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ ->
- eq_error l "Cannot convert non-bit vector into an range"
- | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded"))
-
- (* similar to vector/range case *)
- | "vector","atom",_ ->
- (match args1,args2 with
- | [TA_nexp b1;TA_nexp r1;TA_ord _;TA_typ {t=Tid "bit"}],
- [TA_nexp b2] ->
- let cs = [GtEq(co,Guarantee,b2,n_zero);LtEq(co,Guarantee,b2,mk_sub (mk_2n(r1)) n_one)] in
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "unsigned",l)),[e]),
- (l,
- cons_tag_annot_efr t2 (External (Some "unsigned"))
- cs (get_cummulative_effects (get_eannot e)))))
- | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ ->
- eq_error l "Cannot convert non-bit vector into an range"
- | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded"))
-
- (* coercion from number into bit vector, if there's an explicit type annotation in the source (the "true") *)
- (* this can be lossy, if it doesn't fit into that vector, so we want to require the user to specify the vector size. It was desired by some users, but maybe should be turned back into an error and an explicit truncate function be used *)
- | "range","vector",true ->
- (match args2,args1 with
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Oinc};TA_typ {t=Tid "bit"}],
- [TA_nexp b2;TA_nexp r2;] ->
- let cs = [] (*[LtEq(co,Guarantee,r2,mk_sub {nexp=N2n(r1,None)} n_one)]
- (*This constraint failing should be a warning, but truncation is ok*)*) in
- let tannot = (l, Base(([],t2), External (Some "to_vec_inc"), cs,
- pure_e, (get_cummulative_effects (get_eannot e)), bounds)) in
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_inc",l)),
- [(E_aux(E_internal_exp(tannot), tannot));e]),tannot))
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Odec};TA_typ {t=Tid "bit"}],
- [TA_nexp b2;TA_nexp r2;] ->
- let cs = [] (* See above [LtEq(co,Guarantee,r2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in
- let tannot = (l, Base(([],t2),External (Some "to_vec_dec"),
- cs, pure_e, (get_cummulative_effects (get_eannot e)),bounds)) in
- (*let _ = Printf.eprintf "Generating to_vec_dec call: bounds are %s\n" (bounds_to_string bounds) in*)
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_dec",l)),
- [(E_aux(E_internal_exp(tannot), tannot)); e]),tannot))
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ ->
- eq_error l "Cannot convert a range to a vector without an order"
- | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ ->
- eq_error l "Cannot convert a range into a non-bit vector"
- | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded"))
-
- (* similar to number to bit vector case *)
- | "atom","vector",true ->
- (match args2,args1 with
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Oinc};TA_typ {t=Tid "bit"}],
- [TA_nexp b2] ->
- let cs = [](*[LtEq(co,Guarantee,b2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in
- let tannot = (l, Base(([],t2), External(Some "to_vec_inc"), cs, pure_e,
- (get_cummulative_effects (get_eannot e)), bounds)) in
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_inc",l)),
- [(E_aux(E_internal_exp(tannot), tannot));e]),tannot))
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Odec};TA_typ {t=Tid "bit"}],
- [TA_nexp b2] ->
- let cs = [](*[LtEq(co,Guarantee,b2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in
- let tannot = (l, Base(([],t2), External (Some "to_vec_dec"), cs, pure_e,
- (get_cummulative_effects (get_eannot e)), bounds)) in
- (*let _ = Printf.eprintf "Generating to_vec_dec call: bounds are %s\n" (bounds_to_string bounds) in*)
- (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_dec",l)),
- [(E_aux(E_internal_exp(tannot), tannot)); e]),tannot))
- | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ ->
- eq_error l "Cannot convert a range to a vector without an order"
- | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ ->
- eq_error l "Cannot convert a range into a non-bit vector"
- | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded"))
-
- (* implicit dereference of a register, from register<t> to t, and then perhaps also from t to the expected type *)
- | "register",_,_ ->
- (match args1 with
- | [TA_typ t] ->
- (*TODO Should this be an internal cast?
- Probably, make sure it doesn't interfere with the other internal cast and get removed *)
- (*let _ = Printf.eprintf "Adding cast to remove register read: t %s ; t2 %s\n"
- (t_to_string t) (t_to_string t2) in*)
- let efc = (BE_aux (BE_rreg, l)) in
- let ef = add_effect efc pure_e in
- let new_e = E_aux(E_cast(t_to_typ unit_t,e),
- (l,Base(([],t),External None,[],
- ef,add_effect efc (get_cummulative_effects (get_eannot e)),nob))) in
- let (t',cs,ef',e) = type_coerce co d_env Guarantee is_explicit widen bounds t new_e t2 in
- (t',cs,union_effects ef ef',e)
- | _ -> raise (Reporting_basic.err_unreachable l "register is not properly kinded"))
-
- (* otherwise in Tapp case, fall back on type_consistent *)
- | _,_,_ ->
- let t',cs' = type_consistent co d_env enforce widen t1 t2 in (t',cs',pure_e,e))
-
- (* bit vector of length 1 to bit *)
- | Tapp("vector",[TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ {t=Tid "bit"}]),Tid("bit") ->
- let cs = [Eq(co,r1,n_one)] in
- (t2,cs,pure_e,E_aux((E_app ((Id_aux (Id "most_significant", l)), [e])),
- (l, cons_tag_annot_efr t2 (External (Some "most_significant"))
- cs (get_cummulative_effects (get_eannot e)))))
-
- (* bit to a bitvector of length 1 *)
- | Tid("bit"),Tapp("vector",[TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ {t=Tid "bit"}]) ->
- let cs = [Eq(co,r1,n_one)] in
- (t2,cs,pure_e,E_aux(E_vector [e], (l, constrained_annot_efr t2 cs (get_cummulative_effects (get_eannot e)))))
-
- (* bit to a number range (including 0..1) *)
- | Tid("bit"),Tapp("range",[TA_nexp b1;TA_nexp r1]) ->
- let t',cs'= type_consistent co d_env enforce false {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} t2 in
- (t2,cs',pure_e,
- E_aux(E_case (e,[Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_zero,l)),(l,simple_annot t1)),
- E_aux(E_lit(L_aux(L_num 0,l)),(l,simple_annot t2))),
- (l,simple_annot t2));
- Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_one,l)),(l,simple_annot t1)),
- E_aux(E_lit(L_aux(L_num 1,l)),(l,simple_annot t2))),
- (l,simple_annot t2));]),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
-
-
- (* similar to above, bit to a singleton number range *)
- | Tid("bit"),Tapp("atom",[TA_nexp b1]) ->
- let t',cs'= type_consistent co d_env enforce false t2 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in
- (t2,cs',pure_e,
- E_aux(E_case (e,[Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_zero,l)),(l,simple_annot t1)),
- E_aux(E_lit(L_aux(L_num 0,l)),(l,simple_annot t2))),
- (l,simple_annot t2));
- Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_one,l)),(l,simple_annot t1)),
- E_aux(E_lit(L_aux(L_num 1,l)),(l,simple_annot t2))),
- (l,simple_annot t2));]),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
-
-
- (* number range to a bit *)
- | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tid("bit") ->
- let t',cs'= type_consistent co d_env enforce false t1 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in
- let efr = get_cummulative_effects (get_eannot e)
- in (t2,cs',pure_e,E_aux(E_if(E_aux(E_app(Id_aux(Id "is_one",l),[e]),
- (l, tag_annot_efr bit_t (External (Some "is_one")) efr)),
- E_aux(E_lit(L_aux(L_one,l)),(l,simple_annot bit_t)),
- E_aux(E_lit(L_aux(L_zero,l)),(l,simple_annot bit_t))),
- (l,simple_annot_efr bit_t efr)))
-
- (* similar to above *)
- | Tapp("atom",[TA_nexp b1]),Tid("bit") ->
- let t',cs'= type_consistent co d_env enforce false t1 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in
- let efr = get_cummulative_effects (get_eannot e)
- in (t2,cs',pure_e,E_aux(E_if(E_aux(E_app(Id_aux(Id "is_one",l),[e]),(l, tag_annot_efr bit_t (External None) efr)),
- E_aux(E_lit(L_aux(L_one,l)),(l,simple_annot bit_t)),
- E_aux(E_lit(L_aux(L_zero,l)),(l,simple_annot bit_t))),
- (l,simple_annot_efr bit_t efr)))
-
- (* number range to an enumeration type *)
- | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tid(i) ->
- (match Envmap.apply d_env.enum_env i with
- | Some(enums) ->
- let num_enums = List.length enums in
- (t2,[GtEq(co,Require,b1,n_zero);LtEq(co,Require,r1,mk_c(big_int_of_int num_enums))],pure_e,
- E_aux(E_case(e,
- List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)), (l,simple_annot t1)),
- E_aux(E_id(Id_aux(Id a,l)),
- (l, tag_annot t2 (Enum num_enums)))),
- (l,simple_annot t2))) enums),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
- | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2)))
-
- (* similar to above *)
- | Tapp("atom",[TA_nexp b1]),Tid(i) ->
- (match Envmap.apply d_env.enum_env i with
- | Some(enums) ->
- let num_enums = List.length enums in
- (t2,[GtEq(co,Require,b1,n_zero);
- LtEq(co,Require,b1,mk_c(big_int_of_int num_enums))],pure_e,
- E_aux(E_case(e,
- List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)),(l, simple_annot t1)),
- E_aux(E_id(Id_aux(Id a,l)),
- (l, tag_annot t2 (Enum num_enums)))),
- (l,simple_annot t2))) enums),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
- | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2)))
-
- (* bit vector to an enumeration type *)
- | Tapp("vector", [TA_nexp _; TA_nexp size; _; TA_typ {t= Tid "bit"}]), Tid(i) ->
- (match Envmap.apply d_env.enum_env i with
- | Some(enums) ->
- let num_enums = List.length enums in
- (t2,[LtEq(co,Require,mk_sub (mk_2n size) n_one, mk_c_int num_enums)], pure_e,
- E_aux(E_case (E_aux(E_app((Id_aux(Id "unsigned",l)),[e]),
- (l,
- tag_annot_efr (mk_range n_zero (mk_sub (mk_2n size) n_one)) (External (Some "unsigned"))
- (get_cummulative_effects (get_eannot e)))),
- List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)), (l,simple_annot t1)),
- E_aux(E_id(Id_aux(Id a,l)),
- (l, tag_annot t2 (Enum num_enums)))),
- (l,simple_annot t2))) enums),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
- | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2)))
-
- (* enumeration type to number range *)
- | Tid(i),Tapp("range",[TA_nexp b1;TA_nexp r1;]) ->
- (match Envmap.apply d_env.enum_env i with
- | Some(enums) ->
- (t2,[Eq(co,b1,n_zero);GtEq(co,Guarantee,r1,mk_c(big_int_of_int (List.length enums)))],pure_e,
- E_aux(E_case(e,
- List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_id(Id_aux(Id a,l)), (l,simple_annot t1)),
- E_aux(E_lit(L_aux((L_num i),l)),(l,simple_annot t2))),
- (l,simple_annot t2))) enums),
- (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e)))))
- | None -> eq_error l ("Type mismatch: " ^ (t_to_string t1) ^ " , " ^ (t_to_string t2)))
-
-
- (* probably there's a missing enumeration type to singleton number range *)
-
- (* fall through to type_consistent *)
- | _,_ -> let t',cs = type_consistent co d_env enforce widen t1 t2 in (t',cs,pure_e,e)
-
-and type_coerce co d_env enforce is_explicit widen bounds t1 e t2 =
- type_coerce_internal co d_env enforce is_explicit widen bounds t1 [] e t2 [];;
-
-let rec select_overload_variant d_env params_check get_all variants actual_type =
- match variants with
- | [] -> []
- | NoTyp::variants | Overload _::variants ->
- select_overload_variant d_env params_check get_all variants actual_type
- | Base((parms,t_orig),tag,cs,ef,_,bindings)::variants ->
- (*let _ = Printf.eprintf "About to check a variant %s\n" (t_to_string t_orig) in*)
- let t,cs,ef,_ = if parms=[] then t_orig,cs,ef,Envmap.empty else subst parms false false t_orig cs ef in
- (*let _ = Printf.eprintf "And after substitution %s\n" (t_to_string t) in*)
- let t,cs' = get_abbrev d_env t in
- let recur _ = select_overload_variant d_env params_check get_all variants actual_type in
- (match t.t with
- | Tfn(a,r,_,e) ->
- let is_matching =
- if params_check then conforms_to_t d_env true false a actual_type
- else match actual_type.t with
- | Toptions(at1,Some at2) ->
- (conforms_to_t d_env false true at1 r || conforms_to_t d_env false true at2 r)
- | Toptions(at1,None) -> conforms_to_t d_env false true at1 r
- | _ -> conforms_to_t d_env true true actual_type r in
- (*let _ = Printf.eprintf "Checked a variant, matching? %b\n" is_matching in*)
- if is_matching
- then (Base(([],t),tag,cs@cs',ef,pure_e,bindings))::(if get_all then (recur ()) else [])
- else recur ()
- | _ -> recur () )
-
-let rec split_conditional_constraints = function
- | [] -> [],[],[]
- | Predicate(co,cp,cn)::cs ->
- let (csa,csp,csn) = split_conditional_constraints cs in
- (csa,cp::csp, cn::csn)
- | c::cs ->
- let (csa,csp,csn) = split_conditional_constraints cs in
- (c::csa,csp, csn)
-
-let rec in_constraint_env = function
- | [] -> []
- | InS(co,nexp,vals)::cs ->
- (nexp,(List.map (fun c -> mk_c(big_int_of_int c)) vals))::(in_constraint_env cs)
- | In(co,i,vals)::cs ->
- (mk_nv i,(List.map (fun c -> mk_c(big_int_of_int c)) vals))::(in_constraint_env cs)
- | _::cs -> in_constraint_env cs
-
-let rec contains_var nu n =
- match n.nexp with
- | Nvar _ | Nuvar _ -> nexp_eq_check nu n
- | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> false
- | Nadd(n1,n2) | Nsub(n1,n2) | Nmult(n1,n2) -> contains_var nu n1 || contains_var nu n2
- | Nneg n | N2n(n,_) | Npow(n,_) | Nid(_,n) -> contains_var nu n
-
-let rec contains_in_vars in_env n =
- match in_env with
- | [] -> None
- | (ne,vals)::in_env ->
- (match contains_in_vars in_env n with
- | None -> if contains_var ne n then Some [ne,vals] else None
- | Some(e_env) -> if contains_var ne n then Some((ne,vals)::e_env) else Some(e_env))
-
-let rec get_nuvars n =
- match n.nexp with
- | Nconst _ | Nvar _ | Nid _ | Npos_inf | Nneg_inf | Ninexact-> []
- | Nuvar _ -> [n]
- | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (get_nuvars n1)@(get_nuvars n2)
- | Nneg n | N2n(n,_) | Npow(n,_) -> get_nuvars n
-
-let rec get_all_nuvars_cs cs = match cs with
- | [] -> Var_set.empty
- | (Eq(_,n1,n2) | GtEq(_,_,n1,n2) | LtEq(_,_,n1,n2) | Gt(_,_,n1,n2) | Lt(_,_,n1,n2))::cs ->
- let s = get_all_nuvars_cs cs in
- let n1s = get_nuvars n1 in
- let n2s = get_nuvars n2 in
- List.fold_right (fun n s -> Var_set.add n s) (n1s@n2s) s
- | Predicate(_,cp,cn)::cs ->
- Var_set.union (get_all_nuvars_cs [cp;cn]) (get_all_nuvars_cs cs)
- | CondCons(_,_,_,pats,exps)::cs ->
- let s = get_all_nuvars_cs cs in
- let ps = get_all_nuvars_cs pats in
- let es = get_all_nuvars_cs exps in
- Var_set.union s (Var_set.union ps es)
- | BranchCons(_,_,c)::cs ->
- Var_set.union (get_all_nuvars_cs c) (get_all_nuvars_cs cs)
- | _::cs -> get_all_nuvars_cs cs
-
-let rec subst_nuvars nus n =
- let is_imp_param = n.imp_param in
- let new_n =
- match n.nexp with
- | Nconst _ | Nvar _ | Nid _ | Npos_inf | Nneg_inf | Ninexact -> n
- | Nuvar _ ->
- (match Nexpmap.apply nus n with
- | None -> n
- | Some nc -> nc)
- | Nmult(n1,n2) -> mk_mult (subst_nuvars nus n1) (subst_nuvars nus n2)
- | Nadd(n1,n2) -> mk_add (subst_nuvars nus n1) (subst_nuvars nus n2)
- | Nsub(n1,n2) -> mk_sub (subst_nuvars nus n1) (subst_nuvars nus n2)
- | Nneg n -> mk_neg (subst_nuvars nus n)
- | N2n(n,None) -> mk_2n (subst_nuvars nus n)
- | N2n(n,Some(i)) -> mk_2nc (subst_nuvars nus n) i
- | Npow(n,i) -> mk_pow (subst_nuvars nus n) i in
- (if is_imp_param then set_imp_param new_n);
- new_n
-
-let rec subst_nuvars_cs nus cs =
- match cs with
- | [] -> []
- | Eq(l,n1,n2)::cs -> Eq(l,subst_nuvars nus n1,subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | NtEq(l,n1,n2)::cs -> NtEq(l, subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | GtEq(l,enforce,n1,n2)::cs -> GtEq(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | Gt(l,enforce,n1,n2)::cs -> Gt(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | LtEq(l,enforce,n1,n2)::cs -> LtEq(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | Lt(l,enforce,n1,n2)::cs -> Lt(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs)
- | In(l,s,ns)::cs -> In(l,s,ns)::(subst_nuvars_cs nus cs)
- | InS(l,n,ns)::cs -> InS(l,subst_nuvars nus n,ns)::(subst_nuvars_cs nus cs)
- | Predicate(l, cp,cn)::cs ->
- Predicate(l, List.hd(subst_nuvars_cs nus [cp]), List.hd(subst_nuvars_cs nus [cn]))::(subst_nuvars_cs nus cs)
- | CondCons(l,kind,my_substs,cs_p,cs_e)::cs ->
- CondCons(l,kind,my_substs,subst_nuvars_cs nus cs_p,subst_nuvars_cs nus cs_e)::(subst_nuvars_cs nus cs)
- | BranchCons(l,possible_invars,bs)::cs ->
- BranchCons(l,possible_invars,subst_nuvars_cs nus bs)::(subst_nuvars_cs nus cs)
-
-let rec constraint_size = function
- | [] -> 0
- | c::cs ->
- (match c with
- | CondCons(_,_,_,ps,es) -> constraint_size ps + constraint_size es
- | BranchCons(_,_,bs) -> constraint_size bs
- | _ -> 1) + constraint_size cs
-
-let freshen_constraints cs =
- let nuvars =
- Var_set.fold (fun n map ->
- let ne = new_n() in
- (*let _ = Printf.eprintf "mapping %s to %s\n%!" (n_to_string n) (n_to_string ne) in*)
- Nexpmap.insert map (n,ne)) (get_all_nuvars_cs cs) Nexpmap.empty in
- (subst_nuvars_cs nuvars cs,nuvars)
-
-let rec prepare_constraints = function
- | [] -> []
- | CondCons(l,(Positive|Negative|Switch as kind),None,cs_p,cs_e)::cs ->
- let (new_pred_cs,my_substs) = freshen_constraints cs_p in
- let new_expr_cs = subst_nuvars_cs my_substs cs_e in
- CondCons(l,kind,Some(my_substs),new_pred_cs,(prepare_constraints new_expr_cs))::(prepare_constraints cs)
- | CondCons(l,Solo,None,cs_p,cs_e)::cs ->
- CondCons(l,Solo,None,cs_p,(prepare_constraints cs_e))::(prepare_constraints cs)
- | BranchCons(l,_,bs)::cs -> BranchCons(l,None, prepare_constraints bs)::(prepare_constraints cs)
- | c::cs -> c::(prepare_constraints cs)
-
-let nexpmap_to_string nmap =
- Nexpmap.fold (fun acc k v ->
- match v with
- | One n -> "(" ^ n_to_string k ^ " |-> " ^ n_to_string n ^ ") " ^ acc
- | Two(n1,n2) -> "(" ^ n_to_string k ^ " |-> (" ^ n_to_string n1 ^ ", or " ^ n_to_string n2 ^ ")) " ^ acc
- | Many ns -> "(" ^ n_to_string k ^ " |-> (" ^ string_of_list ", " n_to_string ns ^ ") : " ^ (string_of_list ", " (fun n -> if is_all_nuvar n then "true" else "false") ns) ^ ") " ^ acc) "" nmap
-
-let rec make_merged_constraints acc = function
- | [] -> acc
- | c::cs ->
- (* let _ = Printf.eprintf "merging constraints acc thus far is %s\n%!" (nexpmap_to_string acc) in*)
- make_merged_constraints
- (Nexpmap.fold
- (fun acc k v ->
-(* let _ = Printf.eprintf "folding over c: we have %s |-> %s for acc of %s\n%!"
- (n_to_string k) (n_to_string v) (nexpmap_to_string acc) in*)
- match Nexpmap.apply acc k with
- | None -> Nexpmap.insert acc (k, One v)
- | Some(One v') -> Nexpmap.insert (Nexpmap.remove acc k) (k, Two(v,v'))
- | Some(Two(v',v'')) -> Nexpmap.insert (Nexpmap.remove acc k) (k,Many [v;v';v''])
- | Some(Many vs) -> Nexpmap.insert (Nexpmap.remove acc k) (k,Many (v::vs))) acc c)
- cs
-
-let merge_branch_constraints merge_nuvars constraint_sets =
- (*let _ = Printf.eprintf "merge_branch_constraints called\n%!" in*)
- (*Separate variables into only occurs in one set, or occurs in multiple sets*)
- (*assumes k and n outermost and all nuvar*)
- let conditionally_set k n =
- not(merge_nuvars) || ((occurs_in_nexp k n) || (occurs_in_nexp n k) || equate_n k n || equate_n n k) in
- (*This function assumes n outermost and k all nuvar;
- inserts a new nuvar at bottom, and an eq to k for non-nuvar*)
- let conditionally_lift_to_nuvars_on_merge k n =
- if not(merge_nuvars) || (is_all_nuvar n && conditionally_set k n)
- then [],None
- else
- let new_nuvar = new_n () in
- let new_temp = new_n () in
- match first_non_nu n with
- | Some n' ->
- new_temp.nexp <- n'.nexp; (*Save equation*)
- n'.nexp <- new_nuvar.nexp; (*Put a nuvar in place*)
- [Eq(Patt(Parse_ast.Unknown),k,new_temp)], Some(Nexpmap.from_list [k,new_temp])
- | None -> [],None
- in
- let merged_constraints = make_merged_constraints Nexpmap.empty constraint_sets in
- let merge_walker (sc,new_cs,new_map) k v = match v with
- | One n ->
- (*let _ = Printf.eprintf "Variables in one path: merge_nuvars %b, key %s, one %s\n%!"
- merge_nuvars (n_to_string k) (n_to_string n) in*)
- let k,n = get_outer_most k, get_outer_most n in
- if (is_all_nuvar k || is_all_nuvar n) && conditionally_set k n
- then (sc,new_cs,new_map)
- else (sc, (Eq(Patt(Parse_ast.Unknown),k,n))::new_cs,new_map)
- | Two(n1,n2) ->
- (*let _ = Printf.eprintf "Variables in two paths: merge_nuvars %b, key %s, n1 %s, n2 %s\n%!"
- merge_nuvars (n_to_string k) (n_to_string n1) (n_to_string n2) in*)
- let k,n1,n2 = get_outer_most k, get_outer_most n1, get_outer_most n2 in
- let all_nk, all_nn1, all_nn2 = is_all_nuvar k, is_all_nuvar n1, is_all_nuvar n2 in
- if all_nk && all_nn1 && all_nn2
- then
- let set1,set2 = conditionally_set k n1, conditionally_set k n2 in
- if set1 && set2 then sc,new_cs,new_map
- else (Nexpmap.insert sc (k,v),new_cs,new_map)
- else (if all_nk
- then
- let ncs1,nm1 = conditionally_lift_to_nuvars_on_merge k n1 in
- let ncs2,nm2 = conditionally_lift_to_nuvars_on_merge k n2 in
- let set1,set2 = conditionally_set k n1, conditionally_set k n2 in
- if set1 && set2
- then sc,ncs1@ncs2@new_cs,merge_option_maps new_map (merge_option_maps nm1 nm2)
- else (Nexpmap.insert sc (k,v),new_cs,merge_option_maps new_map (merge_option_maps nm1 nm2))
- else (Nexpmap.insert sc (k,v),new_cs,new_map))
- | Many ns ->
- (*(if merge_nuvars then
- let _ = Printf.eprintf "Variables in many paths: merge_nuvars %b, key %s, ["
- merge_nuvars (n_to_string k) in
- let _ = List.iter (fun n -> Printf.eprintf "%s ;" (n_to_string n)) ns in
- let _ = Printf.eprintf "]\n%!" in
- let _ = Printf.eprintf "Is all nuvar? %b\n%!"
- (List.for_all is_all_nuvar (List.map get_outer_most ns)) in ());*)
- let k, ns = get_outer_most k, List.map get_outer_most ns in
- let is_all_nuvars = List.for_all is_all_nuvar ns in
- if not(merge_nuvars)
- then Nexpmap.insert sc (k,v),new_cs,new_map
- else if is_all_nuvars
- then if List.for_all (fun i -> i) (List.map (conditionally_set k) ns)
- then (sc,new_cs,new_map)
- else (Nexpmap.insert sc (k,v),new_cs,new_map)
- else
- let rec all_eq = function
- | [] | [_] -> true
- | n1::n2::ns ->
- (nexp_eq n1 n2) && all_eq (n2::ns)
- in
- if (all_eq ns) && not(ns=[])
- then if List.for_all (fun i -> i) (List.map (conditionally_set k) ns)
- then (sc,new_cs,new_map)
- else (Nexpmap.insert sc (k,v),new_cs,new_map)
- else
- let sets = List.map (conditionally_lift_to_nuvars_on_merge k) ns in
- let css = (List.flatten (List.map fst sets))@ new_cs in
- let map = List.fold_right merge_option_maps (List.map snd sets) new_map in
- (Nexpmap.insert sc (k,v),css, map) in
- let shared_path_distinct_constraints = Nexpmap.fold merge_walker (Nexpmap.empty,[],None) merged_constraints in
- (*let _ = if merge_nuvars then
- Printf.eprintf "merge branch constraints: shared var mappings after merge %s\n%!"
- (nexpmap_to_string merged_constraints) in*)
- if merge_nuvars then Nexpmap.fold merge_walker (Nexpmap.empty,[],None) merged_constraints
- else
- shared_path_distinct_constraints
-
-let rec extract_path_substs = function
- | [] -> [],[]
- | CondCons(l,k,Some(substs),ps,es)::cs ->
- let set v n = match n.nexp with
- | Nuvar _ -> ignore(equate_n n v)
- | _ -> if nexp_eq n v then () else assert false (*Get a location to here*)
- in
- let updated_substs =
- Nexpmap.fold (fun substs key newvar ->
- (*let _ = Printf.eprintf "building substs sets: %s |-> %s\n" (n_to_string key) (n_to_string newvar) in*)
- match key.nexp with
- | Nuvar _ -> Nexpmap.insert substs (key,newvar)
- | _ -> begin set key newvar; substs end) Nexpmap.empty substs in
- let (substs, cs_rest) = extract_path_substs cs in
- (updated_substs::substs, CondCons(l,k,Some(updated_substs),ps,es)::cs_rest)
- | c::cs ->
- let (substs,cs_rest) = extract_path_substs cs in
- (substs,c::cs_rest)
-
-let rec merge_paths merge_nuvars = function
- | [] -> [],None
- | (BranchCons(co,_,branches) as b)::cs ->
- (*let _ = Printf.eprintf "merge_paths BranchCons case branch is %s\n\n" (constraints_to_string [b]) in*)
- let branches_merged,new_map = merge_paths merge_nuvars branches in
- let path_substs,branches_up = extract_path_substs branches_merged in
- let (shared_vars,new_cs,nm) = merge_branch_constraints merge_nuvars path_substs in
- let (rest_cs,rest_map) = merge_paths merge_nuvars cs in
- let out_map = merge_option_maps (merge_option_maps new_map nm) rest_map in
- (BranchCons(co,Some(shared_vars),branches_up)::(new_cs@rest_cs), out_map)
- | CondCons(co,k,substs,ps,es)::cs ->
- (*let _ = Printf.eprintf "merge_paths CondCons case: ps %s \n es %s\n\n" (constraints_to_string ps) (constraints_to_string es) in*)
- let (new_es,nm) = merge_paths merge_nuvars es in
- let (rest_cs,rest_map) = merge_paths merge_nuvars cs in
- let map = merge_option_maps nm rest_map in
- (CondCons(co,k,substs,ps,new_es)::rest_cs, map)
- | con::cs ->
- let (rest_cs, rest_map) = merge_paths merge_nuvars cs in
- (con::rest_cs, rest_map)
-
-let rec equate_nuvars in_env cs =
- (*let _ = Printf.eprintf "equate_nuvars\n" in*)
- let equate = equate_nuvars in_env in
- match cs with
- | [] -> []
- | (Eq(co,n1,n2) as c)::cs ->
- (match (n1.nexp,n2.nexp) with
- | Nuvar u1, Nuvar u2 ->
- (*let _ = Printf.eprintf "setting two nuvars, %s and %s in equate\n" (n_to_string n1) (n_to_string n2) in*)
- let occurs = (occurs_in_nexp n1 n2) || (occurs_in_nexp n2 n1) in
- (*let _ = Printf.eprintf "did they occur? %b\n" occurs in*)
- if not(occurs)
- then if (equate_n n1 n2) then equate cs else c::equate cs
- else c::equate cs
- | _ -> c::equate cs)
- | CondCons(co,kind,substs,pats,exps):: cs ->
- let pats' = equate pats in
- let exps' = equate exps in
- (match pats',exps' with
- | [],[] -> equate cs
- | _ -> CondCons(co,kind,substs,pats',exps')::(equate cs))
- | BranchCons(co,sv,branches)::cs ->
- let b' = equate branches in
- if [] = b'
- then equate cs
- else BranchCons(co,sv,b')::(equate cs)
- | c::cs -> c::(equate cs)
-
-
-let rec flatten_constraints = function
- | [] -> []
- | c::cs ->
- (match c with
- | CondCons(_,_,_,ps,es) -> flatten_constraints ps @ flatten_constraints es
- | BranchCons(_,_,bs) -> flatten_constraints bs
- | _ -> [c]) @ flatten_constraints cs
-
-let rec simple_constraint_check in_env cs =
- let check = simple_constraint_check in_env in
- (*let _ = Printf.eprintf "simple_constraint_check of %i constraints\n%!" (constraint_size cs) in*)
- match cs with
- | [] -> []
- | Eq(co,n1,n2)::cs ->
- let eq_to_zero ok_to_set n1 n2 =
- (*let _ = Printf.eprintf "eq_to_zero called with n1 %s and n2%s\n" (n_to_string n1) (n_to_string n2) in*)
- let new_n = normalize_nexp (mk_sub n1 n2) in
- (match new_n.nexp with
- | Nconst i ->
- if eq_big_int i zero
- then None
- else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires "
- ^ n_to_string new_n ^ " to equal 0, not " ^ string_of_big_int i)
- | Nuvar u1 ->
- if ok_to_set
- then if (equate_n new_n n_zero) then None else Some(Eq(co,new_n,n_zero))
- else Some(Eq(co,new_n,n_zero))
- | Nadd(new_n1,new_n2) ->
- (match new_n1.nexp, new_n2.nexp with
- | _ -> Some(Eq(co,n1,n2)))
- | _ -> Some(Eq(co,n1,n2))) in
- let check_eq ok_to_set n1 n2 =
- (*let _ = Printf.eprintf "eq check, about to normalize_nexp of %s, %s arising from %s \n"
- (n_to_string n1) (n_to_string n2) (co_to_string co) in*)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *)
- (match n1'.nexp,n2'.nexp,n1.nexp,n2.nexp with
- | Ninexact,nok,_,_ | nok,Ninexact,_,_ ->
- eq_error (get_c_loc co)
- ("Type constraint arising from here requires " ^ n_to_string {nexp = nok; imp_param = false}
- ^ " to be equal to +inf + -inf")
- | Npos_inf,Npos_inf,_,_ | Nneg_inf, Nneg_inf,_,_ -> None
- | Nconst i1, Nconst i2,_,_ | Nconst i1,N2n(_,Some(i2)),_,_ | N2n(_,Some(i1)),Nconst(i2),_,_ ->
- if eq_big_int i1 i2 then None
- else eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^
- " to equal " ^ n_to_string n2 )
- | Nuvar u1, Nuvar u2, _, _ ->
- (*let _ = Printf.eprintf "setting two nuvars, %s and %s, it is ok_to_set %b\n"
- (n_to_string n1) (n_to_string n2) ok_to_set in*)
- if nexp_eq_check n1 n2
- then None
- else
- let occurs = (occurs_in_nexp n1' n2') || (occurs_in_nexp n2' n1') in
- if ok_to_set && not(occurs)
- then if (equate_n n1' n2') then None else Some(Eq(co,n1',n2'))
- else if occurs then eq_to_zero ok_to_set n1' n2'
- else Some(Eq(co,n1',n2'))
- | _, Nuvar u, _, Nuvar _ ->
- (*let _ = Printf.eprintf "setting right nuvar\n" in*)
- let occurs = occurs_in_nexp n1' n2 in
- let leave = leave_nu_as_var (get_outer_most n2') in
- (*let _ = Printf.eprintf "occurs? %b, leave? %b n1' %s in n2' %s\n"
- occurs leave (n_to_string n1') (n_to_string n2') in*)
- if (*not(u.nin) &&*) ok_to_set && not(occurs) && not(leave)
- then if (equate_n n2 n1) then None else (Some (Eq(co,n1',n2')))
- else if occurs
- then eq_to_zero ok_to_set n1' n2'
- else Some (Eq(co,n1',n2'))
- | Nuvar u, _,Nuvar _, _ ->
- (*let _ = Printf.eprintf "setting left nuvar\n" in*)
- let occurs = occurs_in_nexp n2' n1 in
- let leave = leave_nu_as_var (get_outer_most n1') in
- (*let _ = Printf.eprintf "occurs? %b, leave? %b n2' %s in n1' %s\n"
- occurs leave (n_to_string n2') (n_to_string n1') in*)
- if (*not(u.nin) &&*) ok_to_set && not(occurs) && not(leave)
- then if equate_n n1 n2 then None else (Some (Eq(co,n1,n2)))
- else if occurs
- then eq_to_zero ok_to_set n1' n2'
- else Some (Eq(co,n1',n2'))
- | _,_,_,_ ->
- if nexp_eq_check n1' n2'
- then None
- else eq_to_zero ok_to_set n1' n2')
- in
- (match check_eq true n1 n2 with
- | None -> (check cs)
- | Some(c) -> c::(check cs))
- | NtEq(co,n1,n2)::cs ->
- let nt_eq_to_zero n1 n2 =
- (*let _ = Printf.eprintf "nt_eq_to_zero called with n1 %s and n2%s\n" (n_to_string n1) (n_to_string n2) in*)
- let new_n = normalize_nexp (mk_sub n1 n2) in
- (match new_n.nexp with
- | Nconst i ->
- if eq_big_int i zero
- then eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires "
- ^ n_to_string new_n ^ " to not equal 0")
- else None
- | _ -> Some(NtEq(co,n1,n2))) in
- let check_not_eq n1 n2 =
- (*let _ = Printf.eprintf "not eq check, about to normalize_nexp of %s, %s arising from %s \n"
- (n_to_string n1) (n_to_string n2) (co_to_string co) in*)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *)
- (match n1'.nexp,n2'.nexp with
- | Ninexact,nok | nok,Ninexact ->
- eq_error (get_c_loc co)
- ("Type constraint arising from here requires " ^ n_to_string {nexp = nok; imp_param = false} ^
- " to be compared to +inf + -inf")
- | Npos_inf,Npos_inf | Nneg_inf, Nneg_inf ->
- eq_error (get_c_loc co)
- ("Type constraint arising from here requires " ^ n_to_string n1' ^ " to be not = to " ^ n_to_string n2')
- | Nconst i1, Nconst i2 | Nconst i1,N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst(i2) ->
- if eq_big_int i1 i2
- then eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^
- " to not equal " ^ n_to_string n2 )
- else None
- | _,_ ->
- if nexp_eq_check n1' n2'
- then eq_error (get_c_loc co)
- ("Type constraing mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to not equal " ^
- n_to_string n2)
- else nt_eq_to_zero n1' n2')
- in
- (match check_not_eq n1 n2 with
- | None -> (check cs)
- | Some(c) -> c::(check cs))
- | GtEq(co,enforce,n1,n2)::cs ->
- (*let _ = Printf.eprintf ">= check, about to normalize_nexp of %s, %s\n"
- (n_to_string n1) (n_to_string n2) in *)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in*)
- (match n1'.nexp,n2'.nexp with
- | Nconst i1, Nconst i2 | Nconst i1,N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 ->
- if ge_big_int i1 i2
- then check cs
- else eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint of " ^ n_to_string n1 ^ " >= " ^ n_to_string n2 ^
- " arising from here requires "
- ^ string_of_big_int i1 ^ " to be greater than or equal to " ^ string_of_big_int i2)
- | Npos_inf, _ | _, Nneg_inf -> check cs
- | Nconst _ ,Npos_inf ->
- eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires "
- ^ (n_to_string n1') ^ " to be greater than or equal to infinity")
-(* | Nneg_inf,Nuvar _ ->
- if equate_n n2' n1' then check cs else (GtEq(co,enforce,n1',n2')::check cs)
- | Nneg_inf, _ ->
- eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires negative infinity to be >= to "
- ^ (n_to_string n2')) *)
- | Nuvar _, _ | _, Nuvar _ -> GtEq(co,enforce, n1, n2)::(check cs)
- | _,_ ->
- (match nexp_ge n1' n2' with
- | Yes -> check cs
- | No -> eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to be >= to " ^
- (n_to_string n2))
- | Maybe ->
- let new_n = normalize_nexp (mk_sub n1' n2') in
- (match new_n.nexp with
- | Nconst i ->
- if ge_big_int i zero
- then (check cs)
- else eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires "
- ^ n_to_string new_n ^ " to be greater than or equal to 0, not " ^ string_of_big_int i)
- | _ -> GtEq(co,enforce,n1',n2')::(check cs))))
- | Gt(co,enforce,n1,n2)::cs ->
- (*let _ = Printf.eprintf "> check, about to normalize_nexp of %s, %s\n"
- (n_to_string n1) (n_to_string n2) in *)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in*)
- (match nexp_gt n1' n2' with
- | Yes -> check cs
- | No -> eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to be > to " ^
- (n_to_string n2))
- | Maybe ->
- let new_n = normalize_nexp (mk_sub n1' n2') in
- (match new_n.nexp with
- | Nconst i ->
- if gt_big_int i zero
- then (check cs)
- else eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires "
- ^ n_to_string new_n ^ " to be greater than or equal to 0, not " ^ string_of_big_int i)
- | _ -> Gt(co,enforce,n1',n2')::(check cs)))
- | LtEq(co,enforce,n1,n2)::cs ->
- (*let _ = Printf.eprintf "<= check, about to normalize_nexp of %s, %s\n"
- (n_to_string n1) (n_to_string n2) in *)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *)
- (match n1'.nexp,n2'.nexp with
- | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 ->
- if le_big_int i1 i2
- then check cs
- else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires "
- ^ string_of_big_int i1 ^ " to be less than or equal to " ^ string_of_big_int i2)
- | _, Npos_inf | Nneg_inf, _ -> check cs
- | Nuvar _, _ | _, Nuvar _ -> LtEq(co,enforce, n1, n2)::(check cs)
- | _,_ ->
- (match nexp_ge n2' n1' with
- | Yes -> check cs
- | No -> eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^
- " to be less than or equal to " ^ (n_to_string n2))
- | Maybe -> LtEq(co,enforce,n1',n2')::(check cs)))
- | Lt(co,enforce,n1,n2)::cs ->
- (*let _ = Printf.eprintf "< check, about to normalize_nexp of %s, %s\n"
- (n_to_string n1) (n_to_string n2) in *)
- let n1',n2' = normalize_nexp n1,normalize_nexp n2 in
- (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *)
- (match n1'.nexp,n2'.nexp with
- | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 ->
- if lt_big_int i1 i2
- then check cs
- else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires "
- ^ string_of_big_int i1 ^ " to be less than " ^ string_of_big_int i2)
- | _, Npos_inf | Nneg_inf, _ -> check cs
- | _,_ ->
- (match nexp_gt n2' n1' with
- | Yes -> check cs
- | No -> eq_error (get_c_loc co)
- ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^
- " to be less than " ^ (n_to_string n2))
- | Maybe -> Lt(co,enforce,n1',n2')::(check cs)))
- | CondCons(co,kind,substs,pats,exps):: cs ->
- (*let _ = Printf.eprintf "Condcons check length pats %i, length exps %i\n"
- (constraint_size pats) (constraint_size exps) in*)
- let pats' = check pats in
- let exps' = check exps in
- (*let _ = Printf.eprintf "Condcons after check length pats' %i, length exps' %i\n"
- (constraint_size pats') (constraint_size exps') in*)
- (match pats',exps',substs with
- | [],[],None -> check cs
- | _ -> CondCons(co,kind,substs,pats',exps')::(check cs))
- | BranchCons(co,sv,branches)::cs ->
- (*let _ = Printf.eprintf "BranchCons pre_check with %i branches and %i for after\n" (constraint_size branches) (constraint_size cs) in*)
- let b = check branches in
- (*let _ = Printf.eprintf "Branchcons check length branches before %i and after %i with %i remaining after\n"
- (constraint_size branches) (constraint_size b) (constraint_size cs) in*)
- if [] = b
- then check cs
- else BranchCons(co,sv,b)::(check cs)
- | Predicate _::cs -> check cs
- | x::cs ->
- (*let _ = Printf.eprintf "In default case with %s\n%!" (constraints_to_string [x]) in*)
- x::(check cs)
-
-let rec resolve_in_constraints cs = cs
-
-let tri_to_bl c =
- match c with
- | Yes | Maybe -> true
- | _ -> false
-
-type var_side = Left | Right | Neither
-
-let reform_nexps nv lft rght =
- let contains_left, contains_right = contains_nuvar_nexp nv lft, contains_nuvar_nexp nv rght in
- if contains_left && contains_right
- then
- match isolate_nexp nv lft, isolate_nexp nv rght with
- | (Some varl, Some factorl, lft_rst), (Some varr, Some factorr, rght_rst) ->
- if nexp_eq factorl factorr && nexp_eq varl varr
- then None, normalize_nexp (mk_sub rght_rst lft_rst), Neither
- else None, normalize_nexp (mk_sub rght lft), Neither (*Hard cases, let's punt for now*)
- | (Some varl, Some factor, lft_rst), (Some varr, None, rght_rst) ->
- if nexp_eq varl varr
- then Some (normalize_nexp (mk_mult (mk_sub factor n_one) varl)),
- normalize_nexp (mk_sub rght_rst (mk_mult factor lft_rst)), Left
- else None, normalize_nexp (mk_sub rght lft), Neither (*More hard cases*)
- | (Some varl, None, lft_rst), (Some varr, Some factor, rght_rst) ->
- if nexp_eq varl varr
- then Some (normalize_nexp (mk_mult (mk_add factor n_one) varl)),
- normalize_nexp (mk_sub (mk_mult factor rght_rst) lft_rst), Left
- else None, normalize_nexp (mk_sub rght lft), Neither (*More hard cases*)
- | (Some varl, None, lft_rst), (Some varr, None, rght_rst) ->
- if nexp_eq varl varr
- then None, normalize_nexp (mk_sub rght_rst lft_rst), Neither
- else None, normalize_nexp (mk_sub rght lft), Neither
- | (None,_,_),(_,_,_) | (_,_,_),(None,_,_) -> assert false
- else if contains_left
- then
- match isolate_nexp nv lft with
- | (Some var, Some factor, lft_rst) ->
- if divisible_by rght factor
- then Some var, normalize_nexp (mk_sub (divide_by rght factor) lft_rst),Left
- else Some (mk_mult var factor), normalize_nexp (mk_sub rght (mk_mult factor lft_rst)),Left
- | Some var, None, lft_rst -> Some var, normalize_nexp (mk_sub rght lft_rst),Left
- | None, _, lft -> None,normalize_nexp (mk_sub rght lft),Neither
- else if contains_right
- then match isolate_nexp nv rght with
- | (Some var, Some factor, rgt_rst) ->
- if divisible_by lft factor
- then Some var, normalize_nexp (mk_sub (divide_by lft factor) rgt_rst),Right
- else Some (mk_mult var factor), normalize_nexp (mk_sub lft (mk_mult factor rgt_rst)),Right
- | Some var, None, rgt_rst -> Some var, normalize_nexp (mk_sub lft rgt_rst),Right
- | None, _, rght -> None,normalize_nexp (mk_sub rght lft),Neither
- else None, normalize_nexp (mk_sub rght lft), Neither
-
-let iso_builder nuv builder co enforce lft rgt =
- match reform_nexps nuv lft rgt with
- | Some v, nexp_term, Left ->
- builder co enforce v nexp_term
- | Some v, nexp_term, Right ->
- builder co enforce nexp_term v
- | None,nexp_term,Neither ->
- builder co enforce n_zero nexp_term
- | _ -> assert false (*Should be unreachable*)
-
-let rec isolate_constraint nuv constraints = match constraints with
- | [] -> []
- | c::cs ->
- (match c with
- | LtEq(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> LtEq(c,e,l,r)) co enforce lft rgt
- | Lt(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> Lt(c,e,l,r)) co enforce lft rgt
- | GtEq(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> GtEq(c,e,l,r)) co enforce lft rgt
- | Gt(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> Gt(c,e,l,r)) co enforce lft rgt
- | _ -> c)::isolate_constraint nuv cs
-
-let check_range_consistent require_lt require_gt guarantee_lt guarantee_gt =
- match require_lt,require_gt,guarantee_lt,guarantee_gt with
- | None,None,None,None
- | Some _, None, None, None | None, Some _ , None, None | None, None, Some _ , None | None, None, None, Some _
- | Some _, Some _,None,None | None,None,Some _,Some _ (*earlier check should ensure these*)
- -> ()
- | Some(crlt,rlt), Some(crgt,rgt), Some(cglt,glt), Some(cggt,ggt) ->
- if tri_to_bl (nexp_ge rlt glt) (*Can we guarantee the up is less than the required up*)
- then if tri_to_bl (nexp_ge rlt ggt) (*Can we guarantee the lw is less than the required up*)
- then if tri_to_bl (nexp_ge glt rgt) (*Can we guarantee the up is greater than the required lw*)
- then if tri_to_bl (nexp_ge ggt rgt) (*Can we guarantee that the lw is greater than the required lw*)
- then ()
- else multi_constraint_error cggt crgt ("Constraints arising from these locations requires greater than "
- ^ (n_to_string rgt) ^ " but best guarantee is " ^ (n_to_string ggt))
- else multi_constraint_error cglt crgt ("Constraints arising from these locations guarantees a number no greather than " ^ (n_to_string glt) ^ " but requires a number greater than " ^ (n_to_string rgt))
- else multi_constraint_error crlt cggt ("Constraints arising from these locations guarantees a number that is less than " ^ (n_to_string rlt) ^ " but best guarantee is " ^ (n_to_string ggt))
- else multi_constraint_error crlt cglt ("Constraints arising from these locations require no more than " ^ (n_to_string rlt) ^ " but guarantee indicates it may be above " ^ (n_to_string glt))
- | _ ->
- (*let _ = Printf.eprintf "check_range_consistent is in the partial case\n" in*)
- ()
-
-let check_ranges cs =
- (*let _ = Printf.eprintf "In check_ranges with %i constraints\n%!" (constraint_size cs) in*)
- let nuvars = get_all_nuvars_cs cs in
- (*let _ = Printf.eprintf "Have %i nuvars\n" (List.length (Var_set.elements nuvars)) in*)
- let nus_with_cs = List.map (fun n -> (n,contains_nuvar n cs)) (Var_set.elements nuvars) in
- let nus_with_iso_cs = List.map (fun (n,ncs) -> (n,isolate_constraint n ncs)) nus_with_cs in
- let refined_cs = List.concat (List.map (fun (n,ncs) ->
- let guarantees,max_guarantee_lt,min_guarantee_gt =
- refine_guarantees false None None n (flatten_constraints ncs) in
- let require_cs,min_require_lt,max_require_gt = refine_requires false None None n guarantees in
- check_range_consistent min_require_lt max_require_gt max_guarantee_lt min_guarantee_gt;
- require_cs)
- nus_with_iso_cs)
- in
- refined_cs
-
-let do_resolve_constraints = ref true
-
-let resolve_constraints cs =
- (*let _ = Printf.eprintf "called resolve constraints with %i constraints\n" (constraint_size cs) in*)
- if not !do_resolve_constraints
- then (cs,None)
- else
- let rec fix checker len cs =
- (*let _ = Printf.eprintf "Calling fix check thunk, fix check point is %i\n%!" len in *)
- let cs' = checker (in_constraint_env cs) cs in
- let len' = constraint_size cs' in
- if len > len' then fix checker len' cs'
- else cs' in
- (*let _ = Printf.eprintf "Original constraints are %s\n%!" (constraints_to_string cs) in*)
- let branch_freshened = prepare_constraints cs in
- (*let _ = Printf.eprintf "Constraints after prepare constraints are %s\n"
- (constraints_to_string branch_freshened) in*)
- let nuvar_equated = fix equate_nuvars (constraint_size branch_freshened) branch_freshened in
- (*let _ = Printf.eprintf "Constraints after nuvar equated are %s\n%!" (constraints_to_string nuvar_equated) in*)
- let complex_constraints =
- fix (fun in_env cs -> let (ncs,_) = merge_paths false (simple_constraint_check in_env cs) in ncs)
- (constraint_size nuvar_equated) nuvar_equated in
- (*let _ = Printf.eprintf "Now considering %i constraints \n%!" (constraint_size complex_constraints) in*)
- let (complex_constraints,map) = merge_paths true complex_constraints in
- let complex_constraints = check_ranges complex_constraints in
- (*let _ = Printf.eprintf "Resolved as many constraints as possible, leaving %i\n"
- (constraint_size complex_constraints) in
- let _ = Printf.eprintf "%s\n" (constraints_to_string complex_constraints) in*)
- (complex_constraints,map)
-
-
-let check_tannot l annot imp_param constraints efs =
- match annot with
- | Base((params,t),tag,cs,ef,_,bindings) ->
- let efs = remove_local_effects efs in
- ignore(effects_eq (Specc l) efs ef);
- let s_env = (t_remove_unifications Envmap.empty t) in
- let params = Envmap.to_list s_env in
- ignore (remove_internal_unifications s_env);
- let t' = match (t.t,imp_param) with
- | Tfn(p,r,_,e),Some x -> {t = Tfn(p,r,IP_user x,e) }
- | _ -> t in
- Base((params,t'),tag,cs,ef,pure_e,bindings)
- | NoTyp -> raise (Reporting_basic.err_unreachable l "check_tannot given the place holder annotation")
- | Overload _ -> raise (Reporting_basic.err_unreachable l "check_tannot given overload")
-
-let tannot_merge co denv widen t_older t_newer =
- (*let _ = Printf.eprintf "tannot_merge called\n" in*)
- match t_older,t_newer with
- | NoTyp,NoTyp -> NoTyp
- | NoTyp,_ -> t_newer
- | _,NoTyp -> t_older
- | Base((ps_o,t_o),tag_o,cs_o,efl_o,_,bounds_o),Base((ps_n,t_n),tag_n,cs_n,efl_n,_,bounds_n) ->
- (match tag_o,tag_n with
- | Default,tag ->
- (match t_n.t with
- | Tuvar _ -> let t_o,cs_o,ef_o,_ = subst ps_o false false t_o cs_o efl_o in
- let t,_ = type_consistent co denv Guarantee false t_n t_o in
- Base(([],t),tag_n,cs_o,ef_o,pure_e,bounds_o)
- | _ -> t_newer)
- | Emp_local, Emp_local ->
- (*let _ = Printf.eprintf "local-local case\n" in*)
- if conforms_to_t denv true false t_n t_o
- then
- let t,cs_b = type_consistent co denv Guarantee widen t_n t_o in
- (*let _ = Printf.eprintf "types consistent\n" in*)
- Base(([],t),Emp_local,cs_o@cs_n@cs_b,union_effects efl_o efl_n,pure_e, merge_bounds bounds_o bounds_n)
- else Base(([],t_n),Emp_local,cs_n,efl_n,pure_e,bounds_n)
- | _,_ -> t_newer)
- | _ -> t_newer
diff --git a/src/type_internal.mli b/src/type_internal.mli
deleted file mode 100644
index f4924a63..00000000
--- a/src/type_internal.mli
+++ /dev/null
@@ -1,391 +0,0 @@
-(**************************************************************************)
-(* Sail *)
-(* *)
-(* Copyright (c) 2013-2017 *)
-(* Kathyrn Gray *)
-(* Shaked Flur *)
-(* Stephen Kell *)
-(* Gabriel Kerneis *)
-(* Robert Norton-Wright *)
-(* Christopher Pulte *)
-(* Peter Sewell *)
-(* *)
-(* All rights reserved. *)
-(* *)
-(* This software was developed by the University of Cambridge Computer *)
-(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
-(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
-(* *)
-(* Redistribution and use in source and binary forms, with or without *)
-(* modification, are permitted provided that the following conditions *)
-(* are met: *)
-(* 1. Redistributions of source code must retain the above copyright *)
-(* notice, this list of conditions and the following disclaimer. *)
-(* 2. Redistributions in binary form must reproduce the above copyright *)
-(* notice, this list of conditions and the following disclaimer in *)
-(* the documentation and/or other materials provided with the *)
-(* distribution. *)
-(* *)
-(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
-(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
-(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
-(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
-(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
-(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
-(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
-(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
-(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
-(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
-(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
-(* SUCH DAMAGE. *)
-(**************************************************************************)
-
-open Big_int
-
-module Envmap : Finite_map.Fmap with type k = string
-module Nameset : sig
- include Set.S with type elt = string
- val pp : Format.formatter -> t -> unit
-end
-
-val zero : big_int
-val one : big_int
-val two : big_int
-
-(*Trinary replacement for boolean, as sometimes we do want to distinguish we just don't know from a certain yes or no*)
-type triple = Yes | No | Maybe
-val triple_negate : triple -> triple
-
-type kind = { mutable k : k_aux }
-and k_aux =
- | K_Typ
- | K_Nat
- | K_Ord
- | K_Efct
- | K_Val
- | K_Lam of kind list * kind
- | K_infer
-
-type t_uvar
-type n_uvar
-type e_uvar
-type o_uvar
-type t = { mutable t : t_aux }
-(*No recursive t will ever be Tfn *)
-and t_aux =
- | Tvar of string (* concrete *)
- | Tid of string (* concrete *)
- | Tfn of t * t * implicit_parm * effect (* concrete *)
- | Ttup of t list (* concrete *)
- | Tapp of string * t_arg list (* concrete *)
- | Tabbrev of t * t (* first t is the type from the source; second is the actual ground type, never abbrev *)
- | Toptions of t * t option (* used in overloads or cast; first is always concrete. Removed in type checking *)
- | Tuvar of t_uvar (* Unification variable *)
-(*Implicit nexp parameters for library and special function calls*)
-and implicit_parm =
- | IP_none (*Standard function*)
- | IP_length of nexp (*Library function to take length of a vector as first parameter*)
- | IP_start of nexp (*Library functions to take start of a vector as first parameter*)
- | IP_user of nexp (*Special user functions, must be declared with val, will pass stated parameter to function from return type*)
-and nexp = { mutable nexp : nexp_aux ; mutable imp_param : bool}
-and nexp_aux =
- | Nvar of string
- | Nid of string * nexp
- | Nconst of big_int
- | Npos_inf (* Used to define nat and int types, does not arise from source otherwise *)
- | Nneg_inf (* Used to define int type, does not arise from source otherwise *)
- | Nadd of nexp * nexp
- | Nsub of nexp * nexp
- | Nmult of nexp * nexp
- | N2n of nexp * big_int option (* Optionally contains the 2^n result for const n, for different constraint equations *)
- | Npow of nexp * int (* Does not appear in source *)
- | Nneg of nexp (* Does not appear in source *)
- | Ninexact (*Does not appear in source*)
- | Nuvar of n_uvar (* Unification variable *)
-and effect = { mutable effect : effect_aux }
-and effect_aux =
- | Evar of string
- | Eset of Ast.base_effect list
- | Euvar of e_uvar (* Unificiation variable *)
-and order = { mutable order : order_aux }
-and order_aux =
- | Ovar of string
- | Oinc
- | Odec
- | Ouvar of o_uvar (* Unification variable *)
-and t_arg =
- | TA_typ of t
- | TA_nexp of nexp
- | TA_eft of effect
- | TA_ord of order
-
-module Nexpmap : Finite_map.Fmap with type k = nexp
-type nexp_map = nexp Nexpmap.t
-
-type alias_inf =
- | Alias_field of string * string
- | Alias_extract of string * int * int
- | Alias_pair of string * string
-
-type tag =
- | Emp_local (* Standard value, variable, expression *)
- | Emp_global (* Variable from global instead of local scope *)
- | Emp_intro (* Local mutable variable, and this is its introduction *)
- | Emp_set (* Local mutable expression being set *)
- | Tuple_assign of tag list (* Tuple of assignments, should not be External, Default, Construct, etc*)
- | External of string option (* External function or register name *)
- | Default (* Variable has default type, has not been bound *)
- | Constructor of int (* Variable is a data constructor, int says how many variants are in this family *)
- | Enum of int (* Variable came from an enumeration, int tells me the highest possible numeric value *)
- | Alias of alias_inf (* Variable came from a register alias *)
- | Spec (* Variable came from a val specification *)
-
-type constraint_origin =
- | Patt of Parse_ast.l
- | Expr of Parse_ast.l
- | Fun of Parse_ast.l
- | Specc of Parse_ast.l
-
-type range_enforcement = Require | Guarantee
-type cond_kind = Positive | Negative | Solo | Switch
-type 'a many = One of 'a | Two of 'a * 'a | Many of 'a list
-
-(* Constraints for nexps, plus the location which added the constraint *)
-type nexp_range =
- | LtEq of constraint_origin * range_enforcement * nexp * nexp
- | Lt of constraint_origin * range_enforcement * nexp * nexp
- | Eq of constraint_origin * nexp * nexp
- | NtEq of constraint_origin * nexp * nexp
- | GtEq of constraint_origin * range_enforcement * nexp * nexp
- | Gt of constraint_origin * range_enforcement * nexp * nexp
- | In of constraint_origin * string * int list
- (* InS holds the nuvar after a substitution *)
- | InS of constraint_origin * nexp * int list
- (* Predicate treats the first constraint as holding in positive condcons, the second in negative:
- must be one of LtEq, Eq, or GtEq, never In, Predicate, Cond, or Branch *)
- | Predicate of constraint_origin * nexp_range * nexp_range
- (* Constraints from one path from a conditional (pattern or if) and the constraints from that conditional *)
- | CondCons of constraint_origin * cond_kind * (nexp Nexpmap.t) option * nexp_range list * nexp_range list
- (* CondCons constraints from all branches of a conditional; list should be all CondCons *)
- | BranchCons of constraint_origin * ((nexp many) Nexpmap.t) option * nexp_range list
-
-val get_c_loc : constraint_origin -> Parse_ast.l
-
-val n_zero : nexp
-val n_one : nexp
-val n_two : nexp
-val mk_nv : string -> nexp
-val mk_nid : string -> nexp -> nexp
-val mk_add : nexp -> nexp -> nexp
-val mk_sub : nexp -> nexp -> nexp
-val mk_mult : nexp -> nexp -> nexp
-val mk_c : big_int -> nexp
-val mk_c_int : int -> nexp
-val mk_neg : nexp -> nexp
-val mk_2n : nexp -> nexp
-val mk_2nc : nexp -> big_int -> nexp
-val mk_pow : nexp -> int -> nexp
-val mk_p_inf : unit -> nexp
-val mk_n_inf : unit -> nexp
-val mk_inexact : unit -> nexp
-val set_imp_param : nexp -> unit
-
-val mk_atom : nexp -> t
-val mk_tup : t list -> t
-val mk_vector : t -> order -> nexp -> nexp -> t
-
-type variable_range =
- | VR_eq of string * nexp
- | VR_range of string * nexp_range list
- | VR_vec_eq of string * nexp
- | VR_vec_r of string * nexp_range list
- | VR_recheck of string * t (*For cases where inference hasn't yet determined the type of v*)
-
-type bounds_env =
- | No_bounds
- | Bounds of variable_range list * nexp_map option
-
-type t_params = (string * kind) list
-type tannot =
- | NoTyp
- (*A type of a function, variable, expression, etc, that is not overloaded:
- the first effect is for local effects to the current expression or variable
- the second effect is the cummulative effects of any contained subexpressions where applicable, pure otherwise *)
- | Base of (t_params * t) * tag * nexp_range list * effect * effect * bounds_env
- (* First tannot is the most polymorphic version; the list includes all variants. All t to be Tfn *)
- | Overload of tannot * bool * tannot list
-
-type 'a emap = 'a Envmap.t
-
-type rec_kind = Record | Register
-type rec_env = (string * rec_kind * tannot * ((string * t) list))
-type alias_kind = OneReg of string * tannot | TwoReg of string * string * tannot | MultiReg of (string list) * tannot
-type def_envs = {
- k_env: kind emap;
- abbrevs: tannot emap;
- nabbrevs: nexp emap;
- namesch : tannot emap;
- enum_env : (string list) emap;
- rec_env : rec_env list;
- alias_env : alias_kind emap;
- default_o : order;
- }
-
-type exp = tannot Ast.exp
-
-type minmax = (constraint_origin * nexp) option
-type constraints = nexp_range list
-
-
-val lookup_record_typ : string -> rec_env list -> rec_env option
-val lookup_record_fields : string list -> rec_env list -> rec_env option
-val lookup_possible_records : string list -> rec_env list -> rec_env list
-val lookup_field_type : string -> rec_env -> t option
-
-val add_effect : Ast.base_effect -> effect -> effect
-val union_effects : effect -> effect -> effect
-val e_to_string : effect -> string
-val has_rreg_effect : effect -> bool
-val has_wreg_effect : effect -> bool
-val has_rmem_effect : effect -> bool
-val has_rmemt_effect : effect -> bool
-val has_wmem_effect : effect -> bool
-val has_eamem_effect : effect -> bool
-val has_exmem_effect : effect -> bool
-val has_memv_effect : effect -> bool
-val has_memvt_effect : effect -> bool
-val has_lret_effect : effect -> bool
-
-val initial_kind_env : kind Envmap.t
-val initial_abbrev_env : tannot Envmap.t
-val initial_typ_env : tannot Envmap.t
-val nat_t : t
-val unit_t : t
-val int64_t : t
-val bool_t : t
-val bit_t : t
-val string_t : t
-val pure_e : effect
-val nob : bounds_env
-
-val simple_annot : t -> tannot
-val simple_annot_efr : t -> effect -> tannot
-val global_annot : t -> tannot
-val tag_annot : t -> tag -> tannot
-val tag_annot_efr : t -> tag -> effect -> tannot
-val constrained_annot : t -> constraints -> tannot
-val constrained_annot_efr : t -> constraints -> effect -> tannot
-val bounds_annot : t -> bounds_env -> tannot
-val bounds_annot_efr : t -> bounds_env -> effect -> tannot
-val cons_tag_annot : t -> tag -> constraints -> tannot
-val cons_tag_annot_efr : t -> tag -> constraints -> effect -> tannot
-val cons_efl_annot : t -> constraints -> effect -> tannot
-val cons_efs_annot : t -> constraints -> effect -> effect -> tannot
-val efs_annot : t -> effect -> effect -> tannot
-val tag_efs_annot: t -> tag -> effect -> effect -> tannot
-val cons_bs_annot : t -> constraints -> bounds_env -> tannot
-val cons_bs_annot_efr : t -> constraints -> bounds_env -> effect -> tannot
-
-val kind_to_string : kind -> string
-val t_to_string : t -> string
-val n_to_string : nexp -> string
-val constraints_to_string : constraints -> string
-val bounds_to_string : bounds_env -> string
-val tannot_to_string : tannot -> string
-val t_to_typ : t -> Ast.typ
-
-val int_to_nexp : int -> nexp
-
-val reset_fresh : unit -> unit
-val new_t : unit -> t
-val new_n : unit -> nexp
-val new_o : unit -> order
-val new_e : unit -> effect
-val equate_t : t -> t -> unit
-
-val typ_subst : t_arg emap -> bool -> t -> t
-val subst : (Envmap.k * kind) list -> bool -> bool -> t -> constraints -> effect -> t * constraints * effect * t_arg emap
-val subst_with_env : t_arg emap -> bool -> t -> nexp_range list -> effect -> t * constraints * effect * t_arg emap
-val subst_n_with_env : t_arg emap -> nexp -> nexp
-val type_param_consistent : Parse_ast.l -> t_arg emap -> t_arg emap -> nexp_range list
-
-val get_abbrev : def_envs -> t -> (t * nexp_range list)
-
-val is_enum_typ : def_envs -> t -> int option
-val is_bit_vector : t -> bool
-val has_const_vector_length : t -> big_int option
-
-val extract_bounds : def_envs -> string -> t -> bounds_env
-val merge_bounds : bounds_env -> bounds_env -> bounds_env
-val find_var_from_nexp : nexp -> bounds_env -> (string option * string) option
-val add_map_to_bounds : nexp_map -> bounds_env -> bounds_env
-val add_map_tannot : nexp_map -> tannot -> tannot
-val get_map_tannot : tannot -> nexp_map option
-val merge_option_maps : nexp_map option -> nexp_map option -> nexp_map option
-
-val expand_nexp : nexp -> nexp list
-val normalize_nexp : nexp -> nexp
-val normalize_t : t -> t
-val get_index : nexp -> int (*expose nindex through this for debugging purposes*)
-val get_all_nvar : nexp -> string list (*Pull out all of the contained nvar and nuvars in nexp*)
-
-val select_overload_variant : def_envs -> bool -> bool -> tannot list -> t -> tannot list
-
-(*splits constraints into always, positive, negative constraints; where positive and negative happen for predicates *)
-val split_conditional_constraints : constraints -> (constraints * constraints * constraints)
-
-(*May raise an exception if a contradiction is found*)
-val resolve_constraints : constraints -> (constraints * nexp_map option)
-(* whether to actually perform constraint resolution or not *)
-val do_resolve_constraints : bool ref
-
-(*May raise an exception if effects do not match tannot effects,
- will lift unification variables to fresh type variables *)
-val check_tannot : Parse_ast.l -> tannot -> nexp option -> constraints -> effect -> tannot
-
-val nexp_eq_check : nexp -> nexp -> bool (*structural equality only*)
-val nexp_eq : nexp -> nexp -> bool
-val nexp_one_more_than : nexp -> nexp -> bool
-
-(*Selects the subset of given list where an nexp_range contains the given nexp, presumed to be an nvar*)
-val contains_nvar : nexp -> constraints -> constraints
-(*As above but with nuvars*)
-val contains_nuvar : nexp -> constraints -> constraints
-(*Removes first nexp from second nexp, when first nexp is a nuvar or nvar.
- If it isn't possible to remove the first nexp fully and leave integral values on the resulting nexp
- i.e. if we have isolate_nexp 'i (8*i) + 3), then we return the nexp and any non-removable factors
- (this may include 2 ^^ 'x)
-*)
-val isolate_nexp : nexp -> nexp -> (nexp option * nexp option * nexp)
-val refine_requires: bool -> minmax -> minmax -> Nexpmap.k -> constraints -> constraints * minmax * minmax
-val refine_guarantees: bool -> minmax-> minmax -> Nexpmap.k -> constraints -> constraints * minmax * minmax
-
-
-(*type relations*)
-
-val conforms_to_t : def_envs -> bool -> bool -> t -> t -> bool
-
-(* type_consistent is similar to a standard type equality, except in the case of [[consistent t1 t2]] where
- t1 and t2 are both range types and t1 is contained within the range of t2: i.e.
- range<2, 5> is consistent with range<0, 10>, but not vice versa.
- Similar for atom.
- When widen, two atoms are used to generate a range that contains them (or is defined by them for constants; and an atom and a range may widen the range.
- type_consistent mutates uvars to perform unification and will raise an error if the [[t1]] and [[t2]] are inconsistent
-*)
-val type_consistent : constraint_origin -> def_envs -> range_enforcement -> bool -> t -> t -> t * constraints
-
-(* type_coerce mutates to unify variables, and will raise an exception if the first type cannot
- be coerced into the second and is additionally inconsistent with the second;
- bool specifices whether this has arisen from an implicit or explicit type coercion request
- type_coerce origin envs enforce is_explicit (ie came from user) widen bounds t exp expect_t
- *)
-val type_coerce : constraint_origin -> def_envs -> range_enforcement -> bool -> bool -> bounds_env -> t -> exp -> t -> t * constraints * effect * exp
-
-(* Merge tannots when intersection or unioning two environments. In case of default types, defer to tannot on right
- When merging atoms, use bool to control widening.
-*)
-val tannot_merge : constraint_origin -> def_envs -> bool -> tannot -> tannot -> tannot
-
-val initial_typ_env : tannot Envmap.t
-
-val initial_typ_env_list : (string * ((string * tannot) list)) list
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-09 08:27:22 +0000